find_input_switch_.pl1 11/18/82 1708.0rew 11/18/82 1629.5 28332 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ find_input_switch_: proc (a_info_p, a_block, a_sw_idx, a_code); /* This procedure accepts a list of IO switches and searches for the first one in the list which has input available for a successful read operation (get_chars) without blocking. The index of this iocbp in the info structure is returned. If no switch currently has input available, the procedure will either block until input is available or return an index of zero as determined by the a_block bit. */ /* Written by J. C. Whitmore, Feb 1980 */ dcl a_info_p ptr parameter; /* pointer to the switch info structure (INPUT) */ dcl a_block bit (1); /* TRUE - if we are to block until input is available (INPUT) */ dcl a_sw_idx fixed bin; /* index of iocbp to be read (OUTPUT) */ dcl a_code fixed bin (35); /* system error code (OUTPUT) */ dcl max_switches fixed bin; dcl idx fixed bin; dcl 1 read_info aligned, /* for the read_status control order */ 2 read_ev_chan fixed bin (71), 2 input_available bit (1) unal; dcl 1 wait_info aligned, /* data returned from ipc_$block */ 2 ev_chan fixed bin (71), 2 ev_msg fixed bin (71), 2 sender_proc_id bit (36), 2 origin fixed bin, 2 wait_list_idx fixed bin; dcl convert_ipc_code_ entry (fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$unimplemented_version fixed bin (35) ext; dcl addr builtin; %include find_input_sw_info; a_sw_idx, a_code = 0; /* clear the output values */ sw_info_p = a_info_p; /* set up automatic based references */ if sw_info.version ^= sw_info_version_1 then do; /* enforce the version number */ a_code = error_table_$unimplemented_version; return; end; max_switches = sw_info.n_iocb_ptrs; /* there is one ipc_ channel per iocbp */ if max_switches ^= sw_info.n_channels then do; /* just a consistency check */ no_go: a_code = error_table_$bad_arg; return; end; check_for_input: read_info.input_available = "0"b; /* because some IO modules forget to clear this */ do idx = 1 to max_switches; call iox_$control (sw_info.iocbp (idx), "read_status", addr (read_info), a_code); if a_code ^= 0 then return; if read_info.input_available then do; a_sw_idx = idx; return; end; end; if ^a_block then return; call ipc_$block (addr (sw_info.wait_list), addr (wait_info), a_code); if a_code ^= 0 then do; call convert_ipc_code_ (a_code); return; end; go to check_for_input; end find_input_switch_;  hasp_host_.pl1 10/17/88 1109.4r w 10/17/88 1034.0 582489 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* I/O Module for communications with a HASP host: This I/O module is designed for use by the I/O daemon's workstation simulator (hasp_ws_sim_driver_). It communicates with the HASP host through a TTY channel controlled by the ring-0 HASP demultiplexer. As each TTY channel connected through the HASP demultiplexer communicates with only a single device of the physical HASP host, this I/O module will ensure that all I/O switches attached to a given channel have the same device type. (Multiple I/O switches are allowed to support multiple request types being attached to the same channel.) Note: The signon_record control order does not validate that supplied IPC channel is an event-wait channel */ /****^ HISTORY COMMENTS: 1) change(80-02-01,GPalter), approve(), audit(), install(): Created. Modified: 1 September 1980 by G. Palter to remove stream mode support. Modified: 2 December 1980 by G. Palter to properly set return code for io_call control order. Modified: 18 December 1980 by G. Palter to support -terminal_type for input/output translations. Modified: 13 January 1981 by G. Palter to pass the representation of a space in the transmission medium's character code to hasp_util_. Modified: 22 July 1981 by G. Palter to convert to version 2 dial_manager_, invoke release_channel when done with a particular channel, and convert -signon/-no_signon from attach parameters to control orders. Modified: 26 July 1982 by G. Palter to add get_channel_info control order. Modified: October 1982 by G. Palter to drastically improve write_record performance by changing the order of calls to hcs_$tty_order, hcs_$tty_write, and ipc_$block and to use mvt_ rather than the PL/I translate builtin where appropriate. Modified: 14 December 1982 by G. Palter to fix bugs in the read_record entrypoint's handling of partial or very long input records (HASP #001 and HASP #002) and to insure proper behavior of the read_record entrypoint when the input record will not fit in the caller's buffer. 2) change(87-03-17,LJAdams), approve(87-04-03,MCR7646), audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030): Changed ttd_version to ttd_version_3. END HISTORY COMMENTS */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ hasp_host_: procedure (); return; /* not an entry */ /* Parameters */ dcl P_iocb_ptr pointer parameter; /* *: -> I/O switch being operated upon */ dcl P_code fixed binary (35) parameter; dcl P_attach_options (*) character (*) varying parameter; /* attach: attachment arguments */ dcl P_loud_sw bit (1) parameter; /* attach: ON => attachment errors should call com_err_ */ dcl P_open_mode fixed binary parameter; /* open: opening mode */ dcl P_open_sw bit (1) parameter; /* open: obsolete parameter */ dcl P_record_lth fixed binary (21) parameter; /* read_record: set to size of terminal_io_record read into buffer in characters; get_chars: set to # of characters read into buffer; write_record, put_chars: size of terminal_io_record to be written in characters */ dcl P_buffer_ptr pointer parameter; /* read_record, get_chars: -> area to place result of read */ dcl P_buffer_lth fixed binary (21) parameter; /* read_record, get_chars: size of area in characters */ dcl P_record_ptr pointer parameter; /* write_record, put_chars: -> terminal_io_record to be written */ dcl P_order character (*) parameter; /* control: name of control order to be performed */ dcl P_info_ptr pointer parameter; /* control: -> additional information required to execute the control order */ dcl P_new_modes character (*) parameter; /* modes: new modes to be set */ dcl P_old_modes character (*) parameter; /* modes: set to modes in effect before change */ /* Local copies of parameters */ dcl iocb_ptr pointer; dcl code fixed binary (35); dcl argument character (argument_lth) based (argument_ptr);/* based on attach options */ dcl argument_lth fixed binary (21); dcl argument_ptr pointer; dcl loud_sw bit (1) aligned; dcl open_mode fixed binary; dcl order character (32); dcl info_ptr pointer; /* Remaining declarations */ dcl system_area area aligned based (system_area_ptr); dcl system_area_ptr pointer; dcl argument_idx fixed binary; /* # of attach option being processed */ dcl (tty_channel, device_name) character (32); /* required components of attach description */ dcl have_comm bit (1) aligned; /* ON => -comm option given (required) */ dcl terminal_type character (32); /* terminal type specifying translations (optional) */ dcl other_attach_options character (256) varying; /* optional portions supplied by caller */ dcl device_type fixed binary; /* local copy used for argument processing */ dcl idx fixed binary; dcl character_value character (32); /* unused values from argument processing */ dcl numeric_value fixed binary (35); dcl 1 ttd aligned like terminal_type_data; /* used to call ttt_info_$terminal_data */ dcl 1 dma aligned like dial_manager_arg; /* used to attach the channel */ dcl 1 local_event_wait_info aligned like event_wait_info; /* for calls to ipc_$block */ dcl dialup_msg_channel character (32); /* arguments to convert_dial_message_ */ dcl 1 dialup_msg_flags aligned, 2 dialed_up bit (1) unaligned, 2 hungup bit (1) unaligned, 2 control bit (1) unaligned, 2 pad bit (33) unaligned; dcl state fixed binary; /* MCS channel state value */ dcl multiplexer_device_type fixed binary; /* for "get_device_type" control order */ dcl 1 tty_modes aligned, /* used to change MCS modes */ 2 modes_lth fixed binary, 2 modes character (256); dcl 1 read_status aligned, /* for "read_status" control order */ 2 event_channel fixed binary (71), /* channel to block on waiting for input to arrive */ 2 input_available bit (1); /* ON => data in ring-0 waiting to be read */ dcl 1 write_status aligned, /* for "write_status" control order */ 2 event_channel fixed binary (71), /* channel to block on waiting for write to complete */ 2 output_pending bit (1); /* ON => data in ring-0 waiting to be sent */ dcl ips_mask bit (36); /* IPS mask */ dcl cv_string_buffer character (cv_string_buffer_lth) based (cv_string_buffer_ptr); dcl cv_string_buffer_used character (cv_string_buffer_used_lth) based (cv_string_buffer_ptr); dcl (cv_string_buffer_lth, cv_string_buffer_used_lth) fixed binary (21); dcl (cv_string_buffer_ptr, new_cv_string_buffer_ptr) pointer; dcl io_buffer character (io_buffer_lth) unaligned based (io_buffer_ptr); dcl (io_buffer_lth, io_buffer_used, io_buffer_read) fixed binary (21); dcl io_buffer_ptr pointer; /* buffer for I/O to/from the channel */ dcl cv_string_buffer_space character (384); /* local space large enough for most conversions */ dcl io_buffer_space character (256) unaligned; /* local space large enough for most I/O */ dcl (compress_code, expand_code) fixed binary (35); /* code from hasp_util_$compress_text/expand_text */ dcl terminal_io_record_header_lth fixed binary (21); dcl previous_data character (64) varying; /* large enough for an SCB and associated data */ dcl (have_srcb, more_data_needed) bit (1) aligned; dcl srcb_read character (1); /* SRCB read from the device */ dcl srcb character (1) unaligned based (srcb_ptr); /* SRCB character being constructed/interpreted */ dcl srcb_ptr pointer; dcl 1 hasp_printer_srcb unaligned based (srcb_ptr) like hasp_printer_srcb_byte; dcl 1 read_status_info aligned like read_status based (info_ptr); /* data used by "read_status" control order */ dcl 1 hangup_proc_info aligned based (info_ptr), /* data used by "hangup_proc" control order */ 2 procedure entry variable, /* procedure to invoke when line is hungup */ 2 data_ptr pointer, /* user's data to be supplied to said procedure */ 2 priority fixed binary; /* priority of this event call channel */ dcl 1 get_channel_info aligned based (info_ptr) like tty_get_channel_info; dcl NAME character (32) static options (constant) initial ("hasp_host_"); /* format: off */ dcl (NUL initial (""), ASCII_SPACE initial (" "), EBCDIC_SPACE initial ("@")) character (1) static options (constant); dcl (LOWERCASE initial ("abcdefghijklmnopqrstuvwxyz"), UPPERCASE initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ")) character (26) static options (constant); dcl ascii_to_ebcdic_$ae_table character (128) external; dcl ebcdic_to_ascii_$ea_table character (256) external; dcl (error_table_$action_not_performed, error_table_$bad_conversion, error_table_$bad_mode, error_table_$badopt, error_table_$device_type_unknown, error_table_$eof_record, error_table_$improper_data_format, error_table_$incorrect_device_type, error_table_$invalid_read, error_table_$invalid_write, error_table_$io_no_permission, error_table_$long_record, error_table_$noalloc, error_table_$noarg, error_table_$not_attached, error_table_$not_closed, error_table_$not_detached, error_table_$not_open, error_table_$null_info_ptr, error_table_$short_record, error_table_$smallarg, error_table_$undefined_order_request, error_table_$unimplemented_version, error_table_$wrong_no_of_args) fixed binary (35) external; /* format: on */ dcl com_err_ entry () options (variable); dcl continue_to_signal_ entry (fixed binary (35)); dcl convert_dial_message_ entry (bit (72) aligned, character (*), character (*), fixed binary, 1 aligned like dialup_msg_flags, fixed binary (35)); dcl convert_ipc_code_ entry (fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl dial_manager_$privileged_attach entry (pointer, fixed binary (35)); dcl dial_manager_$release_channel entry (pointer, fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl hasp_util_$compress_text entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21), character (1) aligned, fixed binary (35)); dcl hasp_util_$expand_text entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21), character (1) aligned, fixed binary (35)); dcl hcs_$assign_channel entry (fixed binary (71), fixed binary (35)); dcl hcs_$reset_ips_mask entry (bit (36), bit (36)); dcl hcs_$set_ips_mask entry (bit (36), bit (36)); dcl hcs_$tty_abort entry (fixed binary, fixed binary, fixed binary, fixed binary (35)); dcl hcs_$tty_attach entry (character (*), fixed binary (71), fixed binary, fixed binary, fixed binary (35)); dcl hcs_$tty_detach entry (fixed binary, fixed binary (71), fixed binary, fixed binary (35)); dcl hcs_$tty_order entry (fixed binary, character (*), pointer, fixed binary, fixed binary (35)); dcl hcs_$tty_read entry (fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary, fixed binary (35)); dcl hcs_$tty_write entry (fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary, fixed binary (35)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1)); dcl iox_$err_no_operation entry (); dcl iox_$propagate entry (pointer); dcl ipc_$block entry (pointer, pointer, fixed binary (35)); dcl ipc_$create_ev_chn entry (fixed binary (71), fixed binary (35)); dcl ipc_$decl_ev_call_chn entry (fixed binary (71), entry, pointer, fixed binary, fixed binary (35)); dcl ipc_$decl_ev_wait_chn entry (fixed binary (71), fixed binary (35)); dcl ipc_$delete_ev_chn entry (fixed binary (71), fixed binary (35)); dcl mvt_ entry (pointer, pointer, fixed binary (21), character (512) aligned); dcl timer_manager_$alarm_wakeup entry (fixed binary (71), bit (2), fixed binary (71)); dcl ttt_info_$terminal_data entry (character (*), fixed binary, fixed binary, pointer, fixed binary (35)); dcl (any_other, area, cleanup) condition; dcl (addr, binary, copy, currentsize, divide, dimension, hbound, lbound, length, max, min, mod, null, rel, rtrim, string, substr, translate, unspec) builtin; %page; /* Data describing a single switch attached through this I/O module */ dcl 1 had aligned based (had_ptr), 2 attach_description character (256) varying, /* attach description for this I/O switch */ 2 open_description character (24) varying, /* open description (mode) */ 2 channel_info_ptr pointer, /* -> description of the channel */ 2 translations, 3 input character (512), /* received data -> ASCII translate table */ 3 output character (512), /* ASCII -> transmittable data translate table */ 3 space character (1), /* an ASCII space in remote device's character code */ 2 chain, /* chain of I/O switches attached to this channel */ 3 next pointer, 3 previous pointer; dcl had_ptr pointer; /* Data describing a single TTY channel attached through this I/O module */ dcl 1 channel_info aligned based (channel_info_ptr), 2 name character (32), /* name of channel described by this entry */ 2 device_type fixed binary, /* type of device attached on this channel */ 2 devx fixed binary, /* MCS identifier of this channel */ 2 event_channel fixed binary (71), /* MCS signals events via this ipc_ channel */ 2 attach_event_channel fixed binary (71), /* used to obtain the channel from the Answering Service */ 2 hads, /* chain of I/O switches attached to this channel */ 3 first pointer, 3 last pointer, 2 held_input_ptr pointer, /* -> input from this channel waiting for processing */ 2 chain, /* chain of channels attached via this I/O module */ 3 previous pointer, 3 next pointer, 2 flags, 3 attached bit (1) unaligned, /* ON => channel has been attached from answering service */ 3 attach_channel_is_call bit (1) unaligned, /* ON => attach channel has been converted to call channel */ 3 eof_pending bit (1) unaligned, /* ON => next read should return error_table_$eof_record */ 3 pad bit (33) unaligned; dcl channel_info_ptr pointer; dcl first_channel_info_ptr pointer internal static initial (null ()); dcl last_channel_info_ptr pointer internal static initial (null ()); /* Held input: The read_record operation may read more data from ring-0 than necessary; this data is held in this structure for later processing */ dcl 1 held_input aligned based (held_input_ptr), 2 n_elements_used fixed binary (21), /* # of characters still being held */ 2 n_elements_allocated fixed binary (21), /* # of characters initially held */ 2 data character (held_input_n_elements_allocated refer (held_input.n_elements_allocated)); dcl held_input_ptr pointer; dcl held_input_n_elements_allocated fixed binary (21); %page; /* Attach an I/O switch to a device of a HASP host */ hasp_host_attach: entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code); iocb_ptr = P_iocb_ptr; loud_sw = P_loud_sw; code = 0; /* assume no errors yet */ had_ptr = null (); /* avoid freeing garbage if I/O switch already attached */ if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do; P_code = error_table_$not_detached; /* special case this error */ if loud_sw then call com_err_ (P_code, NAME, "For switch ^a.", iocb_ptr -> iocb.name); return; end; system_area_ptr = get_system_free_area_ (); on condition (cleanup) call cleanup_attachment ((0)); /* Process attachment options */ if hbound (P_attach_options, 1) < 1 then call abort_attachment (error_table_$noarg, "At least ""-comm"", ""-tty"", and ""-device"" must be supplied."); allocate had in (system_area) set (had_ptr); have_comm = "0"b; /* haven't seen -comm yet */ tty_channel = ""; /* haven't seen -tty yet */ device_name = ""; /* haven't seen -device yet */ terminal_type = ""; /* haven't seen -terminal_type yet */ other_attach_options = ""; /* optional stuff goes here */ had.open_description = ""; call set_translation (had.translations.input, /* assume input is EBCDIC */ addr (ebcdic_to_ascii_$ea_table), length (ebcdic_to_ascii_$ea_table)); call set_translation (had.translations.output, addr (ascii_to_ebcdic_$ae_table), length (ascii_to_ebcdic_$ae_table)); had.translations.space = EBCDIC_SPACE; /* default translations */ had.channel_info_ptr = null (); /* prevents abort from prematurely detaching channel */ do argument_idx = lbound (P_attach_options, 1) to hbound (P_attach_options, 1); argument_ptr = substraddr (P_attach_options (argument_idx), 1); /* make accessing simpler */ argument_lth = length (P_attach_options (argument_idx)); if substr (argument, 1, 1) ^= "-" then /* do not allow non-control arguments */ call abort_attachment (error_table_$wrong_no_of_args, "All options must be control arguments."); if (argument = "-comm") then do; /* communications module: must be "hasp" */ character_value = get_string_argument (); if (argument ^= "hasp") then call abort_attachment (0, "Communications module must be ""hasp""."); have_comm = "1"b; /* got the right value */ end; else if (argument = "-tty") then /* specification of TTY channel */ tty_channel = get_string_argument (); else if (argument = "-device") then do; /* type of device on other end of channel */ device_name = get_string_argument (); device_type = -1; do idx = lbound (HASP_DEVICE_NAMES, 1) to hbound (HASP_DEVICE_NAMES, 1) while (device_type = -1); if HASP_DEVICE_NAMES (idx) = device_name then device_type = idx; end; if device_type = -1 then /* unknown type */ call abort_attachment (error_table_$device_type_unknown, "Device type must be one of ^v(""^a"", ^)or ""^a""; not ""^a"".", (dimension (HASP_DEVICE_NAMES, 1) - 1), HASP_DEVICE_NAMES, device_name); end; else if (argument = "-terminal_type") | (argument = "-ttp") then do; /* terminal type: specifies input/output translations */ terminal_type = get_string_argument (); terminal_type = translate (terminal_type, UPPERCASE, LOWERCASE); ttd.version = ttd_version_3; /* try to get input/output translations */ call ttt_info_$terminal_data (terminal_type, -1, 0, addr (ttd), code); if code ^= 0 then call abort_attachment (code, "-terminal_type ^a", terminal_type); if (ttd.tables.input_tr_ptr = null ()) | (ttd.tables.output_tr_ptr = null ()) then call abort_attachment (0, "Terminal type ""^a"" does not specify input and output translations.", terminal_type); call set_translation (had.translations.input, addr (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value), dimension (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value, 1)); call set_translation (had.translations.output, addr (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value), dimension (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value, 1)); had.translations.space = translate (ASCII_SPACE, had.translations.output); end; else if (argument = "-physical_line_length") | (argument = "-pll") then do; /* supplied by calling I/O module: ignored here */ numeric_value = get_numeric_argument (); other_attach_options = other_attach_options || " -physical_line_length "; other_attach_options = other_attach_options || argument; end; else if (argument = "-ebcdic") then /* supplied by calling I/O module: ignored here */ other_attach_options = other_attach_options || " -ebcdic"; else if (argument = "-ascii") then /* hasp_host_ doesn't support ASCII data */ call abort_attachment (0, "ASCII is not supported by this I/O module."); else if (argument = "-horizontal_tab") | (argument = "-htab") then call abort_attachment (0, "Horizontal tabs are not supported by this I/O module."); else call abort_attachment (error_table_$badopt, """^a""", argument); end; /* of argument processing loop */ /* Validate that all required information has been supplied and apply any needed defaults */ if ^have_comm then /* must specify -comm */ call abort_attachment (error_table_$noarg, """-comm"""); if (tty_channel = "") then /* must specify -tty */ call abort_attachment (error_table_$noarg, """-tty"""); if (device_name = "") then /* must specify -device */ call abort_attachment (error_table_$noarg, """-device"""); /* Build the attach description */ had.attach_description = rtrim (NAME); had.attach_description = had.attach_description || " -comm hasp -tty "; had.attach_description = had.attach_description || rtrim (tty_channel); had.attach_description = had.attach_description || " -device "; had.attach_description = had.attach_description || rtrim (device_name); if (terminal_type ^= "") then do; /* optional -terminal_type was given */ had.attach_description = had.attach_description || " -terminal_type "; had.attach_description = had.attach_description || rtrim (terminal_type); end; had.attach_description = had.attach_description || other_attach_options; /* Find the description of this channel: Validate that all I/O switches attached to this channel are of for the same type of I/O daemon device (printer, reader, etc.) */ do channel_info_ptr = first_channel_info_ptr repeat (channel_info.chain.next) while (channel_info_ptr ^= null ()); if channel_info.name = tty_channel then go to FOUND_CHANNEL; end; FOUND_CHANNEL: if (channel_info_ptr = null ()) then do; /* first use of the channel */ allocate channel_info in (system_area) set (channel_info_ptr); channel_info.name = tty_channel; channel_info.device_type = device_type; channel_info.devx, channel_info.event_channel, channel_info.attach_event_channel = -1; channel_info.hads = null (); /* no switches connected yet */ channel_info.held_input_ptr = null (); /* no read ahead yet */ string (channel_info.flags) = ""b; /* no special conditions yet */ if first_channel_info_ptr = null () then first_channel_info_ptr = channel_info_ptr; else last_channel_info_ptr -> channel_info.chain.next = channel_info_ptr; channel_info.chain.previous = last_channel_info_ptr; channel_info.chain.next = null (); last_channel_info_ptr = channel_info_ptr; end; else /* channel in use: insure that device type is correct */ if channel_info.device_type ^= device_type then call abort_attachment (error_table_$incorrect_device_type, "Device type of ^a is ""^a""; not ""^a"".", tty_channel, HASP_DEVICE_NAMES (channel_info.device_type), HASP_DEVICE_NAMES (device_type)); if channel_info.hads.first = null () then channel_info.hads.first = had_ptr; /* first switch for this channel */ else channel_info.hads.last -> had.chain.next = had_ptr; had.chain.previous = channel_info.hads.last; had.chain.next = null (); channel_info.hads.last = had_ptr; had.channel_info_ptr = channel_info_ptr; /* Acquire and attach the channel if necessary */ if channel_info.devx = -1 then do; /* Request the TTY channel from the Answering Service */ call ipc_$create_ev_chn (channel_info.attach_event_channel, code); if code ^= 0 then call convert_ipc_code_ (code); if code ^= 0 then call abort_attachment (code, "Creating ipc_ channel."); dma.version = dial_manager_arg_version_2; dma.dial_channel = channel_info.attach_event_channel; dma.channel_name = tty_channel; dma.dial_qualifier, dma.dial_out_destination, dma.reservation_string = ""; call dial_manager_$privileged_attach (addr (dma), code); if code = error_table_$action_not_performed then go to ASSUME_ATTACHED; if code ^= 0 then call abort_attachment (code, "Attempting to attach ^a.", tty_channel); event_wait_channel.n_channels = 1; event_wait_channel.channel_id (1) = channel_info.attach_event_channel; WAIT_FOR_ANSWERING_SERVICE: call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code); /* wait for answering service to give it to us */ if code ^= 0 then call convert_ipc_code_ (code); if code ^= 0 then call abort_attachment (code, "Waiting for attachment to ^a.", tty_channel); call convert_dial_message_ (unspec (local_event_wait_info.message), dialup_msg_channel, ((32)" "), (0), dialup_msg_flags, code); if code ^= 0 then call abort_attachment (code, "Interpreting attachment to ^a.", tty_channel); if ^dialup_msg_flags.dialed_up then do; call com_err_ (0, NAME, "For switch ^a: Unexpected signal from answering service - ^[hangup^;control^] for channel ^a.", iocb_ptr -> iocb.name, dialup_msg_flags.hungup, dialup_msg_channel); go to WAIT_FOR_ANSWERING_SERVICE; end; /* Create the event channel for ring-0: try using a special channel first */ ASSUME_ATTACHED: channel_info.attached = "1"b; /* we have the channel from the answering service now */ call hcs_$assign_channel (channel_info.event_channel, code); if code ^= 0 then do; /* couldn't get fast channel: try standard one */ call ipc_$create_ev_chn (channel_info.event_channel, code); if code ^= 0 then call convert_ipc_code_ (code); if code ^= 0 then call abort_attachment (code, "Creating ipc_ channel."); end; /* Attach the channel through the ring-0 HASP multiplexer in MCS, validate the supplied device type, and set it's modes to "rawi,rawo" */ call hcs_$tty_attach (tty_channel, channel_info.event_channel, channel_info.devx, state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then call abort_attachment (code, "Unable to attach to ^a.", tty_channel); call hcs_$tty_order (channel_info.devx, "get_device_type", addr (multiplexer_device_type), state, code); if state ^= 5 then code = error_table_$io_no_permission; if (code = 0) then if (channel_info.device_type = multiplexer_device_type) then ; /* proper device type for this channel */ else call abort_attachment (error_table_$incorrect_device_type, "Device type of ^a is ""^a""; not ""^a"".", tty_channel, HASP_DEVICE_NAMES (multiplexer_device_type), HASP_DEVICE_NAMES (channel_info.device_type)); else if (code = error_table_$undefined_order_request) then call abort_attachment (0, "^a is not connected to a HASP multiplexer.", tty_channel); else call abort_attachment (code, "Unable to determine device type of ^a.", tty_channel); tty_modes.modes = "rawi,rawo"; tty_modes.modes_lth = length (tty_modes.modes); call hcs_$tty_order (channel_info.devx, "modes", addr (tty_modes), state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then call abort_attachment (code, "Unable to set initial modes for ^a.", tty_channel); end; /* Mask and complete construction of the IOCB */ ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = addr (had.attach_description); iocb_ptr -> iocb.attach_data_ptr = had_ptr; iocb_ptr -> iocb.open = hasp_host_open; iocb_ptr -> iocb.detach_iocb = hasp_host_detach; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); RETURN_FROM_ATTACH: P_code = code; return; %page; /* Open an I/O switch connected to a HASP host: only record oriented openings are supported */ hasp_host_open: entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; open_mode = P_open_mode; if ^((open_mode = Sequential_input) | (open_mode = Sequential_output) | (open_mode = Sequential_input_output)) then do; P_code = error_table_$bad_mode; return; end; had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then if (open_mode = Sequential_output) then do; /* printer/punch opened for output only */ P_code = error_table_$bad_mode; return; end; if (channel_info.device_type = HASP_READER) then if (open_mode = Sequential_input) then do; /* reader opened for input only */ P_code = error_table_$bad_mode; return; end; had.open_description = rtrim (iox_modes (open_mode)); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); if ((open_mode = Sequential_input) | (open_mode = Sequential_input_output)) then iocb_ptr -> iocb.read_record = hasp_host_read_record; if ((open_mode = Sequential_output) | (open_mode = Sequential_input_output)) then iocb_ptr -> iocb.write_record = hasp_host_write_record; iocb_ptr -> iocb.control = hasp_host_control; iocb_ptr -> iocb.modes = hasp_host_modes; iocb_ptr -> iocb.close = hasp_host_close; iocb_ptr -> iocb.detach_iocb = hasp_host_detach; iocb_ptr -> iocb.open_descrip_ptr = addr (had.open_description); /* it's now open */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = 0; return; %page; /* Close an I/O switch connected to a HASP host */ hasp_host_close: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; if iocb_ptr -> iocb.open_descrip_ptr = null () then do; P_code = error_table_$not_open; return; end; ips_mask = ""b; on condition (cleanup) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.open_descrip_ptr = null (); iocb_ptr -> iocb.open = hasp_host_open; iocb_ptr -> iocb.detach_iocb = hasp_host_detach; iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.read_record, iocb_ptr -> iocb.write_record = iox_$err_no_operation; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = 0; return; %page; /* Detach an I/O switch from a device of a HASP host */ hasp_host_detach: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr; if iocb_ptr -> iocb.attach_descrip_ptr = null () then do; P_code = error_table_$not_attached; return; end; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; system_area_ptr = get_system_free_area_ (); had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; call cleanup_attachment (code); /* remove this switch and the channel if necessary */ ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = null (); /* it's detached */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; /* in case trouble freeing the channel */ return; %page; /* Read a record: read a single record from the device, returning a "standard" terminal_io_record structure */ hasp_host_read_record: entry (P_iocb_ptr, P_buffer_ptr, P_buffer_lth, P_record_lth, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; code = 0; if (channel_info.device_type = HASP_READER) then do; P_code = error_table_$invalid_read; /* can't read from the reader */ return; end; system_area_ptr = get_system_free_area_ (); cv_string_buffer_ptr = null (); /* for cleanup handler */ on condition (cleanup) begin; if cv_string_buffer_ptr ^= null () then if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then free cv_string_buffer in (system_area); end; /* Check if last read_record operation read an EOF record containing some carriage control; if so, indicate the EOF condition on this read as previous read just returned the slew control */ if channel_info.eof_pending then do; channel_info.eof_pending = "0"b; /* only do this once per EOF */ P_code = error_table_$eof_record; return; end; /* Validate that there is room in the buffer to hold some actual data in addition to a terminal_io_record header */ terminal_io_record_ptr = P_buffer_ptr; terminal_io_record_header_lth = /* # of characters of buffer occupied by record's header */ 4 * (binary (rel (addr (terminal_io_record.data)), 18, 0) - binary (rel (terminal_io_record_ptr), 18, 0)); if terminal_io_record_header_lth >= P_buffer_lth then do; P_code = error_table_$smallarg; /* supplied buffer is just TOO small */ return; end; terminal_io_record_n_elements = P_buffer_lth - terminal_io_record_header_lth; /* # of actual characters that will fit into the buffer */ /* Obtain and unpack a record: a record is constructed from any data obtained in prior calls to read_record in addition to whatever data must be read from ring-0 in this call to complete the record. Unpacking is performed on the data in 256 character sections until hasp_util_$expand_text detects the end-of-record sequence in the stream */ cv_string_buffer_ptr = addr (cv_string_buffer_space); cv_string_buffer_lth = length (cv_string_buffer_space); cv_string_buffer_used_lth = 0; /* start putting data into automatic */ previous_data = ""; /* piece left from previous read */ srcb_ptr = addr (srcb_read); /* a place to put the SRCB ... */ have_srcb = "0"b; /* ... which hasn't been found yet */ more_data_needed = "1"b; do while (more_data_needed); /* Select source of data for this time around: if necessary, data will be read from ring-0 */ if channel_info.held_input_ptr ^= null () then do; /* read ahead: process as much of the block as can be used */ io_buffer_ptr = addr (channel_info.held_input_ptr -> held_input.data); io_buffer_lth = channel_info.held_input_ptr -> held_input.n_elements_allocated; io_buffer_read = channel_info.held_input_ptr -> held_input.n_elements_used; end; else do; /* no more read ahead: obtain more data from ring-0 */ io_buffer_ptr = addr (io_buffer_space); io_buffer_lth = length (io_buffer_space); call read_io_buffer (); /* sets io_buffer_read */ if code ^= 0 then go to RETURN_FROM_READ_RECORD; end; if length (previous_data) > 0 then do; /* some data left over from previous junk: merge them */ held_input_n_elements_allocated = length (previous_data) + io_buffer_read; allocate held_input in (system_area) set (held_input_ptr); held_input.n_elements_used = held_input.n_elements_allocated; substr (held_input.data, 1, length (previous_data)) = previous_data; substr (held_input.data, (length (previous_data) + 1), io_buffer_read) = substr (io_buffer, 1, io_buffer_read); if io_buffer_ptr ^= addr (io_buffer_space) then free channel_info.held_input_ptr -> held_input in (system_area); channel_info.held_input_ptr = held_input_ptr; io_buffer_ptr = addr (held_input.data); io_buffer_lth, io_buffer_read = held_input.n_elements_used; previous_data = ""; end; /* Unpack the data: stop when an end-of-record indicator is found */ if have_srcb then io_buffer_used = 0; /* in middle of record: first character in buffer is SCB */ else do; /* first part of record: first character is SRCB */ srcb = substr (io_buffer, 1, 1); io_buffer_used = 1; have_srcb = "1"b; end; do while (more_data_needed & (io_buffer_used < io_buffer_read)); call hasp_util_$expand_text (substraddr (io_buffer, 1), io_buffer_read, io_buffer_used, substraddr (cv_string_buffer, 1), cv_string_buffer_lth, cv_string_buffer_used_lth, had.translations.space, expand_code); if expand_code = 0 then more_data_needed = "0"b; /* found end of record indicator */ else if expand_code = error_table_$short_record then ; /* took entire buffer but need more */ else if expand_code = error_table_$long_record then do; /* overflowed the output buffer: grow it and continue */ cv_string_buffer_lth = 2 * cv_string_buffer_lth; on condition (area) begin; /* can't get enough room: record is not readable */ code = error_table_$noalloc; go to RETURN_FROM_READ_RECORD; end; allocate cv_string_buffer in (system_area) set (new_cv_string_buffer_ptr); revert condition (area); new_cv_string_buffer_ptr -> cv_string_buffer_used = cv_string_buffer_used; if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then free cv_string_buffer in (system_area); cv_string_buffer_ptr = new_cv_string_buffer_ptr; end; else if (io_buffer_read - io_buffer_used) <= (HASP_MAX_NOT_COMPRESSED_TEXT_LTH + 1) then do; /* possibly need to read more data from ring-0 */ previous_data = substr (io_buffer, (io_buffer_used + 1), (io_buffer_read - io_buffer_used)); io_buffer_used = io_buffer_read; /* force to read some more data */ end; else do; /* data is definitely improperly formatted */ code = error_table_$improper_data_format; go to RETURN_FROM_READ_RECORD; end; end; if io_buffer_used = io_buffer_read then /* have exhausted this buffer ... */ if io_buffer_ptr ^= addr (io_buffer_space) then do; free channel_info.held_input_ptr -> held_input in (system_area); channel_info.held_input_ptr = null (); end; /* ... so get rid of it so we can read some more */ end; if io_buffer_used < io_buffer_read then do; /* some data left over: save it */ held_input_n_elements_allocated = io_buffer_read - io_buffer_used; allocate held_input in (system_area) set (held_input_ptr); held_input.n_elements_used = held_input.n_elements_allocated; held_input.data = substr (io_buffer, (io_buffer_used + 1), (io_buffer_read - io_buffer_used)); if io_buffer_ptr ^= addr (io_buffer_space) then free channel_info.held_input_ptr -> held_input; channel_info.held_input_ptr = held_input_ptr; end; /* Check for end of file: An EOF record is a zero length record. If an EOF record is found, check if the SRCB contains carriage control information (line printer only), delay indicating the EOF until the next call to read_record and return a zero length record with appropriate slew control; otherwise, return error_table_$eof_record. If no EOF is present, convert the data in the record to ASCII */ if (cv_string_buffer_used_lth = 0) then do; if (channel_info.device_type = HASP_PRINTER) then if (srcb = substr (TEMPLATE_HASP_EOF_RECORD, 1, 1)) then code = error_table_$eof_record; else do; channel_info.eof_pending = "1"b; terminal_io_record.n_elements = 0; /* no data in the record, just slew */ end; else code = error_table_$eof_record; if (code = error_table_$eof_record) then go to RETURN_FROM_READ_RECORD; end; else do; /* data seems OK: convert it */ terminal_io_record.n_elements = min (terminal_io_record_n_elements, cv_string_buffer_used_lth); if cv_string_buffer_used_lth > 0 then call mvt_ (addr (cv_string_buffer_used), addr (terminal_io_record_data_chars), (terminal_io_record.n_elements), had.translations.input); if cv_string_buffer_used_lth > terminal_io_record_n_elements then code = error_table_$long_record; end; /* ... return as much as will fit */ /* Control reaches here iff the record is read/converted successfully: complete the terminal_io_record structure */ terminal_io_record.version = terminal_io_record_version_1; if (channel_info.device_type = HASP_CONSOLE) then terminal_io_record.device_type = TELEPRINTER_DEVICE; else if (channel_info.device_type = HASP_PRINTER) then terminal_io_record.device_type = PRINTER_DEVICE; else if (channel_info.device_type = HASP_PUNCH) then terminal_io_record.device_type = PUNCH_DEVICE; string (terminal_io_record.flags) = ""b; if (channel_info.device_type = HASP_CONSOLE) | (channel_info.device_type = HASP_PUNCH) then do; /* console or punch: slewing is fixed */ terminal_io_record.slew_type = SLEW_BY_COUNT; terminal_io_record.slew_count = 1; terminal_io_record.preslew = "0"b; end; else do; /* printer: interpret the SRCB */ if hasp_printer_srcb.skip_to_channel then terminal_io_record.slew_type = SLEW_TO_CHANNEL; else terminal_io_record.slew_type = SLEW_BY_COUNT; terminal_io_record.slew_count = hasp_printer_srcb.number; terminal_io_record.preslew = hasp_printer_srcb.prespace; end; terminal_io_record.element_size = 9; P_record_lth = terminal_io_record_header_lth + terminal_io_record.n_elements; /* Cleanup */ RETURN_FROM_READ_RECORD: if cv_string_buffer_ptr ^= null () then if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then free cv_string_buffer in (system_area); P_code = code; return; %page; /* Write a record: write a single record to the device. This record represents part or all of a single line and should be the output of the prt_conv_ module using the remote_conv_ conversion coroutine, presently named hasp_host_conv_ */ hasp_host_write_record: entry (P_iocb_ptr, P_record_ptr, P_record_lth, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; code = 0; if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then do; P_code = error_table_$invalid_write; /* can't write printer or punch */ return; end; system_area_ptr = get_system_free_area_ (); io_buffer_ptr = null (); /* for cleanup handler */ on condition (cleanup) begin; /* free any temporary buffers */ if io_buffer_ptr ^= null () then if io_buffer_ptr ^= addr (io_buffer_space) then free io_buffer in (system_area); end; /* Validate input: insure that the caller has supplied a complete terminal I/O record; insure that the terminal input record contains character as opposed to binary data */ terminal_io_record_ptr = P_record_ptr; if terminal_io_record.version ^= terminal_io_record_version_1 then do; P_code = error_table_$unimplemented_version; return; end; if mod (P_record_lth, 4) = 0 then /* X+4-mod(X,4) fails when X is already a multiple of 4 */ if (4 * currentsize (terminal_io_record)) = P_record_lth then ; /* user supplied length agrees with computed length */ else do; P_code = error_table_$improper_data_format; return; end; else /* supplied length not multiple of 4: must round it up */ if (4 * currentsize (terminal_io_record)) ^= (P_record_lth + 4 - mod (P_record_lth, 4)) then do; P_code = error_table_$improper_data_format; return; end; if terminal_io_record.binary | terminal_io_record.preslew | (terminal_io_record.element_size ^= 9) then do; P_code = error_table_$improper_data_format; return; end; /* Convert the data to the remote system's character code (in place) */ call mvt_ (addr (terminal_io_record_data_chars), addr (terminal_io_record_data_chars), (terminal_io_record.n_elements), had.translations.output); /* Compute size of I/O buffer required assuming no compression can be performed on the record. If this size is not too large, the automatic buffer will be used; otherwise, a buffer will be allocated */ io_buffer_lth = max (terminal_io_record.n_elements, 1) + divide ((terminal_io_record.n_elements + HASP_MAX_NOT_COMPRESSED_TEXT_LTH - 1), HASP_MAX_NOT_COMPRESSED_TEXT_LTH, 17, 0) + /* SCBs for the text */ 2; /* SRCB and end-of-record SCB */ if io_buffer_lth <= length (io_buffer_space) then do; /* space needed availabe in automatic */ io_buffer_ptr = addr (io_buffer_space); io_buffer_lth = length (io_buffer_space); end; else do; /* space required larger than automatic buffer */ on condition (area) begin; code = error_table_$noalloc; /* just TOO much */ go to RETURN_FROM_WRITE_RECORD; end; allocate io_buffer in (system_area) set (io_buffer_ptr); end; /* Create the record: construct the SRCB for the record, compress the record (insuring that some data is present in the record), and add the terminating end-of-record SCB */ io_buffer_used = 0; /* nothing in the output yet */ if (channel_info.device_type = HASP_CONSOLE) then call add_character_to_io_buffer (HASP_CONSOLE_SRCB); else if (channel_info.device_type = HASP_READER) then call add_character_to_io_buffer (TEMPLATE_HASP_CARD_SRCB); if terminal_io_record.n_elements = 0 then /* no data: supply some to avoid lossage with RSCS */ call hasp_util_$compress_text (addr (had.translations.space), 1, (0), addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code); else call hasp_util_$compress_text (addr (terminal_io_record.data), (terminal_io_record.n_elements), (0), addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code); if compress_code ^= 0 then do; /* failed: yet above code insured there'd enough room */ WRITE_RECORD_BAD_DATA: code = error_table_$improper_data_format; go to RETURN_FROM_WRITE_RECORD; end; call add_character_to_io_buffer (HASP_EOR_SCB); /* Transmit the I/O block and return to the caller */ call write_io_buffer (); /* needed in end_write_mode control order */ RETURN_FROM_WRITE_RECORD: if io_buffer_ptr ^= null () then if io_buffer_ptr ^= addr (io_buffer_space) then free io_buffer in (system_area); P_code = code; return; %page; /* Perform control operations on an I/O switch connected to a HASP host */ hasp_host_control: entry (P_iocb_ptr, P_order, P_info_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; order = P_order; info_ptr = P_info_ptr; code = 0; if (order = "io_call") then do; /* io_call command interface: translate the supplied info into an ordinary control order */ if info_ptr = null () then do; /* need the order name */ P_code = error_table_$undefined_order_request; return; end; order = info_ptr -> io_call_info.order_name; info_ptr = null (); end; if (order = "signon_record") then do; /* Send a SIGNON record to the host system: validate that the user supplied an event-wait channel, convert the SIGNON record itself to uppercase and the remote system's character code, and pass the control order to MCS for actual processing */ if info_ptr = null () then code = error_table_$null_info_ptr; else do; signon_record_info_ptr = info_ptr; if signon_record_info.version ^= SIGNON_RECORD_INFO_VERSION_1 then code = error_table_$unimplemented_version; /* FINISH ME: validate IPC channel... */ else do; /* proper version */ signon_record_info.record = translate (signon_record_info.record, UPPERCASE, LOWERCASE); signon_record_info.record = translate (signon_record_info.record, had.translations.output); call hcs_$tty_order (channel_info.devx, "signon_record", signon_record_info_ptr, state, code); if state ^= 5 then code = error_table_$io_no_permission; end; end; end; else if (order = "runout") then do; /* Wait for all output to leave the FNP: for HASP channels, we only wait for the output to leave the TTY channel and enter the multiplexer */ write_status.output_pending = "1"b; /* need do until */ do while (write_status.output_pending); call hcs_$tty_order (channel_info.devx, "write_status", addr (write_status), state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then go to RETURN_FROM_CONTROL; if write_status.output_pending then do; event_wait_channel.n_channels = 1; event_wait_channel.channel_id (1) = channel_info.event_channel; call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code); if code ^= 0 then call convert_ipc_code_ (code); if code ^= 0 then go to RETURN_FROM_CONTROL; end; end; end; else if (order = "end_write_mode") then do; /* End a write operation: for a card reader write an EOF record. For all output devices, wait for all output to enter the multiplexer */ if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then do; code = error_table_$invalid_write; go to RETURN_FROM_CONTROL; end; if (channel_info.device_type = HASP_CONSOLE) then ; /* don't write an EOF record */ else do; io_buffer_ptr = addr (TEMPLATE_HASP_EOF_RECORD); io_buffer_lth, io_buffer_used = length (TEMPLATE_HASP_EOF_RECORD); call write_io_buffer (); /* send it */ if code ^= 0 then go to RETURN_FROM_CONTROL; end; call hasp_host_control (iocb_ptr, "runout", (null ()), code); end; else if (order = "read_status") then do; /* Indicate if input is available: check local buffers before checking with ring-0 */ if (info_ptr = null ()) then code = error_table_$null_info_ptr; else do; read_status_info.event_channel = channel_info.event_channel; if (channel_info.held_input_ptr ^= null ()) | channel_info.eof_pending then read_status_info.input_available = "1"b; /* got some here */ else do; call hcs_$tty_order (channel_info.devx, "read_status", info_ptr, state, code); if state ^= 5 then code = error_table_$io_no_permission; end; end; end; else if (order = "resetread") then do; /* Flush pending input: throw out any input being held locally and then perform an appropriate "abort" control on the channel */ if channel_info.held_input_ptr ^= null () then free channel_info.held_input_ptr -> held_input in (system_area); channel_info.held_input_ptr = null (); channel_info.eof_pending = "0"b; call hcs_$tty_abort (channel_info.devx, (1), state, code); if state ^= 5 then code = error_table_$io_no_permission; end; else if (order = "resetwrite") then do; /* Flush pending output: perform the appropriate "abort" control order on the channel */ call hcs_$tty_abort (channel_info.devx, (2), state, code); if state ^= 5 then code = error_table_$io_no_permission; end; else if (order = "hangup_proc") then do; /* Caller supplies a procedure to be invoked when the channel used by this switch is hungup */ if (info_ptr = null ()) then code = error_table_$null_info_ptr; else do; call ipc_$decl_ev_call_chn (channel_info.attach_event_channel, hangup_proc_info.procedure, hangup_proc_info.data_ptr, hangup_proc_info.priority, code); if code ^= 0 then call convert_ipc_code_ (code); if code = 0 then channel_info.attach_channel_is_call = "1"b; end; end; else if (order = "get_channel_info") then do; /* Return the name and MCS device index of the channel attached via this switch */ if (info_ptr = null ()) then code = error_table_$null_info_ptr; else if get_channel_info.version ^= tty_get_channel_info_version then code = error_table_$unimplemented_version; else do; get_channel_info.devx = channel_info.devx; get_channel_info.channel_name = channel_info.name; end; end; else if (order = "select_device") then ; /* select a specific output device: ignored */ else if (order = "reset") then ; /* reset the switch to a well-known state: ignored */ else do; /* Unrecognized control order or "no_signon_record" order: pass it on to MCS */ call hcs_$tty_order (channel_info.devx, order, info_ptr, state, code); if state ^= 5 then code = error_table_$io_no_permission; end; RETURN_FROM_CONTROL: P_code = code; return; %page; /* Change modes: only the "non_edited" and "default" modes are recognized */ hasp_host_modes: entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; had_ptr = iocb_ptr -> iocb.attach_data_ptr; P_old_modes = ""; /* no modes are reflected to caller */ code = 0; if (P_new_modes = "non_edited") | (P_new_modes = "default") then ; else code = error_table_$bad_mode; P_code = code; return; %page; /* Remove an I/O switch which might be attached to the channel: if this switch is the only one attached to the channel, the channel itself is detached */ cleanup_attachment: procedure (P_code); dcl P_code fixed binary (35) parameter; /* a parameter to allow callers to ignore it */ P_code = 0; if had_ptr ^= null () then do; /* there is an I/O switch */ if had.channel_info_ptr ^= null () then do; /* there is knowledge of the channel */ channel_info_ptr = had.channel_info_ptr; if (had.chain.previous = null ()) then channel_info.hads.first = had.chain.next; else had.chain.previous -> had.chain.next = had.chain.next; if (had.chain.next = null ()) then channel_info.hads.last = had.chain.previous; else had.chain.next -> had.chain.previous = had.chain.previous; if (channel_info.hads.first = null ()) then call release_channel (); /* last switch connected to the channel */ end; free had in (system_area); had_ptr = null (); /* just to be sure */ end; return; /* Internal to cleanup_attachment: release the knowledge associated with a TTY channel */ release_channel: procedure (); if channel_info.devx ^= -1 then call hcs_$tty_detach (channel_info.devx, (0), (0), P_code); if channel_info.event_channel ^= -1 then call ipc_$delete_ev_chn (channel_info.event_channel, (0)); if channel_info.attached then do; /* give the channel back to the answering service */ if channel_info.attach_channel_is_call then call ipc_$decl_ev_wait_chn (channel_info.attach_event_channel, (0)); dma.version = dial_manager_arg_version_2; dma.dial_channel = channel_info.attach_event_channel; dma.channel_name = channel_info.name; dma.dial_qualifier, dma.dial_out_destination, dma.reservation_string = ""; call dial_manager_$release_channel (addr (dma), (0)); channel_info.attached = "0"b; /* assume success */ end; if channel_info.attach_event_channel ^= -1 then call ipc_$delete_ev_chn (channel_info.attach_event_channel, (0)); if (channel_info.chain.previous = null ()) then first_channel_info_ptr = channel_info.chain.next; else channel_info.chain.previous -> channel_info.chain.next = channel_info.chain.next; if (channel_info.chain.next = null ()) then last_channel_info_ptr = channel_info.chain.previous; else channel_info.chain.next -> channel_info.chain.previous = channel_info.chain.previous; free channel_info in (system_area); channel_info_ptr = null (); return; end release_channel; end cleanup_attachment; %page; /* Wrapper to protect against errors while IPS interrupts are masked */ any_other_handler: procedure () options (non_quick); if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask); ips_mask = ""b; call continue_to_signal_ ((0)); /* not interested, */ return; end any_other_handler; /* Abort a call to the attach entry: print an error message if requested */ abort_attachment: procedure () options (variable, non_quick); dcl the_code fixed binary (35) based (the_code_ptr); dcl the_code_ptr pointer; dcl caller_message character (256); call cu_$arg_ptr (1, the_code_ptr, (0), (0)); if loud_sw then do; /* an error message is requested */ call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, (0), "1"b, "0"b); call com_err_ (the_code, NAME, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message); end; call cleanup_attachment ((0)); /* get rid of anything that was accomplished */ if the_code = 0 then code = error_table_$action_not_performed; else code = the_code; /* save the error code */ go to RETURN_FROM_ATTACH; end abort_attachment; %page; /* Fetch the next argument from the attach options and validate that it is a non-null character string */ get_string_argument: procedure () returns (character (*)); dcl option_name character (32); option_name = argument; /* about to move on to the next one */ if (argument_idx = hbound (P_attach_options, 1)) then call abort_attachment (error_table_$noarg, "Character string following ""^a"".", option_name); argument_idx = argument_idx + 1; argument_ptr = substraddr (P_attach_options (argument_idx), 1); argument_lth = length (P_attach_options (argument_idx)); if (argument = "") then call abort_attachment (0, "Character string following ""^a"" must be non-null.", option_name); return (argument); end get_string_argument; /* Fetch the next argument from the attach options and verify that it is a number */ get_numeric_argument: procedure () returns (fixed binary (35)); dcl option_name character (32); dcl the_value fixed binary (35); option_name = argument; /* about to move on to the next one */ if (argument_idx = hbound (P_attach_options, 1)) then call abort_attachment (error_table_$noarg, "Number following ""^a"".", option_name); argument_idx = argument_idx + 1; argument_ptr = substraddr (P_attach_options (argument_idx), 1); argument_lth = length (P_attach_options (argument_idx)); the_value = cv_dec_check_ (argument, code); if code ^= 0 then call abort_attachment (error_table_$bad_conversion, """^a"" must be followed by a number; not ""^a"".", option_name, argument); return (the_value); end get_numeric_argument; %page; /* Set input/output translation to the given string: If the string supplied is less than 512 characters, the out of range characters are translated to NULs */ set_translation: procedure (P_translate_table, P_translate_string_ptr, P_translate_string_lth); dcl P_translate_table character (512) aligned parameter; /* translate table */ dcl P_translate_string_ptr pointer parameter; /* -> translation string */ dcl P_translate_string_lth fixed binary (21) parameter; /* length of translation string */ dcl translate_string character (P_translate_string_lth) based (P_translate_string_ptr); P_translate_table = translate_string; if length (translate_string) < length (P_translate_table) then substr (P_translate_table, (length (translate_string) + 1)) = copy (NUL, (length (P_translate_table) - length (translate_string))); return; end set_translation; %page; /* Read an I/O buffer: block until some data arrives and perform a single read from ring-0 */ read_io_buffer: procedure (); io_buffer_read = 0; /* need do until here */ do while (io_buffer_read = 0); read_status.input_available = "0"b; /* again, no do until */ do while (^read_status.input_available); call hcs_$tty_order (channel_info.devx, "read_status", addr (read_status), state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then return; /* punt! */ if ^read_status.input_available then do;/* need to wait for some input */ event_wait_channel.n_channels = 1; event_wait_channel.channel_id (1) = channel_info.event_channel; call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code); if code ^= 0 then call convert_ipc_code_ (code); if code ^= 0 then return; end; end; call hcs_$tty_read (channel_info.devx, addr (io_buffer), (0), io_buffer_lth, io_buffer_read, state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then return; end; return; end read_io_buffer; %page; /* Add the specified character to the I/O buffer for later output */ add_character_to_io_buffer: procedure (P_character); dcl P_character character (1) aligned parameter; if io_buffer_used = length (io_buffer) then /* no room in buffer */ go to WRITE_RECORD_BAD_DATA; io_buffer_used = io_buffer_used + 1; substr (io_buffer, io_buffer_used, 1) = P_character; return; end add_character_to_io_buffer; %page; /* Write an I/O buffer: blocks until the entire buffer has been taken by ring-0 MCS */ write_io_buffer: procedure (); dcl (transmitted, sent_on_call) fixed binary (21); transmitted = 0; /* do until needed here */ do while (transmitted < io_buffer_used); call hcs_$tty_write (channel_info.devx, substraddr (io_buffer, (transmitted + 1)), (0), (io_buffer_used - transmitted), sent_on_call, state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then return; /* punt! */ transmitted = transmitted + sent_on_call; /* got some more through */ if transmitted < io_buffer_used then do; /* not done yet: wait 'till we should try again */ call hcs_$tty_order (channel_info.devx, "write_status", addr (write_status), state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then return; /* punt! */ if write_status.output_pending then do; /* must really and truly wait */ event_wait_channel.n_channels = 1; event_wait_channel.channel_id (1) = channel_info.event_channel; call timer_manager_$alarm_wakeup (1, "11"b, event_wait_channel.channel_id (1)); call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code); if code ^= 0 then call convert_ipc_code_ (code); if code ^= 0 then return; /* punt! */ end; end; end; return; /* this return taken only on success */ end write_io_buffer; %page; /* substraddr: Return a pointer to the specified character of a varying or nonvarying string. When the substraddr builtin function is finally implemented, these internal procedures should be removed */ dcl substraddr generic (substraddr_nonvarying when (character (*) nonvarying, fixed binary precision (1:35)), substraddr_varying when (character (*) varying, fixed binary precision (1:35))); substraddr_nonvarying: procedure (P_string, P_position) returns (pointer); dcl P_string character (*) nonvarying parameter; dcl P_position fixed binary (21) parameter; dcl string_overlay (length (P_string)) character (1) unaligned based (addr (P_string)); return (addr (string_overlay (P_position))); end substraddr_nonvarying; substraddr_varying: procedure (P_string, P_position) returns (pointer); dcl P_string character (*) varying parameter; dcl P_position fixed binary (21) parameter; dcl 1 string_overlay aligned based (addr (P_string)), 2 lth fixed binary (21), 2 characters (0 refer (string_overlay.lth)) character (1) unaligned; return (addr (string_overlay.characters (P_position))); end substraddr_varying; %page; %include terminal_io_record; %page; %include hasp_device_data; %include hasp_srcb_scb_bytes; %include hasp_signon_record_info; %page; %include iocb; %page; %include iox_modes; %page; %include io_call_info; %page; %include dial_manager_arg; %include event_wait_channel; %include event_wait_info; %page; %include terminal_type_data; %include tty_convert; %include tty_get_channel_info; end hasp_host_;  hasp_host_operators_console.pl1 11/18/82 1708.0rew 11/18/82 1629.5 171180 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Command for a Multics process to communicate with a foreign HASP host as a HASP workstation's operator's console: Usage: hasp_host_operators_console channel {-control_args} {attach_arguments} where: channel -- is the name of the HASP operator's channel (eg: a.h014.opr), control_args -- may be either "-no_signon" or "-signon STR", and attach_arguments -- are optional arguments to supply in the attach description */ /* Created: February 1980 by G. Palter */ /* Modified: 15 October 1980 by G. Palter to establish a hangup handler */ /* Modified: 22 July 1981 by G. Palter to support -signon/-no_signon directly */ hasp_host_operators_console: hhoc: procedure () options (variable); dcl n_arguments fixed binary; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_lth fixed binary (21); dcl argument_ptr pointer; dcl tty_channel character (32); /* MCS channel for the operator's console */ dcl 1 sri aligned like signon_record_info; dcl signon_record bit (1) aligned; /* ON => caller wants a SIGNON record transmitted */ dcl signon_response fixed binary (71); /* results of sending the SIGNON record */ dcl operators_console pointer; /* -> IOCB for the console */ dcl switch_name character (32); dcl attach_description character (512) varying; /* attach description for operator's console */ dcl terminal_io_record_header_lth fixed binary (21); /* needed to compute size of buffer to read from user_input */ dcl code fixed binary (35); dcl idx fixed binary; dcl processing bit (1) aligned; dcl 1 hangup_info aligned, /* structure to establish handler for hangups */ 2 entry entry variable, /* the procedure to call */ 2 data_ptr pointer, /* -> arbitrary data to pass to the procedure */ 2 priority fixed binary; /* IPC priority of handler */ dcl 1 ui_status aligned, /* result of "read_status" on user_input */ 2 event_channel fixed binary (71), 2 input_available bit (1); /* ON => something is available to be read from user_input */ dcl 1 oc_status aligned, /* result of "read_status" on operator's console channel */ 2 event_channel fixed binary (71), 2 input_available bit (1); /* ON => foreign system has something to print */ dcl 1 event_wait_list aligned, /* for waiting for input from either user_input or host */ 2 n_channels fixed binary, 2 pad bit (36), 2 channels (2) fixed binary (71); dcl 1 local_event_wait_info aligned like event_wait_info; dcl NO_CONTROL_CHARS character (512) initial (copy (SP, 32) || substr (collate, 33) || copy (SP, 384)); dcl NAME character (32) static options (constant) initial ("hasp_host_operators_console"); dcl (MAJOR_VERSION initial (2), MINOR_VERSION initial (0)) fixed binary static options (constant); dcl (UPPERCASE initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"), LOWERCASE initial ("abcdefghijklmnopqrstuvwxyz")) character (26) static options (constant); dcl (NL initial (" "), SP initial (" ")) character (1) static options (constant); dcl (iox_$user_input, iox_$user_output) pointer external; dcl sys_info$max_seg_size fixed binary (19) external; dcl (error_table_$bigarg, error_table_$invalid_state, error_table_$noarg, error_table_$out_of_sequence) fixed binary (35) external; dcl (com_err_, com_err_$suppress_name) entry () options (variable); dcl convert_ipc_code_ entry (fixed binary (35)); dcl cu_$arg_count entry (fixed binary, fixed binary (35)); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl cu_$cp entry (pointer, fixed binary (21), fixed binary (35)); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl (ioa_, ioa_$nnl) entry () options (variable); dcl iox_$attach_name entry (character (*), pointer, character (*), pointer, fixed binary (35)); dcl iox_$destroy_iocb entry (pointer, fixed binary (35)); dcl iox_$detach_iocb entry (pointer, fixed binary (35)); dcl iox_$close entry (pointer, fixed binary (35)); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl iox_$get_line entry (pointer, pointer, fixed binary (24), fixed binary (24), fixed binary (35)); dcl iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35)); dcl iox_$put_chars entry (pointer, pointer, fixed binary (24), fixed binary (35)); dcl iox_$read_record entry (pointer, pointer, fixed binary (24), fixed binary (24), fixed binary (35)); dcl iox_$write_record entry (pointer, pointer, fixed binary (24), fixed binary (35)); dcl ipc_$block entry (pointer, pointer, fixed binary (35)); dcl ipc_$create_ev_chn entry (fixed binary (71), fixed binary (35)); dcl ipc_$delete_ev_chn entry (fixed binary (71), fixed binary (35)); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl requote_string_ entry (character (*)) returns (character (*)); dcl unique_chars_ entry (bit (*)) returns (character (15)); dcl (addr, binary, codeptr, collate, copy, currentsize, length, min, null, rel, rtrim, substr, string, translate, unspec) builtin; dcl (cleanup, hhoc_hangup_, program_interrupt) condition; %page; %include terminal_io_record; %page; %include hasp_signon_record_info; %page; %include iox_modes; %page; %include event_wait_info; %page; call cu_$arg_count (n_arguments, code); if code ^= 0 then do; /* not invoked as command */ call com_err_ (code, NAME); return; end; if n_arguments = 0 then do; call com_err_$suppress_name (0, NAME, "Usage: hasp_host_operators_console tty_channel {-control_args} {attach_arguments}"); return; end; signon_record = "0"b; /* assume caller doesn't want to send a SIGNON record */ call cu_$arg_ptr (1, argument_ptr, argument_lth, (0)); if index (argument, "-") = 1 then do; call com_err_ (0, NAME, "First argument must be a channel name; not the control argument ""^a"".", argument); return; end; if argument_lth > length (tty_channel) then do; call com_err_ (error_table_$bigarg, NAME, "Channel name must be 32 characters or less; not ""^a"".", tty_channel); return; end; tty_channel = argument; attach_description = "hasp_host_ -comm hasp -tty "; attach_description = attach_description || requote_string_ (rtrim (tty_channel)); attach_description = attach_description || " -device teleprinter"; /* Process optional arguments: -signon/-no_signon may be freely intermixed with the attach options (if any) */ do idx = 2 to n_arguments; call cu_$arg_ptr (idx, argument_ptr, argument_lth, (0)); if (argument = "-no_signon") then /* caller doesn't want a SIGNON record sent */ signon_record = "0"b; else if (argument = "-signon") then do; /* caller supplies a SIGNON record */ if idx = n_arguments then do; call com_err_ (error_table_$noarg, NAME, "Character string after ""-signon""."); return; end; idx = idx + 1; /* move on to next the argument */ call cu_$arg_ptr (idx, argument_ptr, argument_lth, (0)); if argument_lth > length (sri.record) then do; call com_err_ (error_table_$bigarg, NAME, "SIGNON record can not be longer than ^d characters; not ""^a"".", length (sri.record), argument); return; end; sri.record = argument; signon_record = "1"b; /* now will send a SIGNON record */ end; else do; /* anything else goes into the attach description */ attach_description = attach_description || " "; attach_description = attach_description || requote_string_ (argument); end; end; /* Attach the operator's console */ operators_console, /* for cleanup handler */ terminal_io_record_ptr = null (); sri.event_channel = -1; on condition (cleanup) call release_console (); call get_temp_segment_ (NAME, terminal_io_record_ptr, code); if code ^= 0 then do; call com_err_ (code, NAME, "Obtaining buffer space."); return; end; terminal_io_record_header_lth = 4 * binary (rel (addr (terminal_io_record.data)), 18, 0); terminal_io_record.version = terminal_io_record_version_1; terminal_io_record.device_type = TELEPRINTER_DEVICE; terminal_io_record.slew_type = SLEW_BY_COUNT; terminal_io_record.slew_count = 1; string (terminal_io_record.flags) = ""b; terminal_io_record.element_size = 9; switch_name = substr (tty_channel, 1, min (length (rtrim (tty_channel)), 16)) || "." || unique_chars_ (""b); call iox_$attach_name (switch_name, operators_console, (attach_description), codeptr (hasp_host_operators_console), code); if code ^= 0 then do; call com_err_ (code, NAME, "^/^-Attaching ^a using attach description: ^a", switch_name, attach_description); go to RETURN_FROM_COMMAND; end; call iox_$open (operators_console, Sequential_input_output, "0"b, code); if code ^= 0 then do; call com_err_ (code, NAME, "Opening ^a (channel ^a) for sequential input/output.", switch_name, tty_channel); go to RETURN_FROM_COMMAND; end; /* Validate the caller specified SIGNON processing: transmits the SIGNON record if need be */ if signon_record then do; /* send the SIGNON */ call ioa_ ("Sending the SIGNON record: ^a", translate (sri.record, UPPERCASE, LOWERCASE)); sri.version = SIGNON_RECORD_INFO_VERSION_1; call ipc_$create_ev_chn (sri.event_channel, code); if code ^= 0 then call convert_ipc_code_ (code); if code ^= 0 then do; call com_err_ (code, NAME, "Creating event channel for SIGNON record control order."); go to RETURN_FROM_COMMAND; end; sri.pad = ""b; call iox_$control (operators_console, "signon_record", addr (sri), code); if (code = 0) then do; /* multiplexer accepted the call: wait for response */ event_wait_list.n_channels = 1; event_wait_list.channels (1) = sri.event_channel; RETRY_WAIT_FOR_RESPONSE: call ipc_$block (addr (event_wait_list), addr (local_event_wait_info), code); if code ^= 0 then call convert_ipc_code_ (code); if code ^= 0 then do; call com_err_ (code, NAME, "Blocking to await response to SIGNON record control order."); go to RETURN_FROM_COMMAND; end; if local_event_wait_info.ring ^= 0 then do; call com_err_ (0, NAME, "Ignoring extraneous wakeup while waiting for response to SIGNON record control order."); go to RETRY_WAIT_FOR_RESPONSE; end; signon_response = local_event_wait_info.message; if (signon_response = HASP_SIGNON_OK) then call ioa_$nnl ("SIGNON record accepted... "); else if (signon_response = HASP_SIGNON_REJECTED) | (signon_response = HASP_SIGNON_HANGUP) then do; /* foreign system didn't like what we sent */ call com_err_ (0, NAME, "Foreign system rejected SIGNON record^; ^[ please retry^;foreign system has disconnected^].", (signon_response = HASP_SIGNON_REJECTED)); go to RETURN_FROM_COMMAND; end; else do; /* unknown response */ call com_err_ (0, NAME, "Unknown reponse to SIGNON control record order: ^d", signon_response); go to RETURN_FROM_COMMAND; end; end; else if (code = error_table_$out_of_sequence) then do; /* SIGNON record was sent once before... */ call com_err_ (0, NAME, "A SIGNON record was previously transmitted to this remote system."); call ioa_$nnl ("SIGNON record ignored... "); end; /* ... but that's not fatal */ else do; /* multiplexer rejected the control order: explain why */ if (code = error_table_$invalid_state) then call com_err_ (0, NAME, "Local multiplexer is not configured to transmit a SIGNON record."); else call com_err_ (code, NAME, "Requesting SIGNON record transmission."); go to RETURN_FROM_COMMAND; end; end; else do; /* caller doesn't want a SIGNON record transmitted */ call iox_$control (operators_console, "no_signon_record", null (), code); if code ^= 0 then do; /* ... but the multiplexer doesn't like that */ if (code = error_table_$invalid_state) then call com_err_ (0, NAME, "Local multiplexer is configured to transmit a SIGNON record."); else call com_err_ (code, NAME, "Validating that no SIGNON record need be transmitted."); go to RETURN_FROM_COMMAND; end; end; /* Establish a handler for hangup to terminate the command */ hangup_info.entry = hhoc_hangup_handler_; hangup_info.data_ptr = null (); hangup_info.priority = 1; call iox_$control (operators_console, "hangup_proc", addr (hangup_info), code); if code ^= 0 then do; call com_err_ (code, NAME, "Attempting to establish hangup handler for ^a (channel ^a)", switch_name, tty_channel); go to RETURN_FROM_COMMAND; end; on condition (hhoc_hangup_) begin; /* signaled when a hangup occurs */ call com_err_ (0, NAME, "Hangup detected on channel ^a.", tty_channel); go to RETURN_FROM_COMMAND; end; /* Main processing loop */ call ioa_ ("Input:"); processing = "1"b; on condition (program_interrupt) go to CONTINUE_TO_READ_FROM_SWITCHES; do while (processing); CONTINUE_TO_READ_FROM_SWITCHES: call iox_$control (iox_$user_input, "read_status", addr (ui_status), code); if code ^= 0 then do; call com_err_ (code, NAME, "Performing ""read_status"" on user_input."); go to RETURN_FROM_COMMAND; end; call iox_$control (operators_console, "read_status", addr (oc_status), code); if code ^= 0 then do; call com_err_ (code, NAME, "Performing ""read_status"" on channel ^a.", tty_channel); go to RETURN_FROM_COMMAND; end; if ui_status.input_available then do; /* process input (if any) */ call iox_$get_line (iox_$user_input, addr (terminal_io_record.data), (4 * sys_info$max_seg_size - terminal_io_record_header_lth), terminal_io_record.n_elements, code); if code ^= 0 then do; call com_err_ (code, NAME, "Reading from user_input."); go to RETURN_FROM_COMMAND; end; terminal_io_record.n_elements = terminal_io_record.n_elements - 1; /* ignore the newline */ if terminal_io_record.n_elements > 0 then if (substr (terminal_io_record_data_chars, 1, 1) = "!") then call interpret_escape_request (); /* user requests to do something special */ terminal_io_record_data_chars = translate (terminal_io_record_data_chars, NO_CONTROL_CHARS); /* convert control characters and non-ASCII to spaces */ call iox_$write_record (operators_console, terminal_io_record_ptr, (4 * currentsize (terminal_io_record)), code); if code ^= 0 then do; call com_err_ (code, NAME, "Writing to channel ^a.", tty_channel); go to RETURN_FROM_COMMAND; end; end; CHECK_FOR_FOREIGN_MESSAGES: if oc_status.input_available then do; /* process messages from foreign host */ call iox_$read_record (operators_console, terminal_io_record_ptr, (4 * sys_info$max_seg_size), (0), code); if code ^= 0 then do; call com_err_ (code, NAME, "Reading from channel ^a.", tty_channel); go to RETURN_FROM_COMMAND; end; call iox_$put_chars (iox_$user_output, addr (terminal_io_record.data), terminal_io_record.n_elements, (0)); call iox_$put_chars (iox_$user_output, addr (NL), length (NL), (0)); end; if ^ui_status.input_available & ^oc_status.input_available then do; /* no input from anywhere right now: wait for some */ event_wait_list.n_channels = 2; event_wait_list.channels (1) = ui_status.event_channel; event_wait_list.channels (2) = oc_status.event_channel; call ipc_$block (addr (event_wait_list), addr (local_event_wait_info), code); if code ^= 0 then call convert_ipc_code_ (code); if code ^= 0 then do; call com_err_ (code, NAME, "Attempting to wait for input from user_input or ^a.", tty_channel); go to RETURN_FROM_COMMAND; end; end; end; RETURN_FROM_COMMAND: call release_console (); return; /* Invoked when the operator's console channel hangs up: abort the command */ hhoc_hangup_handler_: entry (); signal condition (hhoc_hangup_); return; /* shouldn't get here... */ %page; /* Interpret escape requests: Currently, the only defined escape requests are -- !e command_line -- execute the given Multics command line, !..command_line -- execute the given Multics command line, !. -- identify this program and the channel being used, or !quit -- disconnect the channel and return to Multics command level */ interpret_escape_request: procedure (); if terminal_io_record.n_elements < 2 then do; /* must have more than just "!" */ call com_err_ (0, NAME, "No request supplied after ""!""."); go to CHECK_FOR_FOREIGN_MESSAGES; end; if (substr (terminal_io_record_data_chars, 2, 2) = "e ") | (substr (terminal_io_record_data_chars, 2, 2) = "..") then call cu_$cp (addr (terminal_io_record.data.bits (4)), (terminal_io_record.n_elements - 3), (0)); else if (terminal_io_record.n_elements = 2) & (terminal_io_record_data_chars = "!.") then call ioa_ ("^a version ^d.^d; connected to channel ^a.", NAME, MAJOR_VERSION, MINOR_VERSION, tty_channel); else if (terminal_io_record.n_elements = length ("!quit")) & (terminal_io_record_data_chars = "!quit") then go to RETURN_FROM_COMMAND; /* WARNING: this method can lose messages from host */ else call com_err_ (0, NAME, "Unrecognized request line: ^a", terminal_io_record_data_chars); go to CHECK_FOR_FOREIGN_MESSAGES; end interpret_escape_request; %page; /* Release operator's console (if attached) and perform other necessary cleanup */ release_console: procedure (); if terminal_io_record_ptr ^= null () then do; call release_temp_segment_ (NAME, terminal_io_record_ptr, (0)); terminal_io_record_ptr = null (); end; if operators_console ^= null () then do; /* have the I/O switch */ call iox_$close (operators_console, (0)); call iox_$detach_iocb (operators_console, (0)); call iox_$destroy_iocb (operators_console, (0)); operators_console = null (); end; if sri.event_channel ^= -1 then do; /* created an IPC channel for SIGNON records */ call ipc_$delete_ev_chn (sri.event_channel, (0)); sri.event_channel = -1; end; return; end release_console; end hasp_host_operators_console;  hasp_stream_.pl1 07/13/88 1141.4r w 07/13/88 0935.7 213030 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: style4,indattr,ifthen,^indproc */ hasp_stream_: proc; /* I/O module to allow stream I/O over HASP channels. */ /* Written Feb 1985 by Jim Homan. */ /****^ HISTORY COMMENTS: 1) change(87-03-31,Beattie), approve(87-04-06,MCR7656), audit(87-07-30,Parisek), install(87-08-04,MR12.1-1055): Add support to allow HASP operator subchannels to be login service. END HISTORY COMMENTS */ /* external entries */ dcl continue_to_signal_ entry (fixed bin (35)); dcl get_group_id_ entry () returns (char (32)); dcl get_pdir_ entry () returns (char (168)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl com_err_ entry () options (variable); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$set_ips_mask entry (bit (*) aligned, bit (*) aligned); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$propagate entry (ptr); dcl iox_$err_not_open entry () options (variable); dcl iox_$err_not_closed entry () options (variable); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl terminate_process_ entry (char (*), ptr); /* error codes */ dcl sys_info$max_seg_size fixed bin (35) ext static; dcl error_table_$long_record fixed bin (35) ext static; dcl error_table_$unable_to_do_io fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext; /* Expected argument missing. */ dcl error_table_$incompatible_attach fixed bin (35) ext; /* Attach and open are incompatible. */ dcl error_table_$not_attached fixed bin (35) ext; /* I/O switch (or device) is not attached. */ dcl error_table_$not_detached fixed bin (35) ext; /* I/O switch is not detached. */ dcl error_table_$wrong_no_of_args fixed bin (35) ext static; /* parameters */ dcl buffer_length fixed bin (21) parameter; dcl buffer_ptr ptr parameter; dcl code fixed bin (35) parameter; dcl com_err_switch bit (1) aligned parameter; dcl iocb_ptr ptr parameter; dcl n_read fixed bin (21) parameter; dcl obsolete bit (1) aligned parameter; dcl option_array (*) char (*) var parameter; dcl mode fixed bin parameter; dcl new_modes char (*) parameter; dcl old_modes char (*) parameter; dcl info_ptr ptr parameter; dcl order char (*) parameter; /* automatic variables */ dcl terminal_io_header_length fixed bin (21); dcl hasp_stream_info_ptr ptr; dcl mask bit (36) aligned; dcl atd_ptr ptr; dcl temp_atd char (256) var; dcl 1 local_input_timeout_info aligned like input_timeout_info; dcl 1 local_output_timeout_info aligned like output_timeout_info; dcl stop_time fixed bin (71); dcl line_start_pos fixed bin (21); dcl line_start_ptr ptr; dcl line_length fixed bin (21); /* constants */ dcl ME char (32) int static options (constant) init ("hasp_stream_"); dcl SP char (1) int static options (constant) init (" "); dcl NL char (1) int static options (constant) init (" "); dcl sio_mode char (24) var int static options (constant) init ("stream_input_output"); dcl so_mode char (24) var int static options (constant) init ("stream_output"); dcl si_mode char (24) var int static options (constant) init ("stream_input"); /* based variables */ dcl 1 atd based (atd_ptr) aligned, 2 length fixed bin, 2 string char (length (temp_atd) refer (atd.length)); dcl 1 open_descrip aligned like atd based; dcl 1 hasp_stream_info based (hasp_stream_info_ptr) aligned, 2 temp_seg_ptr ptr, 2 target_iocb_ptr ptr, 2 mode fixed bin, 2 target_attach_description char (256) var, 2 target_switch_name char (32) unal, 2 must_close_target bit (1), 2 must_detach_target bit (1); /* builtins */ dcl (addr, addcharno, bin, clock, collate, copy, currentsize, hbound, index, length, max, min, null, rel, rtrim, string, substr, translate) builtin; /* conditions */ dcl any_other condition; dcl cleanup condition; %page; %include iocb; %page; %include iox_modes; %page; %include pit; %page; %include terminal_io_record; %page; %include user_attributes; %page; %include io_timeout_info; %page; hasp_stream_attach: entry (iocb_ptr, option_array, com_err_switch, code); if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do; code = error_table_$not_detached; if com_err_switch then call com_err_ (code, ME, "^a", iocb_ptr -> iocb.name); return; end; if hbound (option_array, 1) < 1 then do; code = error_table_$noarg; if com_err_switch then call com_err_ (code, ME, "^/Attach description must be: ""hasp_stream_ TargetSwitch"" or ""hasp_stream_ -target TargetATD"""); return; end; atd_ptr, hasp_stream_info_ptr = null (); on cleanup call attach_err_cleanup; allocate hasp_stream_info; hasp_stream_info.target_iocb_ptr = null (); hasp_stream_info.temp_seg_ptr = null (); hasp_stream_info.target_switch_name = ""; hasp_stream_info.target_attach_description = ""; hasp_stream_info.must_close_target, hasp_stream_info.must_detach_target = "0"b; call get_temp_segment_ (ME, hasp_stream_info.temp_seg_ptr, code); if code ^= 0 then do; if com_err_switch then call com_err_ (code, ME, "Cannot get temp segment."); return; end; call process_option_array (code); if code ^= 0 then goto ATTACH_ERR_EXIT; if hasp_stream_info.target_attach_description ^= "" then call attach_target; if code ^= 0 then do; if com_err_switch then call com_err_ (code, ME, "Cannot attach target switch with attach description:^/^a", hasp_stream_info.target_attach_description); goto ATTACH_ERR_EXIT; end; allocate atd; atd.string = temp_atd; on any_other call any_other_handler (); /* Can't tolerate inconsistent IOCBs */ revert cleanup; call hcs_$set_ips_mask ("0"b, mask); /* Mask IPS signals while changing IOCB */ iocb_ptr -> iocb.attach_descrip_ptr = atd_ptr; iocb_ptr -> iocb.attach_data_ptr = hasp_stream_info_ptr; iocb_ptr -> iocb.detach_iocb = hasp_stream_detach_iocb; iocb_ptr -> iocb.open = hasp_stream_open; iocb_ptr -> iocb.modes = hasp_stream_modes; iocb_ptr -> iocb.control = hasp_stream_control; call iox_$propagate (iocb_ptr); call hcs_$set_ips_mask (mask, "0"b); /* Restore IPS signals */ revert any_other; code = 0; return; ATTACH_ERR_EXIT: call attach_err_cleanup (); return; attach_err_cleanup: proc; if atd_ptr ^= null () then free atd; if hasp_stream_info_ptr ^= null () then do; if hasp_stream_info.temp_seg_ptr ^= null () then call release_temp_segment_ (ME, hasp_stream_info.temp_seg_ptr, (0)); free hasp_stream_info; end; end attach_err_cleanup; %page; /* procedure to fill in attach_data and temp_atd from arguments passed via option_array */ process_option_array: proc (ec); dcl ec fixed bin (35); dcl argN fixed bin; ec = 0; if option_array (1) = "-target" then do; hasp_stream_info.target_attach_description = ""; temp_atd = rtrim (ME) || " " || option_array (1); do argN = 2 to hbound (option_array, 1); hasp_stream_info.target_attach_description = hasp_stream_info.target_attach_description || option_array (argN) || " "; temp_atd = temp_atd || " " || option_array (argN); end; end; else do; if hbound (option_array, 1) ^= 1 then do; ec = error_table_$wrong_no_of_args; if com_err_switch then call com_err_ (ec, ME, "^/Attach description must be: ""hasp_stream_ TargetSwitch"", ""hasp_stream_ -login_channel"" or ""hasp_stream_ -target TargetATD"""); return; end; if option_array (1) = "-login_channel" then do; /* get pointer to the PIT to get login channel */ call hcs_$initiate (get_pdir_ (), "pit", "pit_", (0), (0), pit_ptr, ec); if pit_ptr ^= null () then ec = 0; if ec ^= 0 then do; if com_err_switch then call com_err_ (ec, ME, "Unable to get pointer to PIT."); return; end; hasp_stream_info.target_attach_description = "hasp_workstation_ -device teleprinter -comm hasp -suppress_dial_manager -tty " || rtrim (pit.tty); temp_atd = rtrim (ME) || " -login_channel -target " || hasp_stream_info.target_attach_description; end; else do; hasp_stream_info.target_switch_name = option_array (1); temp_atd = rtrim (ME) || " " || option_array (1); end; end; end process_option_array; %page; hasp_stream_open: entry (iocb_ptr, mode, obsolete, code); hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; if mode ^= Stream_input & mode ^= Stream_output & mode ^= Stream_input_output then do; code = error_table_$incompatible_attach; return; end; hasp_stream_info.mode = mode; call open_target; if code ^= 0 then do; call close_and_detach_target; return; end; on any_other call any_other_handler (); /* Can't tolerate inconsistent IOCBs */ call hcs_$set_ips_mask ("0"b, mask); /* Mask IPS signals while changing IOCB */ iocb_ptr -> iocb.actual_iocb_ptr -> iocb.detach_iocb = iox_$err_not_closed; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.close = hasp_stream_close; if hasp_stream_info.mode = Stream_input then do; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (si_mode); iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_line = hasp_stream_get_line; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_chars = hasp_stream_get_chars; end; else if hasp_stream_info.mode = Stream_output then do; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (so_mode); iocb_ptr -> iocb.actual_iocb_ptr -> iocb.put_chars = hasp_stream_put_chars; end; else do; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (sio_mode); iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_line = hasp_stream_get_line; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_chars = hasp_stream_get_chars; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.put_chars = hasp_stream_put_chars; end; call iox_$propagate (iocb_ptr); call hcs_$set_ips_mask (mask, "0"b); /* Restore IPS signals */ revert any_other; return; %page; attach_target: proc; hasp_stream_info.target_switch_name = "hasp_stream_." || unique_chars_ ("0"b); call iox_$attach_name (hasp_stream_info.target_switch_name, hasp_stream_info.target_iocb_ptr, (hasp_stream_info.target_attach_description), null (), code); if code ^= 0 then return; hasp_stream_info.must_detach_target = "1"b; end attach_target; %page; open_target: proc; dcl target_mode char (24) var; dcl target_mode_number fixed bin; /* First get the IOCB for this switch */ call iox_$look_iocb (hasp_stream_info.target_switch_name, hasp_stream_info.target_iocb_ptr, code); if code ^= 0 then return; /* Make sure the switch is attached */ if hasp_stream_info.target_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = null then do; code = error_table_$not_attached; return; end; /* If the switch is already open, make sure its opening mode is OK */ if hasp_stream_info.target_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; target_mode = hasp_stream_info.target_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr -> open_descrip.string; if hasp_stream_info.mode = Stream_input_output then do; if target_mode ^= "sequential_input_output" then code = error_table_$incompatible_attach; end; else if hasp_stream_info.mode = Stream_input then do; if target_mode ^= "sequential_input" & target_mode ^= "sequential_input_output" then code = error_table_$incompatible_attach; end; else if hasp_stream_info.mode = Stream_output then do; if target_mode ^= "sequential_output" & target_mode ^= "sequential_input_output" then code = error_table_$incompatible_attach; end; end; else do; /* If it wasn't already open, open it for appropriate mode */ if hasp_stream_info.mode = Stream_input then target_mode_number = Sequential_input; else if hasp_stream_info.mode = Stream_output then target_mode_number = Sequential_output; else target_mode_number = Sequential_input_output; call iox_$open (hasp_stream_info.target_iocb_ptr, target_mode_number, obsolete, code); if code = 0 then hasp_stream_info.must_close_target = "1"b; end; end open_target; %page; hasp_stream_detach_iocb: entry (iocb_ptr, code); hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; on any_other call any_other_handler (); /* Can't tolerate inconsistent IOCBs */ call release_temp_segment_ (ME, hasp_stream_info.temp_seg_ptr, (0)); free iocb_ptr -> iocb.attach_descrip_ptr -> atd; free iocb_ptr -> iocb.attach_data_ptr -> hasp_stream_info; call hcs_$set_ips_mask ("0"b, mask); /* Mask IPS signals while changing IOCB */ iocb_ptr -> iocb.attach_descrip_ptr = null (); call iox_$propagate (iocb_ptr); call hcs_$set_ips_mask (mask, "0"b); /* Restore IPS signals */ revert any_other; code = 0; return; %page; hasp_stream_close: entry (iocb_ptr, code); hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; call close_and_detach_target; on any_other call any_other_handler (); /* Can't tolerate inconsistent IOCBs */ call hcs_$set_ips_mask ("0"b, mask); /* Mask IPS signals while changing IOCB */ iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null (); iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open = hasp_stream_open; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.detach_iocb = hasp_stream_detach_iocb; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.modes = iox_$err_not_open; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.control = iox_$err_not_open; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_chars = iox_$err_not_open; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.put_chars = iox_$err_not_open; iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_line = iox_$err_not_open; call iox_$propagate (iocb_ptr); call hcs_$set_ips_mask (mask, "0"b); /* Restore IPS signals */ revert any_other; code = 0; return; %page; hasp_stream_get_chars: entry (iocb_ptr, buffer_ptr, buffer_length, n_read, code); hasp_stream_get_line: entry (iocb_ptr, buffer_ptr, buffer_length, n_read, code); hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; terminal_io_record_ptr = hasp_stream_info.temp_seg_ptr; terminal_io_record.n_elements = 0; /* Might not be set if code ^= 0 */ n_read = 0; call iox_$read_record (hasp_stream_info.target_iocb_ptr, terminal_io_record_ptr, (4 * sys_info$max_seg_size), (0), code); if terminal_io_record.n_elements ^= 0 then call convert_input (buffer_ptr, buffer_length, n_read, code); return; %page; hasp_stream_put_chars: entry (iocb_ptr, buffer_ptr, buffer_length, code); hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; terminal_io_record_ptr = hasp_stream_info.temp_seg_ptr; line_start_pos = 0; call get_next_line (buffer_ptr, buffer_length, line_start_ptr, line_start_pos, line_length); do while (line_start_ptr ^= null ()); call convert_output (line_start_ptr, line_length); call iox_$write_record (hasp_stream_info.target_iocb_ptr, terminal_io_record_ptr, (4 * currentsize (terminal_io_record)), code); call get_next_line (buffer_ptr, buffer_length, line_start_ptr, line_start_pos, line_length); end; return; %page; hasp_stream_control: entry (iocb_ptr, order, info_ptr, code); /* Just pass through all orders except the timeout orders that need to be changed a bit. */ hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; if order = "get_chars_timeout" | order = "get_line_timeout" then do; terminal_io_record_ptr = hasp_stream_info.temp_seg_ptr; terminal_io_record.n_elements = 0; timeout_info_ptr = info_ptr; local_input_timeout_info.timeout = input_timeout_info.timeout; local_input_timeout_info.buffer_pointer = terminal_io_record_ptr; local_input_timeout_info.buffer_length = 4 * sys_info$max_seg_size; input_timeout_info.characters_read = 0; call iox_$control (hasp_stream_info.target_iocb_ptr, "read_record_timeout", addr (local_input_timeout_info), code); if terminal_io_record.n_elements ^= 0 then call convert_input (input_timeout_info.buffer_pointer, input_timeout_info.buffer_length, input_timeout_info.characters_read, code); end; else if order = "put_chars_timeout" then do; terminal_io_record_ptr = hasp_stream_info.temp_seg_ptr; timeout_info_ptr = info_ptr; output_timeout_info.characters_written = 0; stop_time = clock () + input_timeout_info.timeout; terminal_io_header_length = bin (rel (addr (terminal_io_record.data))); line_start_pos = 0; call get_next_line (output_timeout_info.buffer_pointer, output_timeout_info.buffer_length, line_start_ptr, line_start_pos, line_length); do while (line_start_ptr ^= null ()); call convert_output (line_start_ptr, line_length); local_output_timeout_info.timeout = max (0, stop_time - clock ()); local_output_timeout_info.buffer_length = 4 * currentsize (terminal_io_record); local_output_timeout_info.buffer_pointer = terminal_io_record_ptr; call iox_$control (hasp_stream_info.target_iocb_ptr, "write_record_timeout", addr (local_output_timeout_info), code); if code ^= 0 then return; output_timeout_info.characters_written = line_start_pos + line_length; /* write_record_timeout writes all or none */ call get_next_line (output_timeout_info.buffer_pointer, output_timeout_info.buffer_length, line_start_ptr, line_start_pos, line_length); end; if output_timeout_info.characters_written > output_timeout_info.buffer_length then output_timeout_info.characters_written = output_timeout_info.buffer_length; /* Can happen if no NL at end */ end; else call iox_$control (hasp_stream_info.target_iocb_ptr, order, info_ptr, code); return; %page; hasp_stream_modes: entry (iocb_ptr, new_modes, old_modes, code); hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; call iox_$modes (hasp_stream_info.target_iocb_ptr, new_modes, old_modes, code); return; %page; /* procedure to close target switch if opened by hasp_stream_, and detach if attached by hasp_stream_ */ close_and_detach_target: proc; if hasp_stream_info.must_close_target then call iox_$close (hasp_stream_info.target_iocb_ptr, 0); hasp_stream_info.must_close_target = "0"b; if hasp_stream_info.must_detach_target then call iox_$detach_iocb (hasp_stream_info.target_iocb_ptr, 0); hasp_stream_info.must_detach_target = "0"b; end close_and_detach_target; %page; any_other_handler: proc; dcl 1 fatal_error_info aligned, 2 version fixed bin, 2 status_code fixed bin (35); if get_group_id_ () = "Initializer.SysDaemon.z" then do; if mask then call hcs_$set_ips_mask (mask, "0"b); mask = ""b; call continue_to_signal_ ((0)); /* hope to get an asdump */ end; else do; fatal_error_info.version = 0; fatal_error_info.status_code = error_table_$unable_to_do_io; call terminate_process_ ("fatal_error", addr (fatal_error_info)); end; end any_other_handler; %page; convert_output: proc (output_string_ptr, output_string_length); dcl output_string_ptr ptr; dcl output_string_length fixed bin (21); dcl output_string char (output_string_length) based (output_string_ptr); dcl NO_CONTROL_CHARS character (512) initial (copy (SP, 32) || substr (collate (), 33) || copy (SP, 384)); terminal_io_record.version = terminal_io_record_version_1; terminal_io_record.device_type = TELEPRINTER_DEVICE; terminal_io_record.slew_type = SLEW_BY_COUNT; terminal_io_record.slew_count = 1; string (terminal_io_record.flags) = ""b; terminal_io_record.element_size = 9; terminal_io_record.n_elements = length (output_string); terminal_io_record_data_chars = translate (output_string, NO_CONTROL_CHARS); /* convert control characters and non-ASCII to spaces */ end convert_output; convert_input: proc (input_buffer_ptr, input_buffer_length, n_read, ec); dcl input_buffer_ptr ptr; dcl input_buffer_length fixed bin (21); dcl n_read fixed bin (21); dcl ec fixed bin (35); dcl 1 input_buffer based (input_buffer_ptr), 2 data char (min (n_read - 1, input_buffer_length)), 2 new_line char (1); ec = 0; n_read = terminal_io_record.n_elements + 1; input_buffer.data = terminal_io_record_data_chars; if n_read < input_buffer_length then input_buffer.new_line = NL; else ec = error_table_$long_record; end convert_input; %page; get_next_line: proc (buf_ptr, buf_len, line_start_ptr, line_start_pos, line_len); dcl buf_ptr ptr; dcl buf_len fixed bin (21); dcl line_start_ptr ptr; dcl line_start_pos fixed bin (21); dcl line_len fixed bin (21); dcl next_NL fixed bin (21); dcl buffer char (buf_len) based (buf_ptr); if buf_len <= 0 then do; /* Catch zero-length buffer */ line_start_ptr = null (); return; end; if line_start_pos = 0 then line_start_pos = 1; else do; line_start_pos = line_start_pos + line_length; /* Move past prev line */ if line_start_pos > buf_len then do; /* Could be at end if prev line didn't end in NL */ line_start_ptr = null (); return; end; if substr (buffer, line_start_pos, 1) = NL then line_start_pos = line_start_pos + 1; /* Bump past NL at end of prev line */ if line_start_pos > buf_len then do; /* Check again for end */ line_start_ptr = null (); return; end; end; line_start_ptr = addcharno (buf_ptr, line_start_pos - 1); next_NL = index (substr (buffer, line_start_pos), NL); if next_NL = 0 then /* No NL at buffer end */ line_length = buf_len - line_start_pos + 1; else line_length = next_NL - 1; end get_next_line; end hasp_stream_;  hasp_util_.pl1 12/20/82 1103.4rew 12/20/82 1052.8 107073 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* Support functions for use by user-ring HASP I/O modules */ /* Created: December 1979 by G. Palter */ /* Modified: 13 January 1980 by G. Palter to have the character to be treated as a space for compression/expansion be a parameter rather than fixed as the EBCDIC space character */ /* Modified: 22 July 1981 by G. Palter to compress only spaces in order to increase the performance of HASP I/O switches */ /* Modified: 15 December 1982 by G. Palter to return error_table_$short_record if the expand_text entry reaches the end of the input buffer normally without finding an end-of-record indicator */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ hasp_util_: procedure (); return; /* not an entry */ /* Error returns */ OUTPUT_BUFFER_OVERFLOWS: if expand_entry then /* reflect what part was processed */ P_input_text_used = input_text_used - 1; else P_input_text_used = input_text_used; P_output_buffer_used = output_buffer_used; P_code = error_table_$long_record; return; BAD_DATA_FORMAT: P_input_text_used = input_text_used - 1; /* this much processed successfully */ P_output_buffer_used = output_buffer_used; P_code = error_table_$improper_data_format; return; /* Parameters */ dcl P_input_text_ptr pointer parameter; /* -> text to be compressed or decompressed (I) */ dcl P_input_text_lth fixed binary (21) parameter; /* length of above text (I) */ dcl P_input_text_used fixed binary (21) parameter; /* amount of above text processed (I/O) */ dcl P_output_buffer_ptr pointer parameter; /* -> buffer to hold resulting text (I) */ dcl P_output_buffer_lth fixed binary (21) parameter; /* size of above buffer (I) */ dcl P_output_buffer_used fixed binary (21) parameter; /* amount of above buffer used (I/O) */ dcl P_space character (1) aligned parameter; /* treated as a space for compression/expansion (I) */ dcl P_code fixed binary (35) parameter; /* status code (O) */ /* Local copies of parameters */ dcl input_text_ptr pointer; dcl (input_text_lth, input_text_used) fixed binary (21); dcl output_buffer_ptr pointer; dcl (output_buffer_lth, output_buffer_used) fixed binary (21); dcl space character (1); /* Remaining declarations */ dcl input_text character (input_text_lth) unaligned based (input_text_ptr); dcl input_text_array (input_text_lth) character (1) unaligned based (input_text_ptr); dcl output_buffer character (output_buffer_lth) unaligned based (output_buffer_ptr); dcl output_buffer_array (output_buffer_lth) character (1) unaligned based (output_buffer_ptr); dcl scb_char character (1) unaligned based (scb_char_ptr); dcl 1 scb unaligned based (scb_char_ptr) like hasp_scb_byte; dcl 1 not_compressed_scb unaligned based (scb_char_ptr) like hasp_not_compressed_scb_byte; dcl 1 compressed_scb unaligned based (scb_char_ptr) like hasp_compressed_scb_byte; dcl scb_char_ptr pointer; dcl expand_entry bit (1) aligned; /* ON => expand_text entry; OFF => compress_text entry */ dcl space_space character (2); dcl the_character character (1) unaligned; dcl is_space bit (1) aligned; dcl (amount_to_scan, first_duplicate_idx, compression_count, count) fixed binary (21); dcl found_eor bit (1) aligned; /* found end-of-record while expanding */ /* format: off */ dcl (error_table_$improper_data_format, error_table_$long_record, error_table_$short_record) fixed binary (35) external; /* format: on */ dcl (addr, index, min, substr, verify) builtin; %page; /* Compress text: apply HASP compression algorithm on the supplied text, placing result into given output buffer */ compress_text: entry (P_input_text_ptr, P_input_text_lth, P_input_text_used, P_output_buffer_ptr, P_output_buffer_lth, P_output_buffer_used, P_space, P_code); expand_entry = "0"b; input_text_ptr = P_input_text_ptr; input_text_lth = P_input_text_lth; input_text_used = P_input_text_used; output_buffer_ptr = P_output_buffer_ptr; output_buffer_lth = P_output_buffer_lth; output_buffer_used = P_output_buffer_used; space = P_space; space_space = space || space; call add_scb_char (); /* add an initial SCB for this piece of text */ do while (input_text_used < input_text_lth); amount_to_scan = min ((input_text_lth - input_text_used), (HASP_MAX_NOT_COMPRESSED_TEXT_LTH - not_compressed_scb.count)); first_duplicate_idx = index (substr (input_text, (input_text_used + 1), amount_to_scan), space_space); /* do first_duplicate_idx = 1 to (amount_to_scan - 1) */ /* while (substr (input_text, (input_text_used+first_duplicate_idx), 1) */ /* ^= substr (input_text, (input_text_used+first_duplicate_idx+1), 1)); */ /* end; */ /* search for first duplicated character */ /* if first_duplicate_idx = amount_to_scan */ if first_duplicate_idx = 0 then do; /* No duplicates found: in this portion of the text, no duplicate characters were found so this portion will be copied directly to the output buffer. The size of this substring was computed to not overflow the possibly partially-used SCB already at the end of the output buffer */ call copy_for_compression (amount_to_scan); if input_text_used < input_text_lth then call add_scb_char (); end; else do; /* Duplicate characters found: copy any portion of the string before these characters; if more than two of this character appears in the string, use the compressed form of the SCB to save space in the output buffer */ if first_duplicate_idx > 1 then /* some text appears before the duplicates */ call copy_for_compression (first_duplicate_idx - 1); the_character = substr (input_text, (input_text_used + 1), 1); is_space = (the_character = space); compression_count = verify (substr (input_text, (input_text_used + 1)), the_character) - 1; if compression_count = -1 then /* rest of string is the same character */ compression_count = input_text_lth - input_text_used; if compression_count > 2 then do; /* compression is possible */ if not_compressed_scb.count = 0 then output_buffer_used = output_buffer_used - 1; count = compression_count; do while (count > 0); call add_scb_char (); scb.not_compressed = "0"b; compressed_scb.not_blank = ^is_space; compressed_scb.count = min (count, HASP_MAX_COMPRESSED_TEXT_LTH); if ^is_space then do; if output_buffer_used = output_buffer_lth then do; output_buffer_used = output_buffer_used - 1; go to OUTPUT_BUFFER_OVERFLOWS; end; /* be sure to flush the SCB before returning */ output_buffer_used = output_buffer_used + 1; substr (output_buffer, output_buffer_used, 1) = the_character; end; count = count - compressed_scb.count; input_text_used = input_text_used + compressed_scb.count; end; if input_text_used < input_text_lth then call add_scb_char (); end; else do; /* duplicate is too short to benifit from compression */ call copy_for_compression (compression_count); if (not_compressed_scb.count = HASP_MAX_NOT_COMPRESSED_TEXT_LTH) & (input_text_used < input_text_lth) then call add_scb_char (); end; end; end; P_input_text_used = input_text_used; /* reflect what was done to caller */ P_output_buffer_used = output_buffer_used; P_code = 0; return; %page; /* Expand text: apply the inverse of the HASP compression algorithm on the supplied text, placing the result into the given output buffer. If the entire input text is successfully processed but an end-of-record string control byte (SCB) is not found, error_table_$short_record will be returned */ expand_text: entry (P_input_text_ptr, P_input_text_lth, P_input_text_used, P_output_buffer_ptr, P_output_buffer_lth, P_output_buffer_used, P_space, P_code); expand_entry = "1"b; /* for output overflow error handling */ input_text_ptr = P_input_text_ptr; input_text_lth = P_input_text_lth; input_text_used = P_input_text_used; output_buffer_ptr = P_output_buffer_ptr; output_buffer_lth = P_output_buffer_lth; output_buffer_used = P_output_buffer_used; space = P_space; found_eor = "0"b; /* haven't seen EOR yet */ do while (input_text_used < input_text_lth); input_text_used = input_text_used + 1; /* have picked up an SCB */ scb_char_ptr = addr (input_text_array (input_text_used)); if scb_char = HASP_EOR_SCB then do; /* found the end of a record */ found_eor = "1"b; go to RETURN_FROM_EXPAND_TEXT; end; else if scb.not_compressed then do; /* A piece of not compressed text: simply copy it to the output buffer */ count = not_compressed_scb.count; if (input_text_used + count) > input_text_lth then go to BAD_DATA_FORMAT; /* not enough text in input stream */ if (output_buffer_used + count) > output_buffer_lth then go to OUTPUT_BUFFER_OVERFLOWS; substr (output_buffer, (output_buffer_used + 1), count) = substr (input_text, (input_text_used + 1), count); input_text_used = input_text_used + count; output_buffer_used = output_buffer_used + count; end; else do; /* A piece of compressed text: duplicate the requested character in the output buffer */ count = compressed_scb.count; if compressed_scb.not_blank then do; /* not space: get the character */ if (input_text_used + 1) > input_text_lth then go to BAD_DATA_FORMAT; input_text_used = input_text_used + 1; the_character = substr (input_text, input_text_used, 1); end; else the_character = space; /* compressed character is a space */ if (output_buffer_used + count) > output_buffer_lth then go to OUTPUT_BUFFER_OVERFLOWS; substr (output_buffer, (output_buffer_used + 1), count) = copy (the_character, count); output_buffer_used = output_buffer_used + count; end; end; RETURN_FROM_EXPAND_TEXT: P_input_text_used = input_text_used; P_output_buffer_used = output_buffer_used; if found_eor then /* processing terminated at end-of-record */ P_code = 0; else P_code = error_table_$short_record; /* processing terminated at end of input text */ return; %page; /* Add an SCB character to the output buffer */ add_scb_char: procedure (); if output_buffer_used = output_buffer_lth then go to OUTPUT_BUFFER_OVERFLOWS; output_buffer_used = output_buffer_used + 1; scb_char_ptr = addr (output_buffer_array (output_buffer_used)); scb.not_eor = "1"b; scb.not_compressed = "1"b; not_compressed_scb.count = 0; return; end add_scb_char; /* Copy a piece of text from the input string to the output buffer and update the SCB character count */ copy_for_compression: procedure (P_n_characters); dcl P_n_characters fixed binary (21) parameter; dcl n_characters fixed binary (21); n_characters = P_n_characters; if (output_buffer_used + n_characters) > output_buffer_lth then go to OUTPUT_BUFFER_OVERFLOWS; substr (output_buffer, (output_buffer_used + 1), n_characters) = substr (input_text, (input_text_used + 1), n_characters); output_buffer_used = output_buffer_used + n_characters; not_compressed_scb.count = not_compressed_scb.count + n_characters; input_text_used = input_text_used + n_characters; /* advance "pointer" past text already compressed */ return; end copy_for_compression; %page; %include hasp_srcb_scb_bytes; end hasp_util_;  hasp_workstation_.pl1 10/17/88 1109.4r w 10/17/88 1034.1 792657 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* I/O Module for communications with a HASP workstation: This I/O module is designed for use by the I/O daemon's RJE software (remote_driver_). It communicates with the HASP workstation through a TTY channel controlled by the ring-0 HASP demultiplexer. As each TTY channel connected through the HASP demultiplexer communicates with only a single device of the physical HASP workstation, this I/O module will ensure that all I/O switches attached to a given channel have the same device type. (Multiple I/O switches are allowed to support multiple request types being attached to the same channel.) */ /* Created: January 1980 by G. Palter */ /* Modified: 1 September 1980 by G. Palter to remove stream mode support */ /* Modified: 2 December 1980 by G. Palter to properly set return code for io_call control order */ /* Modified: 18 December 1980 by G. Palter to support -terminal_type for input/output translations */ /* Modified: 13 January 1981 by G. Palter to pass the representation of a space in the transmission medium's character code to hasp_util_ */ /* Modified: 22 July 1981 by G. Palter to convert to version 2 dial_manager_ and invoke release_channel when done with a particular channel */ /* Modified: 25 December 1981 by G. Palter to support set_forms control order */ /* Modified: 26 July 1982 by G. Palter to add get_channel_info control order */ /* Modified: October 1982 by G. Palter to drastically improve write_record performance by changing the order of calls to hcs_$tty_order, hcs_$tty_write, and ipc_$block and to use mvt_ rather than the PL/I translate builtin where appropriate */ /* Modified: 14 December 1982 by G. Palter to support "s0" as a valid carriage control sequence (HASP #008), to fix bugs in the read_record entrypoint's handling of partial or very long input records (HASP #001 and HASP #002), and to insure proper behavior of the read_record entrypoint when the input record will not fit in the caller's buffer */ /* Modified: 12 February 1985 by Jim Homan to support HASP operator consoles as message coordinator consoles: add read_record_timeout, write_record_timeout, set_event_channel and set_term_type control orders; add -suppress_dial_manager control arg. Also removed calls to convert_ipc_code_, changed substraddr to addcharno, created timer_manager_constants include file. */ /****^ HISTORY COMMENTS: 1) change(87-03-17,LJAdams), approve(87-04-03,MCR7646), audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030): Changed ttd_version to ttd_version_3. 2) change(87-04-03,Beattie), approve(87-04-06,MCR7656), audit(87-07-30,Parisek), install(87-08-03,MR12.1-1055): Add support for control orders necessary to use operator subchannel on HASP workstation multiplexer as login channels. END HISTORY COMMENTS */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ hasp_workstation_: procedure (); return; /* not an entry */ /* Parameters */ dcl P_iocb_ptr pointer parameter; /* *: -> I/O switch being operated upon */ dcl P_code fixed binary (35) parameter; dcl P_attach_options (*) character (*) varying parameter; /* attach: attachment arguments */ dcl P_loud_sw bit (1) parameter; /* attach: ON => attachment errors should call com_err_ */ dcl P_open_mode fixed binary parameter; /* open: opening mode */ dcl P_open_sw bit (1) parameter; /* open: obsolete parameter */ dcl P_record_lth fixed binary (21) parameter; /* read_record: set to size of terminal_io_record read into buffer in characters; get_chars: set to # of characters read into buffer; write_record, put_chars: size of terminal_io_record to be written in characters */ dcl P_buffer_ptr pointer parameter; /* read_record, get_chars: -> area to place result of read */ dcl P_buffer_lth fixed binary (21) parameter; /* read_record, get_chars: size of area in characters */ dcl P_record_ptr pointer parameter; /* write_record, put_chars: -> terminal_io_record to be written */ dcl P_order character (*) parameter; /* control: name of control order to be performed */ dcl P_info_ptr pointer parameter; /* control: -> additional information required to execute the control order */ dcl P_new_modes character (*) parameter; /* modes: new modes to be set */ dcl P_old_modes character (*) parameter; /* modes: set to modes in effect before change */ dcl P_timeout fixed bin (71) parameter; /* read_record_timed: */ dcl P_chars_sent fixed bin (21) parameter; /* write_record_timed: */ /* Local copies of parameters */ dcl iocb_ptr pointer; dcl code fixed binary (35); dcl temp_state fixed bin; dcl based_state fixed bin based; dcl argument character (argument_lth) based (argument_ptr);/* based on attach options */ dcl argument_lth fixed binary (21); dcl argument_ptr pointer; dcl loud_sw bit (1) aligned; dcl open_mode fixed binary; dcl order character (32); dcl info_ptr pointer; /* Remaining declarations */ dcl event_channel fixed bin (71) based; dcl system_area area aligned based (system_area_ptr); dcl system_area_ptr pointer; dcl argument_idx fixed binary; /* # of attach option being processed */ dcl (tty_channel, device_name) character (32); /* required components of attach description */ dcl have_comm bit (1) aligned; /* ON => -comm option given (required) */ dcl terminal_type character (32); /* terminal type specifying translations (optional) */ dcl block_on_io_sw bit (1) aligned; /* OFF => -no_block given */ dcl suppress_dial_manager_sw bit (1) aligned; /* ON => -suppress_dial_manager given */ dcl other_attach_options character (256) varying; /* optional portions supplied by caller */ dcl timeout fixed bin (71); dcl stop_time fixed bin (71); dcl device_type fixed binary; /* local copy used for argument processing */ dcl idx fixed binary; dcl character_value character (32); /* unused values from argument processing */ dcl numeric_value fixed binary (35); dcl 1 ttd aligned like terminal_type_data; /* used to call ttt_info_$terminal_data */ dcl 1 dma aligned like dial_manager_arg; /* used to attach the channel */ dcl 1 local_event_wait_info aligned like event_wait_info; /* for calls to ipc_$block */ dcl dialup_msg_channel character (32); /* arguments to convert_dial_message_ */ dcl 1 dialup_msg_flags aligned, 2 dialed_up bit (1) unaligned, 2 hungup bit (1) unaligned, 2 control bit (1) unaligned, 2 pad bit (33) unaligned; dcl state fixed binary; /* MCS channel state value */ dcl multiplexer_device_type fixed binary; /* for "get_device_type" control order */ dcl 1 tty_modes aligned, /* used to change MCS modes */ 2 modes_lth fixed binary, 2 modes character (256); dcl 1 read_status aligned, /* for "read_status" control order */ 2 event_channel fixed binary (71), /* channel to block on waiting for input to arrive */ 2 input_available bit (1); /* ON => data in ring-0 waiting to be read */ dcl 1 write_status aligned, /* for "write_status" control order */ 2 event_channel fixed binary (71), /* channel to block on waiting for write to complete */ 2 output_pending bit (1); /* ON => data in ring-0 waiting to be sent */ dcl ips_mask bit (36); /* IPS mask */ dcl cv_string_buffer character (cv_string_buffer_lth) based (cv_string_buffer_ptr); dcl cv_string_buffer_used character (cv_string_buffer_used_lth) based (cv_string_buffer_ptr); dcl (cv_string_buffer_lth, cv_string_buffer_used_lth) fixed binary (21); dcl (cv_string_buffer_ptr, new_cv_string_buffer_ptr) pointer; dcl io_buffer character (io_buffer_lth) unaligned based (io_buffer_ptr); dcl (io_buffer_lth, io_buffer_used, io_buffer_read) fixed binary (21); dcl io_buffer_ptr pointer; /* buffer for I/O to/from the channel */ dcl cv_string_buffer_space character (384); /* local space large enough for most conversions */ dcl io_buffer_space character (256) unaligned; /* local space large enough for most I/O */ dcl (compress_code, expand_code) fixed binary (35); /* code from hasp_util_$compress_text/expand_text */ dcl terminal_io_record_header_lth fixed binary (21); dcl previous_data character (64) varying; /* large enough for an SCB and associated data */ dcl (have_srcb, more_data_needed) bit (1) aligned; dcl srcb_read character (1); /* SRCB read from the device */ dcl n_extra_records fixed binary; /* used to calculate output I/O buffer size */ dcl srcb character (1) unaligned based (srcb_ptr); /* SRCB character being constructed/interpreted */ dcl srcb_ptr pointer; dcl 1 hasp_printer_srcb unaligned based (srcb_ptr) like hasp_printer_srcb_byte; dcl more_srcbs_needed bit (1) aligned; /* local state used to perform output slewing */ dcl (n_last_opcode, local_slew_count) fixed binary; dcl pid bit (36) aligned based (info_ptr); /* data used by "assign_to_user_process" control order */ dcl detachflag fixed bin aligned based (info_ptr); /* data used by "detach_user_process" control order */ dcl line_type fixed bin based (info_ptr); /* data used by "set_line_type" control order */ dcl 1 read_status_info aligned like read_status based (info_ptr); /* data used by "read_status" control order */ dcl 1 hangup_proc_info aligned based (info_ptr), /* data used by "hangup_proc" control order */ 2 procedure entry variable, /* procedure to invoke when line is hungup */ 2 data_ptr pointer, /* user's data to be supplied to said procedure */ 2 priority fixed binary; /* priority of this event call channel */ dcl 1 get_channel_info aligned based (info_ptr) like tty_get_channel_info; dcl NAME character (32) static options (constant) initial ("hasp_workstation_"); /* format: off */ dcl (NUL initial (""), ASCII_SPACE initial (" "), EBCDIC_SPACE initial ("@")) character (1) static options (constant); dcl (UPPERCASE initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"), LOWERCASE initial ("abcdefghijklmnopqrstuvwxyz")) character (26) static options (constant); dcl ascii_to_ebcdic_$ae_table character (128) external; dcl ebcdic_to_ascii_$ea_table character (256) external; dcl error_table_$timeout fixed bin(35) ext static; dcl error_table_$invalid_device fixed bin(35) ext static; dcl (error_table_$action_not_performed, error_table_$bad_conversion, error_table_$bad_mode, error_table_$badopt, error_table_$bigarg, error_table_$device_type_unknown, error_table_$eof_record, error_table_$improper_data_format, error_table_$inconsistent, error_table_$incorrect_device_type, error_table_$invalid_read, error_table_$invalid_write, error_table_$io_no_permission, error_table_$long_record, error_table_$noalloc, error_table_$noarg, error_table_$not_attached, error_table_$not_closed, error_table_$not_detached, error_table_$not_open, error_table_$null_info_ptr, error_table_$short_record, error_table_$smallarg, error_table_$unable_to_do_io, error_table_$undefined_order_request, error_table_$unimplemented_version, error_table_$wrong_no_of_args) fixed binary (35) external; /* format: on */ dcl com_err_ entry () options (variable); dcl continue_to_signal_ entry (fixed binary (35)); dcl convert_dial_message_ entry (bit (72) aligned, character (*), character (*), fixed binary, 1 aligned like dialup_msg_flags, fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl dial_manager_$privileged_attach entry (pointer, fixed binary (35)); dcl dial_manager_$release_channel entry (pointer, fixed binary (35)); dcl get_group_id_ entry () returns (char (32)); dcl get_system_free_area_ entry () returns (pointer); dcl hasp_util_$compress_text entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21), character (1) aligned, fixed binary (35)); dcl hasp_util_$expand_text entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21), character (1) aligned, fixed binary (35)); dcl hcs_$assign_channel entry (fixed binary (71), fixed binary (35)); dcl hcs_$delete_channel entry (fixed binary (71), fixed binary (35)); dcl hcs_$reset_ips_mask entry (bit (36), bit (36)); dcl hcs_$set_ips_mask entry (bit (36), bit (36)); dcl hcs_$tty_detach_new_proc entry (fixed bin, bit (36) aligned, fixed bin, fixed bin (35)); dcl hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35)); dcl hcs_$tty_abort entry (fixed binary, fixed binary, fixed binary, fixed binary (35)); dcl hcs_$tty_attach entry (character (*), fixed binary (71), fixed binary, fixed binary, fixed binary (35)); dcl hcs_$tty_detach entry (fixed binary, fixed binary, fixed binary, fixed binary (35)); dcl hcs_$tty_order entry (fixed binary, character (*), pointer, fixed binary, fixed binary (35)); dcl hcs_$tty_state entry (fixed bin, fixed bin, fixed bin (35)); dcl hcs_$tty_read entry (fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary, fixed binary (35)); dcl hcs_$tty_write entry (fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary, fixed binary (35)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1)); dcl iox_$err_no_operation entry (); dcl iox_$propagate entry (pointer); dcl ipc_$block entry (pointer, pointer, fixed binary (35)); dcl ipc_$create_ev_chn entry (fixed binary (71), fixed binary (35)); dcl ipc_$decl_ev_call_chn entry (fixed binary (71), entry, pointer, fixed binary, fixed binary (35)); dcl ipc_$decl_ev_wait_chn entry (fixed binary (71), fixed binary (35)); dcl ipc_$delete_ev_chn entry (fixed binary (71), fixed binary (35)); dcl mvt_ entry (pointer, pointer, fixed binary (21), character (512) aligned); dcl requote_string_ entry (character (*)) returns (character (*)); dcl terminate_process_ entry (char (*), ptr); dcl timer_manager_$alarm_wakeup entry (fixed binary (71), bit (2), fixed binary (71)); dcl timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); dcl ttt_info_$terminal_data entry (character (*), fixed binary, fixed binary, pointer, fixed binary (35)); dcl (any_other, area, cleanup) condition; dcl (addcharno, addr, binary, clock, copy, currentsize, divide, dimension, hbound, index, lbound, length, ltrim, max, maxlength, min, mod, null, rel, rtrim, string, substr, translate, unspec) builtin; %page; /* Data describing a single switch attached through this I/O module */ dcl 1 had aligned based (had_ptr), 2 attach_description character (256) varying, /* attach description for this I/O switch */ 2 open_description character (24) varying, /* open description (mode) */ 2 channel_info_ptr pointer, /* -> description of the channel */ 2 top_of_page_sequence_ptr pointer, /* -> description of slewing operations to reach next page */ 2 inside_page_sequence_ptr pointer, /* -> ... next inside page (head sheet) */ 2 outside_page_sequence_ptr pointer, /* -> ... next outside page (tail sheet) */ 2 default_forms character (32) varying, /* default type of forms used on this switch (from -forms) */ 2 current_forms character (32) varying, /* type of forms currently in use (set_forms control order) */ 2 translations, 3 input character (512), /* received data -> ASCII translate table */ 3 output character (512), /* ASCII -> transmittable data translate table */ 3 space character (1), /* an ASCII space in remote device's character code */ 2 chain, /* chain of I/O switches attached to this channel */ 3 next pointer, 3 previous pointer; dcl had_ptr pointer; /* Data describing a single TTY channel attached through this I/O module */ dcl 1 channel_info aligned based (channel_info_ptr), 2 name character (32), /* name of channel described by this entry */ 2 device_type fixed binary, /* type of device attached on this channel */ 2 devx fixed binary, /* MCS identifier of this channel */ 2 event_channel fixed binary (71), /* MCS signals events via this ipc_ channel */ 2 attach_event_channel fixed binary (71), /* used to obtain the channel from the Answering Service */ 2 hads, /* chain of I/O switches attached to this channel */ 3 first pointer, 3 last pointer, 2 held_input_ptr pointer, /* -> input from this channel waiting for processing */ 2 forms character (32) varying, /* type of forms last written to this device */ 2 chain, /* chain of channels attached via this I/O module */ 3 previous pointer, 3 next pointer, 2 flags, 3 attached bit (1) unaligned, /* ON => channel has been attached from answering service */ 3 attach_channel_is_call bit (1) unaligned, /* ON => attach channel has been converted to call channel */ 3 event_channel_assigned bit (1) unaligned, 3 event_channel_created bit (1) unaligned, 3 output_interrupted bit (1) unaligned, /* ON => a write_record timed out and a resetwrite must be done before further output */ 3 suppress_dial_manager bit (1) unaligned, 3 block_on_io bit (1) unaligned, /* ON => block on read and write IO operations */ 3 pad bit (29) unaligned; dcl channel_info_ptr pointer; dcl first_channel_info_ptr pointer internal static initial (null ()); dcl last_channel_info_ptr pointer internal static initial (null ()); /* Slew sequence description: the types of slewing performed by the I/O daemon (top-of-page/inside-psage/outside-page) must be translated into a sequence of operations intepretable by the HASP workstation. These operations are either (1) skip N lines or (2) skip to channel N. The sequences are specified in the attach description */ dcl 1 slew_sequence aligned based (slew_sequence_ptr), 2 n_ops fixed binary, /* # of operations required to do this type of slewing */ 2 ops (slew_sequence_n_ops refer (slew_sequence.n_ops)), 3 count_or_channel fixed binary, /* # of lines to skip or channel # */ 3 skip_to_channel bit (1); /* ON => above value is channel #; OFF => it's a line count */ dcl slew_sequence_ptr pointer; dcl slew_sequence_n_ops fixed binary; /* used by attach entry to allocate this structure */ /* Held input: The read_record operation may read more data from ring-0 than necessary; this data is held in this structure for later processing */ dcl 1 held_input aligned based (held_input_ptr), 2 n_elements_used fixed binary (21), /* # of characters still being held */ 2 n_elements_allocated fixed binary (21), /* # of characters initially held */ 2 data character (held_input_n_elements_allocated refer (held_input.n_elements_allocated)); dcl held_input_ptr pointer; dcl held_input_n_elements_allocated fixed binary (21); %page; /* Attach an I/O switch to a device of a HASP workstation */ hasp_workstation_attach: entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code); iocb_ptr = P_iocb_ptr; loud_sw = P_loud_sw; code = 0; /* assume no errors yet */ had_ptr = null (); /* avoid freeing garbage if I/O switch already attached */ if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do; P_code = error_table_$not_detached; /* special case this error */ if loud_sw then call com_err_ (P_code, NAME, "For switch ^a.", iocb_ptr -> iocb.name); return; end; system_area_ptr = get_system_free_area_ (); on condition (cleanup) call cleanup_attachment ((0)); /* Process attachment options */ if hbound (P_attach_options, 1) < 1 then call abort_attachment (error_table_$noarg, "At least ""-comm"", ""-tty"", and ""-device"" must be supplied."); allocate had in (system_area) set (had_ptr); have_comm = "0"b; /* haven't seen -comm yet */ tty_channel = ""; /* haven't seen -tty yet */ device_name = ""; /* haven't seen -device yet */ terminal_type = ""; /* haven't seen -terminal_type yet */ block_on_io_sw = "1"b; /* set the default values */ suppress_dial_manager_sw = "0"b; other_attach_options = ""; /* optional stuff goes here */ had.open_description = ""; had.top_of_page_sequence_ptr, /* haven't seen slew control information yet */ had.inside_page_sequence_ptr, had.outside_page_sequence_ptr = null (); had.default_forms, had.current_forms = ""; /* haven't seen -forms yet */ call set_translation (had.translations.input, /* assume input is EBCDIC */ addr (ebcdic_to_ascii_$ea_table), length (ebcdic_to_ascii_$ea_table)); call set_translation (had.translations.output, addr (ascii_to_ebcdic_$ae_table), length (ascii_to_ebcdic_$ae_table)); had.translations.space = EBCDIC_SPACE; /* default translations */ had.channel_info_ptr = null (); /* prevents abort from prematurely detaching channel */ do argument_idx = lbound (P_attach_options, 1) to hbound (P_attach_options, 1); argument_ptr = addcharno (addr (P_attach_options (argument_idx)), 4); argument_lth = length (P_attach_options (argument_idx)); if substr (argument, 1, 1) ^= "-" then /* do not allow non-control arguments */ call abort_attachment (error_table_$wrong_no_of_args, "All options must be control arguments."); if (argument = "-comm") then do; /* communications module: must be "hasp" */ character_value = get_string_argument (); if (argument ^= "hasp") then call abort_attachment (0, "Communications module must be ""hasp""."); have_comm = "1"b; /* got the right value */ end; else if (argument = "-tty") then /* specification of TTY channel */ tty_channel = get_string_argument (); else if (argument = "-device") then do; /* type of device on other end of channel */ device_name = get_string_argument (); device_type = -1; do idx = lbound (HASP_DEVICE_NAMES, 1) to hbound (HASP_DEVICE_NAMES, 1) while (device_type = -1); if HASP_DEVICE_NAMES (idx) = device_name then device_type = idx; end; if device_type = -1 then /* unknown type */ call abort_attachment (error_table_$device_type_unknown, "Device type must be one of ^v(""^a"", ^)or ""^a""; not ""^a"".", (dimension (HASP_DEVICE_NAMES, 1) - 1), HASP_DEVICE_NAMES, device_name); end; else if (argument = "-terminal_type") | (argument = "-ttp") then do; /* terminal type: specifies input/output translations */ terminal_type = get_string_argument (); terminal_type = translate (terminal_type, UPPERCASE, LOWERCASE); ttd.version = ttd_version_3; /* try to get input/output translations */ call ttt_info_$terminal_data (terminal_type, -1, 0, addr (ttd), code); if code ^= 0 then call abort_attachment (code, "-terminal_type ^a", terminal_type); if (ttd.tables.input_tr_ptr = null ()) | (ttd.tables.output_tr_ptr = null ()) then call abort_attachment (0, "Terminal type ""^a"" does not specify input and output translations.", terminal_type); call set_translation (had.translations.input, addr (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value), dimension (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value, 1)); call set_translation (had.translations.output, addr (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value), dimension (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value, 1)); had.translations.space = translate (ASCII_SPACE, had.translations.output); end; else if (argument = "-physical_line_length") | (argument = "-pll") then do; /* supplied by calling I/O module: ignored here */ numeric_value = get_numeric_argument (); other_attach_options = other_attach_options || " -physical_line_length "; other_attach_options = other_attach_options || argument; end; else if (argument = "-ebcdic") then /* supplied by calling I/O module: ignored here */ other_attach_options = other_attach_options || " -ebcdic"; else if (argument = "-ascii") then /* hasp_workstation_ doesn't support ASCII data */ call abort_attachment (0, "ASCII is not supported by this I/O module."); else if (argument = "-horizontal_tab") | (argument = "-htab") then call abort_attachment (0, "Horizontal tabs are not supported by this I/O module."); else if (argument = "-top_of_page") then do; /* specifies how to get to top of any page */ call parse_slew_sequence (had.top_of_page_sequence_ptr); other_attach_options = other_attach_options || " -top_of_page "; other_attach_options = other_attach_options || argument; end; else if (argument = "-inside_page") then do; /* specifies how to get to top of inside page */ call parse_slew_sequence (had.inside_page_sequence_ptr); other_attach_options = other_attach_options || " -inside_page "; other_attach_options = other_attach_options || argument; end; else if (argument = "-outside_page") then do;/* specifies how to get to top of outside page */ call parse_slew_sequence (had.outside_page_sequence_ptr); other_attach_options = other_attach_options || " -outside_page "; other_attach_options = other_attach_options || argument; end; else if (argument = "-forms") then do; /* specifies forms to be used for this switch */ character_value = get_string_argument (); if argument_lth > maxlength (had.default_forms) then call abort_attachment (error_table_$bigarg, "Forms name must be ^d characters or less.", maxlength (had.default_forms)); character_value = translate (character_value, UPPERCASE, LOWERCASE); other_attach_options = other_attach_options || " -forms "; other_attach_options = other_attach_options || requote_string_ (substr (character_value, 1, argument_lth)); had.default_forms = substr (character_value, 1, argument_lth); end; /* will translate to proper code later */ else if (argument = "-suppress_dial_manager") then do; suppress_dial_manager_sw = "1"b; other_attach_options = other_attach_options || " -suppress_dial_manager"; end; else if (argument = "-no_block") then do; block_on_io_sw = "0"b; other_attach_options = other_attach_options || " -no_block"; end; else call abort_attachment (error_table_$badopt, """^a""", argument); end; /* of argument processing loop */ /* Validate that all required information has been supplied and apply any needed defaults */ if ^have_comm then /* must specify -comm */ call abort_attachment (error_table_$noarg, """-comm"""); if (tty_channel = "") then /* must specify -tty */ call abort_attachment (error_table_$noarg, """-tty"""); if (device_name = "") then /* must specify -device */ call abort_attachment (error_table_$noarg, """-device"""); if (device_type = HASP_PRINTER) then /* only printers need slewing sequences */ if ((had.top_of_page_sequence_ptr = null ()) | (had.inside_page_sequence_ptr = null ()) | (had.outside_page_sequence_ptr = null ())) then do; /* not all sequences supplied: default to skip to channel 1 */ slew_sequence_n_ops = 1; allocate slew_sequence in (system_area) set (slew_sequence_ptr); slew_sequence.ops (1).count_or_channel = 1; slew_sequence.ops (1).skip_to_channel = "1"b; if (had.top_of_page_sequence_ptr = null ()) then had.top_of_page_sequence_ptr = slew_sequence_ptr; if (had.inside_page_sequence_ptr = null ()) then had.inside_page_sequence_ptr = slew_sequence_ptr; if (had.outside_page_sequence_ptr = null ()) then had.outside_page_sequence_ptr = slew_sequence_ptr; end; else ; /* all sequences were specified */ else /* not printer: reject any slewing controls */ if ((had.top_of_page_sequence_ptr ^= null ()) | (had.inside_page_sequence_ptr ^= null ()) | (had.outside_page_sequence_ptr ^= null ())) then do; if (had.outside_page_sequence_ptr ^= null ()) then idx = 3; if (had.inside_page_sequence_ptr ^= null ()) then idx = 2; if (had.top_of_page_sequence_ptr ^= null ()) then idx = 1; call abort_attachment (error_table_$inconsistent, """-^[top_of_page^;inside_page^;outside_page^]"" may not be specified for the ^a device.", idx, device_name); end; if (device_type ^= HASP_PRINTER) then /* do not allow forms if not a printer */ if (had.default_forms ^= "") then call abort_attachment (error_table_$inconsistent, """-forms"" may not be specified for the ^a device.", device_name); if (had.default_forms ^= "") then do; /* translate to code used by foreign device */ had.default_forms = translate (had.default_forms, had.translations.output); had.current_forms = had.default_forms; /* start out by using this forms specification */ end; /* Build the attach description */ had.attach_description = rtrim (NAME); had.attach_description = had.attach_description || " -comm hasp -tty "; had.attach_description = had.attach_description || rtrim (tty_channel); had.attach_description = had.attach_description || " -device "; had.attach_description = had.attach_description || rtrim (device_name); if (terminal_type ^= "") then do; /* optional -terminal_type was given */ had.attach_description = had.attach_description || " -terminal_type "; had.attach_description = had.attach_description || rtrim (terminal_type); end; had.attach_description = had.attach_description || other_attach_options; /* Find the description of this channel: Validate that all I/O switches attached to this channel are of for the same type of I/O daemon device (printer, reader, etc.) */ do channel_info_ptr = first_channel_info_ptr repeat (channel_info.chain.next) while (channel_info_ptr ^= null ()); if channel_info.name = tty_channel then go to FOUND_CHANNEL; end; FOUND_CHANNEL: if (channel_info_ptr = null ()) then do; /* first use of the channel */ allocate channel_info in (system_area) set (channel_info_ptr); channel_info.name = tty_channel; channel_info.device_type = device_type; channel_info.devx, channel_info.event_channel, channel_info.attach_event_channel = -1; channel_info.hads = null (); /* no switches connected yet */ channel_info.held_input_ptr = null (); /* no read ahead yet */ channel_info.forms = ""; /* no forms used yet */ string (channel_info.flags) = ""b; /* not attached yet */ if first_channel_info_ptr = null () then first_channel_info_ptr = channel_info_ptr; else last_channel_info_ptr -> channel_info.chain.next = channel_info_ptr; channel_info.chain.previous = last_channel_info_ptr; channel_info.chain.next = null (); last_channel_info_ptr = channel_info_ptr; end; else /* channel in use: insure that device type is correct */ if channel_info.device_type ^= device_type then call abort_attachment (error_table_$incorrect_device_type, "Device type of ^a is ""^a""; not ""^a"".", tty_channel, HASP_DEVICE_NAMES (channel_info.device_type), HASP_DEVICE_NAMES (device_type)); if channel_info.hads.first = null () then channel_info.hads.first = had_ptr; /* first switch for this channel */ else channel_info.hads.last -> had.chain.next = had_ptr; had.chain.previous = channel_info.hads.last; had.chain.next = null (); channel_info.hads.last = had_ptr; had.channel_info_ptr = channel_info_ptr; /* Acquire and attach the channel if necessary */ if channel_info.devx = -1 then do; channel_info.block_on_io = block_on_io_sw; channel_info.suppress_dial_manager = suppress_dial_manager_sw; if suppress_dial_manager_sw then goto ASSUME_ATTACHED; /* Request the TTY channel from the Answering Service */ call ipc_$create_ev_chn (channel_info.attach_event_channel, code); if code ^= 0 then call abort_attachment (code, "Creating ipc_ channel."); dma.version = dial_manager_arg_version_2; dma.dial_channel = channel_info.attach_event_channel; dma.channel_name = tty_channel; dma.dial_qualifier, dma.dial_out_destination, dma.reservation_string = ""; call dial_manager_$privileged_attach (addr (dma), code); if code = error_table_$action_not_performed then go to ASSUME_ATTACHED; if code ^= 0 then call abort_attachment (code, "Attempting to attach ^a.", tty_channel); event_wait_channel.n_channels = 1; event_wait_channel.channel_id (1) = channel_info.attach_event_channel; WAIT_FOR_ANSWERING_SERVICE: call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code); /* wait for answering service to give it to us */ if code ^= 0 then call abort_attachment (code, "Waiting for attachment to ^a.", tty_channel); call convert_dial_message_ (unspec (local_event_wait_info.message), dialup_msg_channel, ((32)" "), (0), dialup_msg_flags, code); if code ^= 0 then call abort_attachment (code, "Interpreting attachment to ^a.", tty_channel); if ^dialup_msg_flags.dialed_up then do; /* seems to be a wakeup for some other channel */ call com_err_ (0, NAME, "For switch ^a: Unexpected signal from answering service - ^[hangup^;control^] for channel ^a.", iocb_ptr -> iocb.name, dialup_msg_flags.hungup, dialup_msg_channel); go to WAIT_FOR_ANSWERING_SERVICE; end; /* Create the event channel for ring-0: try using a special channel first */ ASSUME_ATTACHED: channel_info.attached = "1"b; /* we have the channel from the answering service now */ call hcs_$assign_channel (channel_info.event_channel, code); if code = 0 then channel_info.event_channel_assigned = "1"b; else do; /* couldn't get fast channel: try standard one */ call ipc_$create_ev_chn (channel_info.event_channel, code); if code ^= 0 then call abort_attachment (code, "Creating ipc_ channel."); channel_info.event_channel_created = "0"b; end; /* Attach the channel through the ring-0 HASP multiplexer in MCS, validate the supplied device type, and set its modes to "rawi,rawo" */ call hcs_$tty_attach (tty_channel, channel_info.event_channel, channel_info.devx, state, code); if ^suppress_dial_manager_sw then if state ^= 5 then code = error_table_$io_no_permission; if suppress_dial_manager_sw then if code = error_table_$action_not_performed then /* This means the mpx is down */ call abort_attachment (error_table_$invalid_device, /* But the message coordinator likes this error code to mean mpx down. */ "The parent multiplexer has not been loaded."); if code ^= 0 then call abort_attachment (code, "Unable to attach to ^a.", tty_channel); call hcs_$tty_order (channel_info.devx, "get_device_type", addr (multiplexer_device_type), state, code); if ^suppress_dial_manager_sw then if state ^= 5 then code = error_table_$io_no_permission; if (code = 0) then if (channel_info.device_type = multiplexer_device_type) then ; /* proper device type for this channel */ else call abort_attachment (error_table_$incorrect_device_type, "Device type of ^a is ""^a""; not ""^a"".", tty_channel, HASP_DEVICE_NAMES (multiplexer_device_type), HASP_DEVICE_NAMES (channel_info.device_type)); else if (code = error_table_$undefined_order_request) then call abort_attachment (0, "^a is not connected to a HASP multiplexer.", tty_channel); else call abort_attachment (code, "Unable to determine device type of ^a.", tty_channel); tty_modes.modes = "rawi,rawo"; tty_modes.modes_lth = length (tty_modes.modes); call hcs_$tty_order (channel_info.devx, "modes", addr (tty_modes), state, code); if ^suppress_dial_manager_sw then if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then call abort_attachment (code, "Unable to set initial modes for ^a.", tty_channel); end; /* Mask and complete construction of the IOCB */ ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = addr (had.attach_description); iocb_ptr -> iocb.attach_data_ptr = had_ptr; iocb_ptr -> iocb.open = hasp_workstation_open; iocb_ptr -> iocb.control = hasp_workstation_control_before_open; iocb_ptr -> iocb.detach_iocb = hasp_workstation_detach; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); RETURN_FROM_ATTACH: P_code = code; return; %page; /* Open an I/O switch connected to a HASP workstation: only record oriented openings are supported */ hasp_workstation_open: entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; open_mode = P_open_mode; if ^((open_mode = Sequential_input) | (open_mode = Sequential_output) | (open_mode = Sequential_input_output)) then do; P_code = error_table_$bad_mode; return; end; had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; if (channel_info.device_type = HASP_READER) then if (open_mode = Sequential_output) then do; /* reader opened for output only */ P_code = error_table_$bad_mode; return; end; if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then if (open_mode = Sequential_input) then do; /* printer/punch opened for input only */ P_code = error_table_$bad_mode; return; end; had.open_description = rtrim (iox_modes (open_mode)); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); if ((open_mode = Sequential_input) | (open_mode = Sequential_input_output)) then iocb_ptr -> iocb.read_record = hasp_workstation_read_record; if ((open_mode = Sequential_output) | (open_mode = Sequential_input_output)) then iocb_ptr -> iocb.write_record = hasp_workstation_write_record; iocb_ptr -> iocb.control = hasp_workstation_control; iocb_ptr -> iocb.modes = hasp_workstation_modes; iocb_ptr -> iocb.close = hasp_workstation_close; iocb_ptr -> iocb.detach_iocb = hasp_workstation_detach; iocb_ptr -> iocb.open_descrip_ptr = addr (had.open_description); /* it's now open */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = 0; return; %page; /* Close an I/O switch connected to a HASP workstation */ hasp_workstation_close: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; if iocb_ptr -> iocb.open_descrip_ptr = null () then do; P_code = error_table_$not_open; return; end; ips_mask = ""b; on condition (cleanup) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.open_descrip_ptr = null (); iocb_ptr -> iocb.open = hasp_workstation_open; iocb_ptr -> iocb.detach_iocb = hasp_workstation_detach; iocb_ptr -> iocb.control = hasp_workstation_control_before_open; iocb_ptr -> iocb.modes, iocb_ptr -> iocb.read_record, iocb_ptr -> iocb.write_record = iox_$err_no_operation; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = 0; return; %page; /* Detach an I/O switch from a device of a HASP workstation */ hasp_workstation_detach: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr; if iocb_ptr -> iocb.attach_descrip_ptr = null () then do; P_code = error_table_$not_attached; return; end; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; system_area_ptr = get_system_free_area_ (); had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; call cleanup_attachment (code); /* remove this switch and the channel if necessary */ ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = null (); /* it's detached */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; /* in case trouble freeing the channel */ return; %page; /* Read a record: read a single record from the device, returning a "standard" terminal_io_record structure */ hasp_workstation_read_record: entry (P_iocb_ptr, P_buffer_ptr, P_buffer_lth, P_record_lth, P_code); call init_read (); if ^channel_info.block_on_io then timeout = 0; else timeout = -1; goto READ_JOIN; hasp_workstation_read_record_timed: /* For read_record_timeout control order */ entry (P_iocb_ptr, P_buffer_ptr, P_buffer_lth, P_record_lth, P_code, P_timeout); call init_read (); if ^channel_info.block_on_io then do; P_code = error_table_$inconsistent; return; end; timeout = P_timeout; READ_JOIN: stop_time = clock () + timeout; code = 0; if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then do; P_code = error_table_$invalid_read; /* can't read from printer or punch */ return; end; system_area_ptr = get_system_free_area_ (); cv_string_buffer_ptr = null (); /* for cleanup handler */ on condition (cleanup) begin; if cv_string_buffer_ptr ^= null () then if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then free cv_string_buffer in (system_area); end; /* Validate that there is room in the buffer to hold some actual data in addition to a terminal_io_record header */ terminal_io_record_ptr = P_buffer_ptr; terminal_io_record_header_lth = /* # of characters of buffer occupied by record's header */ 4 * (binary (rel (addr (terminal_io_record.data)), 18, 0) - binary (rel (terminal_io_record_ptr), 18, 0)); if terminal_io_record_header_lth >= P_buffer_lth then do; code = error_table_$smallarg; /* supplied buffer is just TOO small */ return; end; terminal_io_record_n_elements = P_buffer_lth - terminal_io_record_header_lth; /* # of actual characters that will fit into the buffer */ /* Obtain and unpack a record: a record is constructed from any data obtained in prior calls to read_record in addition to whatever data must be read from ring-0 in this call to complete the record. Unpacking is performed on the data in 256 character sections until hasp_util_$expand_text detects the end-of-record sequence in the stream */ cv_string_buffer_ptr = addr (cv_string_buffer_space); cv_string_buffer_lth = length (cv_string_buffer_space); cv_string_buffer_used_lth = 0; /* start putting data into automatic */ previous_data = ""; /* piece left from previous read */ srcb_ptr = addr (srcb_read); /* a place to put the SRCB ... */ have_srcb = "0"b; /* ... which hasn't been found yet */ more_data_needed = "1"b; do while (more_data_needed); /* Select source of data for this time around: if necessary, data will be read from ring-0 */ if channel_info.held_input_ptr ^= null () then do; /* read ahead: process as much of the block as can be used */ io_buffer_ptr = addr (channel_info.held_input_ptr -> held_input.data); io_buffer_lth = channel_info.held_input_ptr -> held_input.n_elements_allocated; io_buffer_read = channel_info.held_input_ptr -> held_input.n_elements_used; end; else do; /* no more read ahead: obtain more data from ring-0 */ io_buffer_ptr = addr (io_buffer_space); io_buffer_lth = length (io_buffer_space); call read_io_buffer (); /* sets io_buffer_read */ if code ^= 0 then go to RETURN_FROM_READ_RECORD; if io_buffer_read = 0 then do; terminal_io_record.n_elements = 0; P_record_lth = 0; P_code = 0; return; end; end; if length (previous_data) > 0 then do; /* some data left over from previous junk: merge them */ held_input_n_elements_allocated = length (previous_data) + io_buffer_read; allocate held_input in (system_area) set (held_input_ptr); held_input.n_elements_used = held_input.n_elements_allocated; substr (held_input.data, 1, length (previous_data)) = previous_data; substr (held_input.data, (length (previous_data) + 1), io_buffer_read) = substr (io_buffer, 1, io_buffer_read); if io_buffer_ptr ^= addr (io_buffer_space) then free channel_info.held_input_ptr -> held_input in (system_area); channel_info.held_input_ptr = held_input_ptr; io_buffer_ptr = addr (held_input.data); io_buffer_lth, io_buffer_read = held_input.n_elements_used; previous_data = ""; end; /* Unpack the data: stop when an end-of-record indicator is found */ if have_srcb then io_buffer_used = 0; /* in middle of record: first character in buffer is SCB */ else do; /* first part of record: first character is SRCB */ srcb = substr (io_buffer, 1, 1); io_buffer_used = 1; have_srcb = "1"b; end; do while (more_data_needed & (io_buffer_used < io_buffer_read)); call hasp_util_$expand_text (addr (io_buffer), io_buffer_read, io_buffer_used, addr (cv_string_buffer), cv_string_buffer_lth, cv_string_buffer_used_lth, had.translations.space, expand_code); if expand_code = 0 then more_data_needed = "0"b; /* found end of record indicator */ else if expand_code = error_table_$short_record then ; /* took entire buffer but need more */ else if expand_code = error_table_$long_record then do; /* overflowed the output buffer: grow it and continue */ cv_string_buffer_lth = 2 * cv_string_buffer_lth; on condition (area) begin; /* can't get enough room: record is not readable */ code = error_table_$noalloc; go to RETURN_FROM_READ_RECORD; end; allocate cv_string_buffer in (system_area) set (new_cv_string_buffer_ptr); revert condition (area); new_cv_string_buffer_ptr -> cv_string_buffer_used = cv_string_buffer_used; if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then free cv_string_buffer in (system_area); cv_string_buffer_ptr = new_cv_string_buffer_ptr; end; else if (io_buffer_read - io_buffer_used) <= (HASP_MAX_NOT_COMPRESSED_TEXT_LTH + 1) then do; /* possibly need to read more data from ring-0 */ previous_data = substr (io_buffer, (io_buffer_used + 1), (io_buffer_read - io_buffer_used)); io_buffer_used = io_buffer_read; /* force to read some more data */ end; else do; /* data is definitely improperly formatted */ code = error_table_$improper_data_format; go to RETURN_FROM_READ_RECORD; end; end; if io_buffer_used = io_buffer_read then /* have exhausted this buffer ... */ if io_buffer_ptr ^= addr (io_buffer_space) then do; free channel_info.held_input_ptr -> held_input in (system_area); channel_info.held_input_ptr = null (); end; /* ... so get rid of it so we can read some more */ end; if io_buffer_used < io_buffer_read then do; /* some data left over: save it */ held_input_n_elements_allocated = io_buffer_read - io_buffer_used; allocate held_input in (system_area) set (held_input_ptr); held_input.n_elements_used = held_input.n_elements_allocated; held_input.data = substr (io_buffer, (io_buffer_used + 1), (io_buffer_read - io_buffer_used)); if io_buffer_ptr ^= addr (io_buffer_space) then free channel_info.held_input_ptr -> held_input; channel_info.held_input_ptr = held_input_ptr; end; /* Check for end of file: An EOF record is a zero length record. If an EOF record is found, return error_table_$eof_record, otherwise, convert the data in the record to ASCII */ if (cv_string_buffer_used_lth = 0) then do; code = error_table_$eof_record; go to RETURN_FROM_READ_RECORD; end; else do; /* data seems OK: convert it */ terminal_io_record.n_elements = min (terminal_io_record_n_elements, cv_string_buffer_used_lth); if cv_string_buffer_used_lth > 0 then call mvt_ (addr (cv_string_buffer_used), addr (terminal_io_record_data_chars), (terminal_io_record.n_elements), had.translations.input); if cv_string_buffer_used_lth > terminal_io_record_n_elements then code = error_table_$long_record; end; /* ... return as much as will fit */ /* Control reaches here iff the record is read/converted successfully: complete the terminal_io_record structure */ terminal_io_record.version = terminal_io_record_version_1; if (channel_info.device_type = HASP_CONSOLE) then terminal_io_record.device_type = TELEPRINTER_DEVICE; else if (channel_info.device_type = HASP_READER) then terminal_io_record.device_type = READER_DEVICE; terminal_io_record.slew_type = SLEW_BY_COUNT; /* for console/reader, this is fixed */ terminal_io_record.slew_count = 1; string (terminal_io_record.flags) = ""b; terminal_io_record.element_size = 9; P_record_lth = terminal_io_record_header_lth + terminal_io_record.n_elements; /* Cleanup */ RETURN_FROM_READ_RECORD: if cv_string_buffer_ptr ^= null () then if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then free cv_string_buffer in (system_area); P_code = code; return; %page; /* Write a record: write a single record to the device. This record represents part or all of a single line and should be the output of the prt_conv_ module using the remote_conv_ conversion routine */ hasp_workstation_write_record: entry (P_iocb_ptr, P_record_ptr, P_record_lth, P_code); timeout = -1; goto WRITE_JOIN; hasp_workstation_write_record_timed: /* for write_record_timout control order */ entry (P_iocb_ptr, P_record_ptr, P_record_lth, P_code, P_timeout, P_chars_sent); timeout = P_timeout; if timeout < 0 then timeout = 0; /* Make sure that timeout = -1 means non-timeout call */ WRITE_JOIN: if timeout >= 0 then stop_time = clock () + timeout; iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; code = 0; if channel_info.device_type = HASP_READER then do;/* can't write the card reader */ P_code = error_table_$invalid_write; return; end; system_area_ptr = get_system_free_area_ (); io_buffer_ptr = null (); /* for cleanup handler */ on condition (cleanup) begin; /* free any temporary buffers */ if io_buffer_ptr ^= null () then if io_buffer_ptr ^= addr (io_buffer_space) then free io_buffer in (system_area); end; /* Validate input: insure that the caller has supplied a complete terminal I/O record; insure that the terminal input record contains character as opposed to binary data */ terminal_io_record_ptr = P_record_ptr; if terminal_io_record.version ^= terminal_io_record_version_1 then do; P_code = error_table_$unimplemented_version; return; end; if mod (P_record_lth, 4) = 0 then /* X+4-mod(X,4) fails when X is already a multiple of 4 */ if (4 * currentsize (terminal_io_record)) = P_record_lth then ; /* user supplied length agrees with computed length */ else do; P_code = error_table_$improper_data_format; return; end; else /* supplied length not multiple of 4: must round it up */ if (4 * currentsize (terminal_io_record)) ^= (P_record_lth + 4 - mod (P_record_lth, 4)) then do; P_code = error_table_$improper_data_format; return; end; if terminal_io_record.binary | terminal_io_record.preslew | (terminal_io_record.element_size ^= 9) then do; P_code = error_table_$improper_data_format; return; end; /* Convert the data to the character code used by the remote system (in place) */ call mvt_ (addr (terminal_io_record_data_chars), addr (terminal_io_record_data_chars), (terminal_io_record.n_elements), had.translations.output); /* Compute size of I/O buffer required assuming no compression can be performed on the record. If this size is not too large, the automatic buffer will be used; otherwise, a buffer will be allocated */ io_buffer_lth = max (terminal_io_record.n_elements, 1) + divide ((terminal_io_record.n_elements + HASP_MAX_NOT_COMPRESSED_TEXT_LTH - 1), HASP_MAX_NOT_COMPRESSED_TEXT_LTH, 17, 0) + /* SCBs for the text */ 2; /* SRCB and end-of-record SCB */ if (channel_info.device_type = HASP_PRINTER) then do; /* line printer: must count extra records for SRCBs and forms change (if necessary) */ if (had.current_forms ^= channel_info.forms) then io_buffer_lth = io_buffer_lth + 3 + max (length (had.current_forms), 1); /* SRCB, SCB, forms-name, EOR-SCB */ if (terminal_io_record.slew_type = SLEW_BY_COUNT) then n_extra_records = divide (terminal_io_record.slew_count, HASP_MAX_SLEW_COUNT, 17, 0); else if (terminal_io_record.slew_type = SLEW_TO_TOP_OF_PAGE) then n_extra_records = had.top_of_page_sequence_ptr -> slew_sequence.n_ops - 1; else if (terminal_io_record.slew_type = SLEW_TO_INSIDE_PAGE) then n_extra_records = had.inside_page_sequence_ptr -> slew_sequence.n_ops - 1; else if (terminal_io_record.slew_type = SLEW_TO_OUTSIDE_PAGE) then n_extra_records = had.outside_page_sequence_ptr -> slew_sequence.n_ops - 1; else if (terminal_io_record.slew_type = SLEW_TO_CHANNEL) then n_extra_records = 0; /* can be specified in the first SRCB */ io_buffer_lth = io_buffer_lth + 4 * n_extra_records; /* SRCB, SCB, blank, EOR-SCB */ end; if io_buffer_lth <= length (io_buffer_space) then do; /* space needed available in automatic */ io_buffer_ptr = addr (io_buffer_space); io_buffer_lth = length (io_buffer_space); end; else do; /* space required larger than automatic buffer */ on condition (area) begin; code = error_table_$noalloc; /* just TOO much */ go to RETURN_FROM_WRITE_RECORD; end; allocate io_buffer in (system_area) set (io_buffer_ptr); end; io_buffer_used = 0; /* nothing in the output yet */ /* Forms processing: for a line printer, issue a HASP forms change record if the forms required for this I/O switch differs from the last forms used on the channel */ if (channel_info.device_type = HASP_PRINTER) then if (had.current_forms ^= channel_info.forms) then do; call add_character_to_io_buffer ((HASP_FORMS_CHANGE_SRCB)); if length (had.current_forms) = 0 then call hasp_util_$compress_text (addr (had.translations.space), 1, (0), addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code); else call hasp_util_$compress_text (addr (had.current_forms), length (had.current_forms), (0), addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code) ; if compress_code ^= 0 then go to WRITE_RECORD_BAD_DATA; call add_character_to_io_buffer ((HASP_EOR_SCB)); end; /* Create the record: construct the SRCB for the record, compress the record (insuring that some data is present in the record), and add the terminating end-of-record SCB */ call generate_record_srcb (); /* does the dirty work */ if terminal_io_record.n_elements = 0 then /* no data: supply some to avoid lossage with RSCS */ call hasp_util_$compress_text (addr (had.translations.space), 1, (0), addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code); else call hasp_util_$compress_text (addr (terminal_io_record.data), (terminal_io_record.n_elements), (0), addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code); if compress_code ^= 0 then do; /* failed. yet above code insured there'd be enough room */ WRITE_RECORD_BAD_DATA: code = error_table_$improper_data_format; go to RETURN_FROM_WRITE_RECORD; end; call add_character_to_io_buffer ((HASP_EOR_SCB)); /* Complete the data block: for the line printer, the slew control operation requested in the data record may not be representable as a single SRCB character. The call to generate_record_srcb above sets local state to indicate if more SRCBs are needed. In this case, empty records are created containing just the SRCB and a blank */ do while (more_srcbs_needed); call generate_next_srcb (); /* create the next SRCB */ call hasp_util_$compress_text (addr (had.translations.space), 1, (0), addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code); if compress_code ^= 0 then go to WRITE_RECORD_BAD_DATA; call add_character_to_io_buffer ((HASP_EOR_SCB)); end; /* Transmit the I/O block and return to the caller */ if timeout = -1 then call write_io_buffer ((0)); else call write_io_buffer (P_chars_sent); if code = 0 then /* if write was successfull ... */ if (channel_info.device_type = HASP_PRINTER) then /* ... forms have changed */ channel_info.forms = had.current_forms; RETURN_FROM_WRITE_RECORD: if io_buffer_ptr ^= null () then if io_buffer_ptr ^= addr (io_buffer_space) then free io_buffer in (system_area); P_code = code; return; %page; /* Perform control operations on an I/O switch connected to a HASP workstation */ hasp_workstation_control_before_open: entry (P_iocb_ptr, P_order, P_info_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; order = P_order; info_ptr = P_info_ptr; code = 0; if (order = "set_event" | order = "set_event_channel") then call hasp_workstation_control (P_iocb_ptr, P_order, P_info_ptr, P_code); else do; call hcs_$tty_order (channel_info.devx, order, info_ptr, state, code); P_code = code; end; return; hasp_workstation_control: entry (P_iocb_ptr, P_order, P_info_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; order = P_order; info_ptr = P_info_ptr; code = 0; if (order = "io_call") then do; /* io_call command interface: translate the supplied info into an ordinary control order */ if info_ptr = null () then do; /* need the order name */ P_code = error_table_$undefined_order_request; return; end; order = info_ptr -> io_call_info.order_name; info_ptr = null (); end; if (order = "runout") then do; /* Wait for all output to leave the FNP: for HASP channels, we only wait for the output to leave the TTY channel and enter the multiplexer */ write_status.output_pending = "1"b; /* need do until */ do while (write_status.output_pending); call hcs_$tty_order (channel_info.devx, "write_status", addr (write_status), state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then go to RETURN_FROM_CONTROL; if write_status.output_pending then do; event_wait_channel.n_channels = 1; event_wait_channel.channel_id (1) = channel_info.event_channel; call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code); if code ^= 0 then go to RETURN_FROM_CONTROL; end; end; end; else if (order = "end_write_mode") then do; /* End a write operation: waits for all output to enter the multiplexer, then for a line printer or card punch, writes an EOF record, and, for a line printer, reset the forms to the default forms given in the attach description */ if (channel_info.device_type = HASP_READER) then do; code = error_table_$invalid_write; go to RETURN_FROM_CONTROL; end; if (channel_info.device_type = HASP_CONSOLE) then ; /* don't write an EOF record */ else do; io_buffer_ptr = addr (TEMPLATE_HASP_EOF_RECORD); io_buffer_lth, io_buffer_used = length (TEMPLATE_HASP_EOF_RECORD); call write_io_buffer ((0)); /* send it */ if code ^= 0 then go to RETURN_FROM_CONTROL; if channel_info.device_type = HASP_PRINTER then /* reset the switch to its default */ had.current_forms = had.default_forms; channel_info.forms = ""; /* reset to default forms */ end; call hasp_workstation_control (iocb_ptr, "runout", (null ()), code); end; else if (order = "set_forms") then do; /* Change the forms used for output on this switch until the next "end_write_mode" control order */ if (info_ptr = null ()) then code = error_table_$null_info_ptr; else do; sti_ptr = info_ptr; if set_forms_info.version ^= SET_FORMS_INFO_VERSION_1 then code = error_table_$unimplemented_version; else do; had.current_forms = rtrim (set_forms_info.forms); /* strip trailing whitespace */ had.current_forms = translate (had.current_forms, UPPERCASE, LOWERCASE); had.current_forms = translate (had.current_forms, had.translations.output); end; /* convert to uppercase and proper character set */ end; end; else if (order = "read_status") then do; /* Indicate if input is available: check local buffers before checking with ring-0 */ if (info_ptr = null ()) then code = error_table_$null_info_ptr; else do; read_status_info.event_channel = channel_info.event_channel; if (channel_info.held_input_ptr ^= null ()) then read_status_info.input_available = "1"b; /* got some here */ else do; call hcs_$tty_order (channel_info.devx, "read_status", info_ptr, state, code); if state ^= 5 then code = error_table_$io_no_permission; end; end; end; else if (order = "resetread") then do; /* Flush pending input: throw out any input being held locally and then perform an appropriate "abort" control on the channel */ if channel_info.held_input_ptr ^= null () then free channel_info.held_input_ptr -> held_input in (system_area); channel_info.held_input_ptr = null (); call hcs_$tty_abort (channel_info.devx, (1), state, code); if state ^= 5 then code = error_table_$io_no_permission; end; else if (order = "resetwrite") then do; /* Flush pending output: perform the appropriate "abort" control order on the channel */ call hcs_$tty_abort (channel_info.devx, (2), state, code); if state ^= 5 then code = error_table_$io_no_permission; end; else if (order = "hangup_proc") then do; /* Caller supplies a procedure to be invoked when the channel used by this switch is hungup */ if (info_ptr = null ()) then code = error_table_$null_info_ptr; else do; call ipc_$decl_ev_call_chn (channel_info.attach_event_channel, hangup_proc_info.procedure, hangup_proc_info.data_ptr, hangup_proc_info.priority, code); if code = 0 then channel_info.attach_channel_is_call = "1"b; end; end; else if (order = "get_channel_info") then do; /* Return the name and MCS device index of the channel attached via this switch */ if (info_ptr = null ()) then code = error_table_$null_info_ptr; else if get_channel_info.version ^= tty_get_channel_info_version then code = error_table_$unimplemented_version; else do; get_channel_info.devx = channel_info.devx; get_channel_info.channel_name = channel_info.name; end; end; else if (order = "select_device") then ; /* select a specific output device: ignored */ else if (order = "reset") then ; /* reset the switch to a well-known state: ignored */ else if (order = "set_event" | order = "set_event_channel") then do; if channel_info.event_channel_assigned then call hcs_$delete_channel (channel_info.event_channel, code); else if channel_info.event_channel_created then call ipc_$delete_ev_chn (channel_info.event_channel, code); channel_info.event_channel = info_ptr -> event_channel; call hcs_$tty_event (channel_info.devx, channel_info.event_channel, state, code); if code ^= 0 then goto RETURN_FROM_CONTROL; channel_info.event_channel_assigned = "0"b; channel_info.event_channel_created = "0"b; end; else if (order = "set_term_type") then do; sttip = info_ptr; if set_term_type_info.version ^= stti_version_1 then do; code = error_table_$unimplemented_version; goto RETURN_FROM_CONTROL; end; ttd.version = ttd_version_3; call ttt_info_$terminal_data (set_term_type_info.name, -1, 0, addr (ttd), code); if code ^= 0 then goto RETURN_FROM_CONTROL; if (ttd.tables.input_tr_ptr ^= null ()) then /* If no translation table, don't change */ call set_translation (had.translations.input, addr (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value), dimension (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value, 1)); if (ttd.tables.output_tr_ptr ^= null ()) then do; call set_translation (had.translations.output, addr (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value), dimension (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value, 1)); had.translations.space = translate (ASCII_SPACE, had.translations.output); end; /* This should not affect operation of channel. Its only */ /* effect should be to set up the tcb with terminal type so */ /* stty can see it. */ call hcs_$tty_order (channel_info.devx, "set_terminal_data", addr (ttd), state, code); if state ^= 5 then code = error_table_$io_no_permission; end; else if (order = "set_line_type") then do; if (info_ptr = null ()) then code = error_table_$null_info_ptr; else if line_type ^= LINE_HASP_OPR | channel_info.device_type ^= HASP_CONSOLE then code = error_table_$incorrect_device_type; else code = 0; /* basically a nop */ end; else if (order = "read_record_timeout") then do; timeout_info_ptr = info_ptr; input_timeout_info.characters_read = 0; call hasp_workstation_read_record_timed (P_iocb_ptr, input_timeout_info.buffer_pointer, input_timeout_info.buffer_length, input_timeout_info.characters_read, code, input_timeout_info.timeout); end; else if (order = "write_record_timeout") then do; timeout_info_ptr = info_ptr; call hasp_workstation_write_record_timed (P_iocb_ptr, output_timeout_info.buffer_pointer, output_timeout_info.buffer_length, code, output_timeout_info.timeout, output_timeout_info.characters_written); end; /* wouldn't do any good to send password mask */ else if (order = "assign_to_user_process") then do; if info_ptr = null () then code = error_table_$null_info_ptr; else do; call hcs_$tty_detach_new_proc (channel_info.devx, pid, state, code); if state ^= 5 then code = error_table_$io_no_permission; end; end; else if (order = "printer_off") then code = 0; else if (order = "printer_on") then code = 0; else if (order = "state") then do; call hcs_$tty_state (channel_info.devx, temp_state, (0)); info_ptr -> based_state = temp_state; code = 0; end; else if (order = "detach_user_process") then do; call hcs_$tty_detach (channel_info.devx, detachflag, temp_state, code); if temp_state ^= 5 then code = error_table_$io_no_permission; end; else do; /* Unrecognized control order: pass it on to MCS */ call hcs_$tty_order (channel_info.devx, order, info_ptr, state, code); if order ^= "listen" then if state ^= 5 then code = error_table_$io_no_permission; end; RETURN_FROM_CONTROL: P_code = code; return; %page; /* Change modes: modes operation a noop */ hasp_workstation_modes: entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code); P_old_modes = ""; /* no modes are reflected to caller */ P_code = 0; return; %page; /* Remove an I/O switch which might be attached to the channel: if this switch is the only one attached to the channel, the channel itself is detached */ cleanup_attachment: procedure (P_code); dcl P_code fixed binary (35) parameter; /* a parameter to allow callers to ignore it */ P_code = 0; if had_ptr ^= null () then do; /* there is an I/O switch */ if had.channel_info_ptr ^= null () then do; /* there is knowledge of the channel */ channel_info_ptr = had.channel_info_ptr; if (had.chain.previous = null ()) then channel_info.hads.first = had.chain.next; else had.chain.previous -> had.chain.next = had.chain.next; if (had.chain.next = null ()) then channel_info.hads.last = had.chain.previous; else had.chain.next -> had.chain.previous = had.chain.previous; if (channel_info.hads.first = null ()) then call release_channel (); /* last switch connected to the channel */ end; if had.top_of_page_sequence_ptr ^= null () then free had.top_of_page_sequence_ptr -> slew_sequence in (system_area); if had.inside_page_sequence_ptr ^= null () then free had.inside_page_sequence_ptr -> slew_sequence in (system_area); if had.outside_page_sequence_ptr ^= null () then free had.outside_page_sequence_ptr -> slew_sequence in (system_area); free had in (system_area); had_ptr = null (); /* just to be sure */ end; return; /* Internal to cleanup_attachment: release the knowledge associated with a TTY channel */ release_channel: procedure (); if channel_info.devx ^= -1 then call hcs_$tty_detach (channel_info.devx, (0), (0), P_code); if channel_info.event_channel ^= -1 then if channel_info.event_channel_assigned then call hcs_$delete_channel (channel_info.event_channel, (0)); else if channel_info.event_channel_created then call ipc_$delete_ev_chn (channel_info.event_channel, (0)); if channel_info.attached then do; /* give the channel back to the answering service */ if channel_info.attach_channel_is_call then call ipc_$decl_ev_wait_chn (channel_info.attach_event_channel, (0)); if ^channel_info.suppress_dial_manager then do; dma.version = dial_manager_arg_version_2; dma.dial_channel = channel_info.attach_event_channel; dma.channel_name = channel_info.name; dma.dial_qualifier, dma.dial_out_destination, dma.reservation_string = ""; call dial_manager_$release_channel (addr (dma), (0)); end; channel_info.attached = "0"b; /* assume success */ end; if channel_info.attach_event_channel ^= -1 then call ipc_$delete_ev_chn (channel_info.attach_event_channel, (0)); if (channel_info.chain.previous = null ()) then first_channel_info_ptr = channel_info.chain.next; else channel_info.chain.previous -> channel_info.chain.next = channel_info.chain.next; if (channel_info.chain.next = null ()) then last_channel_info_ptr = channel_info.chain.previous; else channel_info.chain.next -> channel_info.chain.previous = channel_info.chain.previous; free channel_info in (system_area); channel_info_ptr = null (); return; end release_channel; end cleanup_attachment; %page; /* Wrapper to protect against errors while IPS interrupts are masked */ any_other_handler: procedure () options (non_quick); dcl 1 fatal_error_info aligned, 2 version fixed bin, 2 status_code fixed bin (35); if get_group_id_ () = "Initializer.SysDaemon.z" then do; if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask); ips_mask = ""b; call continue_to_signal_ ((0)); /* hope to get an asdump */ end; else do; fatal_error_info.version = 0; fatal_error_info.status_code = error_table_$unable_to_do_io; call terminate_process_ ("fatal_error", addr (fatal_error_info)); end; return; end any_other_handler; /* Abort a call to the attach entry: print an error message if requested */ abort_attachment: procedure () options (variable, non_quick); dcl the_code fixed binary (35) based (the_code_ptr); dcl the_code_ptr pointer; dcl caller_message character (256); call cu_$arg_ptr (1, the_code_ptr, (0), (0)); if loud_sw then do; /* an error message is requested */ call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, (0), "1"b, "0"b); call com_err_ (the_code, NAME, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message); end; call cleanup_attachment ((0)); /* get rid of anything that was accomplished */ if the_code = 0 then code = error_table_$action_not_performed; else code = the_code; /* save the error code */ go to RETURN_FROM_ATTACH; end abort_attachment; %page; /* Fetch the next argument from the attach options and validate that it is a non-null character string */ get_string_argument: procedure () returns (character (*)); dcl option_name character (32); option_name = argument; /* about to move on to the next one */ if (argument_idx = hbound (P_attach_options, 1)) then call abort_attachment (error_table_$noarg, "Character string following ""^a"".", option_name); argument_idx = argument_idx + 1; argument_ptr = addcharno (addr (P_attach_options (argument_idx)), 4); argument_lth = length (P_attach_options (argument_idx)); if (argument = "") then call abort_attachment (0, "Character string following ""^a"" must be non-null.", option_name); return (argument); end get_string_argument; /* Fetch the next argument from the attach options and verify that it is a number */ get_numeric_argument: procedure () returns (fixed binary (35)); dcl option_name character (32); dcl the_value fixed binary (35); option_name = argument; /* about to move on to the next one */ if (argument_idx = hbound (P_attach_options, 1)) then call abort_attachment (error_table_$noarg, "Number following ""^a"".", option_name); argument_idx = argument_idx + 1; argument_ptr = addcharno (addr (P_attach_options (argument_idx)), 4); argument_lth = length (P_attach_options (argument_idx)); the_value = cv_dec_check_ (argument, code); if code ^= 0 then call abort_attachment (error_table_$bad_conversion, """^a"" must be followed by a number; not ""^a"".", option_name, argument); return (the_value); end get_numeric_argument; %page; init_read: procedure; iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; had_ptr = iocb_ptr -> iocb.attach_data_ptr; channel_info_ptr = had.channel_info_ptr; return; end init_read; /* Set input/output translation to the given string: If the string supplied is less than 512 characters, the out of range characters are translated to NULs */ set_translation: procedure (P_translate_table, P_translate_string_ptr, P_translate_string_lth); dcl P_translate_table character (512) aligned parameter; /* translate table */ dcl P_translate_string_ptr pointer parameter; /* -> translation string */ dcl P_translate_string_lth fixed binary (21) parameter; /* length of translation string */ dcl translate_string character (P_translate_string_lth) based (P_translate_string_ptr); P_translate_table = translate_string; if length (translate_string) < length (P_translate_table) then substr (P_translate_table, (length (translate_string) + 1)) = copy (NUL, (length (P_translate_table) - length (translate_string))); return; end set_translation; %page; /* Parse a slew control sequence specification: the specification is of the form Tn:Tn:Tn:Tn:... where "n" is the numeric value and T represents the type of operation to perform. T may be either "c" for skip to channel "n", or "s" for space "n" lines */ parse_slew_sequence: procedure (P_slew_sequence_ptr); dcl P_slew_sequence_ptr pointer; /* set -> slew_sequence constructed */ dcl (option_name, operation) character (32); dcl (start, next_colon) fixed binary (21); dcl the_number fixed binary (35); dcl next_op fixed binary; option_name = argument; /* remember it for error messages */ character_value = get_string_argument (); /* insure specification is present */ start = 1; slew_sequence_n_ops = 0; /* haven't found any yet */ /* Count and verify syntax of each operation */ do while (start <= length (argument)); next_colon = index (substr (argument, start), ":"); if next_colon = 0 then /* rest of argument is this sequence */ next_colon = length (argument) - start + 2; operation = ltrim (rtrim (substr (argument, start, (next_colon - 1)))); if (operation = "") then call abort_attachment (0, "All slewing operations must be non-null: ""^a"" for ""^a"".", argument, option_name); if (substr (operation, 1, 1) ^= "c") & (substr (operation, 1, 1) ^= "s") then call abort_attachment (0, "Invalid slewing operation ""^a"" specified in ""^a"" for ""^a"".", substr (operation, 1, 1), argument, option_name); the_number = cv_dec_check_ (substr (operation, 2), code); if code ^= 0 then call abort_attachment (error_table_$bad_conversion, """^a"" in ""^a"" for ""^a"".", substr (operation, 2), argument, option_name); if ((substr (operation, 1, 1) = "c") & ((the_number < 1) | (the_number > 12))) | ((substr (operation, 1, 1) = "s") & ((the_number > 15) | (the_number < 0))) then call abort_attachment (0, "Invalid value for slewing operation ""^a"" in ""^a"" for ""^a"".", operation, argument, option_name); slew_sequence_n_ops = slew_sequence_n_ops + 1; /* it's OK */ start = start + next_colon; end; /* Specification is valid: allocate the structure and fill it in */ on condition (area) call abort_attachment (error_table_$noalloc, "Interpreting ""^a"" for ""^a"".", argument, option_name); allocate slew_sequence in (system_area) set (slew_sequence_ptr); start = 1; next_op = 0; do while (start <= length (argument)); next_colon = index (substr (argument, start), ":"); if next_colon = 0 then /* rest of argument is this sequence */ next_colon = length (argument) - start + 2; operation = ltrim (rtrim (substr (argument, start, (next_colon - 1)))); next_op = next_op + 1; if (substr (operation, 1, 1) = "c") then slew_sequence.ops (next_op).skip_to_channel = "1"b; else slew_sequence.ops (next_op).skip_to_channel = "0"b; the_number = cv_dec_check_ (substr (operation, 2), (0)); slew_sequence.ops (next_op).count_or_channel = the_number; start = start + next_colon; end; P_slew_sequence_ptr = slew_sequence_ptr; /* return results to caller */ return; end parse_slew_sequence; %page; /* Read an I/O buffer: block until some data arrives and perform a single read from ring-0 */ read_io_buffer: procedure (); io_buffer_read = 0; /* need do until here */ do while (io_buffer_read = 0); read_status.input_available = "0"b; /* again, no do until */ if timeout ^= 0 then /* timeout of zero means no blocking */ do while (^read_status.input_available); call hcs_$tty_order (channel_info.devx, "read_status", addr (read_status), state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then return; /* punt! */ if ^read_status.input_available then do;/* need to wait for some input */ event_wait_channel.n_channels = 1; event_wait_channel.channel_id (1) = channel_info.event_channel; if timeout > 0 then call timer_manager_$alarm_wakeup (stop_time, ABSOLUTE_MICROSECONDS, channel_info.event_channel); call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code); if timeout > 0 then call timer_manager_$reset_alarm_wakeup (channel_info.event_channel); if code ^= 0 then return; if timeout > 0 then if clock () > stop_time then read_status.input_available = "1"b; /* Force drop out of loop */ end; end; call hcs_$tty_read (channel_info.devx, addr (io_buffer), (0), io_buffer_lth, io_buffer_read, state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then return; if io_buffer_read = 0 then if timeout >= 0 then do; if (clock () > stop_time) & channel_info.block_on_io then code = error_table_$timeout; return; end; end; return; end read_io_buffer; %page; /* Generate the SRCB for this record: for the console or a punch, the contents of the record's SRCB is fixed; for a line printer, the contents of the SRCB are determined from the slew_control field of the terminal_io_record. For the printer, the type of slewing requested might not be able to be satisfied by one SRCB; if this occurs, state information is saved to allow generation of as many null records with appropriate SRCBs as necessary */ generate_record_srcb: procedure (); more_srcbs_needed = "0"b; /* assume that only one SRCB needed for this slew */ if (channel_info.device_type = HASP_PRINTER) then do; /* Line printer: start interpretation of slew_control */ if (terminal_io_record.slew_type = SLEW_BY_COUNT) then local_slew_count = terminal_io_record.slew_count; else if (terminal_io_record.slew_type = SLEW_TO_CHANNEL) then ; /* given channel stop: only need one SRCB for this type */ else do; /* skip to top of some type of page */ n_last_opcode = 0; /* haven't done anything yet */ if (terminal_io_record.slew_type = SLEW_TO_TOP_OF_PAGE) then slew_sequence_ptr = had.top_of_page_sequence_ptr; else if (terminal_io_record.slew_type = SLEW_TO_INSIDE_PAGE) then slew_sequence_ptr = had.inside_page_sequence_ptr; else if (terminal_io_record.slew_type = SLEW_TO_OUTSIDE_PAGE) then slew_sequence_ptr = had.outside_page_sequence_ptr; end; call generate_next_srcb (); /* actually generate the SRCB */ end; else do; /* The console or a punch: generate a fixed SRCB */ call add_character_to_io_buffer (NUL); srcb_ptr = addcharno (addr (io_buffer), io_buffer_used - 1); if (channel_info.device_type = HASP_CONSOLE) then srcb = HASP_CONSOLE_SRCB; else if (channel_info.device_type = HASP_PUNCH) then srcb = TEMPLATE_HASP_CARD_SRCB; end; return; end generate_record_srcb; %page; /* Generate next SRCB: given the current local state, construct the next SRCB character required to perform the request slewing operation; update the local state for the next call (if any) */ generate_next_srcb: procedure (); call add_character_to_io_buffer (NUL); /* make the SRCB and initialize it to all zeroes */ srcb_ptr = addcharno (addr (io_buffer), io_buffer_used - 1); hasp_printer_srcb.mbo1 = "1"b; /* SRCB now specifies space zero lines */ if (terminal_io_record.slew_type = SLEW_BY_COUNT) then do; hasp_printer_srcb.number = min (local_slew_count, HASP_MAX_SLEW_COUNT); local_slew_count = local_slew_count - hasp_printer_srcb.number; more_srcbs_needed = (local_slew_count > 0); end; else if (terminal_io_record.slew_type = SLEW_TO_CHANNEL) then do; /* skip to specified channel stop */ hasp_printer_srcb.skip_to_channel = "1"b; hasp_printer_srcb.number = terminal_io_record.slew_count; more_srcbs_needed = "0"b; /* only need one SRCB to do the job */ end; else do; /* special slewing requested: interpret attach description */ n_last_opcode = n_last_opcode + 1; hasp_printer_srcb.skip_to_channel = slew_sequence.ops (n_last_opcode).skip_to_channel; hasp_printer_srcb.number = slew_sequence.ops (n_last_opcode).count_or_channel; more_srcbs_needed = (slew_sequence.n_ops > n_last_opcode); end; return; end generate_next_srcb; /* Add the specified character to the I/O buffer for later output */ add_character_to_io_buffer: procedure (P_character); dcl P_character character (1) parameter; if io_buffer_used = length (io_buffer) then /* no room in buffer */ go to WRITE_RECORD_BAD_DATA; io_buffer_used = io_buffer_used + 1; substr (io_buffer, io_buffer_used, 1) = P_character; return; end add_character_to_io_buffer; %page; /* Write an I/O buffer: blocks until the entire buffer has been taken by ring-0 MCS */ write_io_buffer: procedure (transmitted); dcl (transmitted, sent_on_call) fixed binary (21); /* First see if any output from an interrupted timed write_record is sitting in ring 0 and must be flushed. The flushing is done at the last possible moment (now) to lessen the chance of flushing output that was ahead of the interrupted record, but still in ring 0. */ transmitted = 0; if channel_info.output_interrupted then do; call hcs_$tty_abort (channel_info.devx, 2, state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then return; channel_info.output_interrupted = "0"b; end; do while (transmitted < io_buffer_used); call hcs_$tty_write (channel_info.devx, addcharno (addr (io_buffer), transmitted), (0), (io_buffer_used - transmitted), sent_on_call, state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then return; /* punt! */ transmitted = transmitted + sent_on_call; /* got some more through */ if transmitted < io_buffer_used then do; /* not done yet: wait 'till we should try again */ call hcs_$tty_order (channel_info.devx, "write_status", addr (write_status), state, code); if state ^= 5 then code = error_table_$io_no_permission; if code ^= 0 then return; /* punt! */ if write_status.output_pending then do; /* must really and truly wait */ if timeout = 0 /* Zero timeout means never block */ | (timeout > 0 & clock () > stop_time) then do; /* Really timed out */ if transmitted > 0 then channel_info.output_interrupted = "1"b; if channel_info.block_on_io then code = error_table_$timeout; /* non-block code is not interested in timeouts */ return; end; event_wait_channel.n_channels = 1; event_wait_channel.channel_id (1) = channel_info.event_channel; call timer_manager_$alarm_wakeup (1, RELATIVE_SECONDS, event_wait_channel.channel_id (1)); if timeout > 0 then call timer_manager_$alarm_wakeup (stop_time, ABSOLUTE_MICROSECONDS, channel_info.event_channel); call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code); call timer_manager_$reset_alarm_wakeup (channel_info.event_channel); if code ^= 0 then return; /* punt! */ end; end; end; return; /* this return taken only on success */ end write_io_buffer; %page; %include terminal_io_record; %page; %include hasp_device_data; %include hasp_srcb_scb_bytes; %include hasp_set_forms_info; %page; %include iocb; %page; %include iox_modes; %page; %include io_call_info; %page; %include dial_manager_arg; %include event_wait_channel; %include event_wait_info; %page; %include line_types; %page; %include terminal_type_data; %include tty_convert; %include tty_get_channel_info; %page; %include io_timeout_info; %page; %include set_term_type_info; %page; %include timer_manager_constants; end hasp_workstation_;  hasp_ws_sim_driver_.pl1 10/03/89 1012.1rew 10/03/89 0954.2 345483 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* IO Daemon Driver Module - designed to run as a HASP workstation for one of the devices associated with the station. The possible devices are: READER - send jobs to the host as if this pgm is a card reader. PRINTER - receive print files from the host. PUNCH - receive punch files (card decks) from the host. The device to be run by the process is specified in the minor_args with the dev= key as follows: "reader_out" => READER device, "printer_in" => PRINTER device, "punch_in" => PUNCH device. The process can only run one of the possible HASP devices. There must be a separate process for each active device. */ /* format: style4 */ /* Created by J. C. Whitmore, Feb. 1980. */ /* Modified: September 1980 by G. Palter to make auto_queue the default, eliminate ident= minor_args keyword and ident command, and add request_type= minor_args keyword and request_type command */ /* Modified: 30 September 1981 by G. Palter to use proper maximum length for the request type name (24 characters) */ /* Modified: 24 November 1981 by G. Palter to implement the auto_receive parameter */ /* Modified: February 23, 1985 by C. Marker to use version 5 message segments */ /****^ HISTORY COMMENTS: 1) change(87-05-10,Gilcrease), approve(87-05-13,MCR7686), audit(88-02-01,Farley), install(88-02-02,MR12.2-1019): Update to version 4 dprint_msg. 2) change(88-08-19,Brunelle), approve(88-08-19,MCR7911), audit(88-10-21,Wallman), install(88-10-28,MR12.2-1199): Upgraded to version 5 iod tables. 3) change(88-08-25,Farley), approve(88-08-19,MCR7911), audit(88-10-18,Wallman), install(88-10-28,MR12.2-1199): Updated to allow for version 5 dprint_msg. 4) change(89-06-15,Brunelle), approve(89-09-18,MCR8129), audit(89-09-29,Beattie), install(89-10-03,MR12.3-1083): Correct generation of major/minor_args_ptr when using offset into the I/O daemon tables string area. END HISTORY COMMENTS */ hasp_ws_sim_driver_: procedure (); return; /* not an entry */ /* Parameters */ dcl a_argp ptr parameter; dcl a_source fixed bin parameter; /* 1 = master console, 2 = slave */ dcl a_state fixed bin parameter; /* 0 = not quite ready to handle a request */ /* 1 = drivers are ready */ /* 2 = command entered after a quit */ dcl a_stream char (*) parameter; dcl a_banner_type fixed bin parameter; /* type of banner to be written */ /* 1 = heading banner */ /* 2 = tail banner */ /* 3 = error message */ dcl a_data_ptr ptr parameter; /* pointer to output request data or */ /* to char(256) varying string error msg */ dcl a_code fixed bin (35) parameter; /* error code */ /* Other declarations */ dcl age fixed bin; dcl argp ptr; dcl banner_type fixed bin; dcl code fixed bin (35); dcl date_string char (24); dcl device_type char (32); dcl element_size fixed bin; dcl format_code fixed bin; dcl generic_type character (32); dcl ignore fixed bin (35); dcl last fixed bin; dcl local_request_type character (24); dcl iocbp ptr; dcl major_args char (major_args_length) based (major_args_ptr); dcl major_args_ptr ptr; dcl major_args_length fixed bin; dcl major_args_name char (256) varying; dcl minor_args char (minor_args_length) based (minor_args_ptr); dcl minor_args_ptr ptr; dcl minor_args_length fixed bin; dcl minor_args_name char (256) varying; dcl omode char (256); dcl p ptr; dcl p2 ptr; dcl save_code fixed bin (35); dcl source fixed bin; dcl state fixed bin; dcl value fixed bin; dcl value_string character (256) varying; dcl 1 term_info aligned like terminal_info; dcl 1 hangup_info aligned, /* structure used to set hangup_info proc */ 2 entry entry, 2 data_ptr ptr, 2 priority fixed bin; dcl 1 read_info aligned, 2 read_ev_chan fixed bin (71), 2 input_ready bit (1) unal; dcl 1 ev_chan_list aligned based, 2 number fixed bin, 2 channel (12) fixed bin (71); dcl 1 static_receive_data aligned int static like receive_file_data; dcl static_default_request_type character (32) internal static initial (""); /* request type specified in iod_tables */ dcl sys_dir char (168) based; dcl 1 arg_list aligned based (argp), /* parse_command_ structure */ 2 max_tokens fixed bin, /* space allocated, do not change */ 2 n_tokens fixed bin, /* number of tokens from command line (including cmd) */ 2 command char (64) var, /* the first token is the command */ 2 arg (n_tokens - 1) char (64) var; /* the other tokens are args to the command */ dcl add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; dcl continue_to_signal_ entry (fixed bin (35)); dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl iod_info_$generic_type entry (character (*), character (32), fixed binary (35)); dcl initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl iodd_msg_ entry options (variable); dcl iodd_parse_$args entry (char (*) var, char (*)) returns (char (256) var); dcl iodd_hangup_$iodd_hangup_ entry; dcl set_iod_val entry (char (*), char (*)); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl iodd_listen_ entry (ptr); dcl output_request_ entry (char (*), fixed bin, ptr, entry, fixed bin (35)); dcl output_request_$set_single_copy entry (); dcl output_request_$error_during_request entry (char (*)); dcl pool_manager_$init entry (char (*), fixed bin, bit (36) aligned, fixed bin (35)); dcl pool_manager_$clean_pool entry (char (*), fixed bin, fixed bin, fixed bin (35)); dcl receive_file_ entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl timer_manager_$sleep entry (fixed bin (71), bit (2) aligned); dcl space char (1) int static options (constant) init (" "); dcl master fixed bin int static options (constant) init (1); dcl slave fixed bin int static options (constant) init (2); dcl both fixed bin int static options (constant) init (0); /* master and slave for iodd_msg_ */ dcl log fixed bin int static options (constant) init (0); dcl normal fixed bin int static options (constant) init (1); dcl error fixed bin int static options (constant) init (2); dcl punch_rmcc_mode fixed bin int static options (constant) init (3); dcl initial_punch_rate fixed bin int static options (constant) init (500); /* same for the punch */ dcl head_banner fixed bin int static options (constant) init (1); dcl default_request_types (2) character (32) static options (constant) /* default for dprinting received files */ initial ("printer", "punch"); dcl myname char (19) int static init ("hasp_ws_sim_driver_") options (constant); dcl time fixed bin (71) int static init (10); dcl pool_dir char (168) int static init (""); dcl station char (32) int static; dcl 1 static_sw_info aligned int static like sw_info; /* allocate a copy of this structure */ dcl (addr, character, clock, convert, divide, length, ltrim, null, rtrim) builtin; dcl (cleanup, command_level, re_init, no_coord, daemon_new_device, daemon_logout, daemon_slave_logout, conversion) condition; dcl (error_table_$action_not_performed, error_table_$bigarg, error_table_$fatal_error, error_table_$io_no_permission, error_table_$undefined_order_request, error_table_$ionmat, error_table_$not_detached, error_table_$not_closed) fixed binary (35) external; /* */ /* Initialize the driver */ init: entry (a_argp); stat_p = a_argp; /* put the arg into static for easy reference */ station = "Undefined!"; /* clear station name for any messages */ text_strings_ptr = iodd_static.text_strings_ptr; /* get ptr to i/o daemon table text area */ if iodd_static.attach_type ^= ATTACH_TYPE_TTY then do; /* this driver expects a tty channel */ call iodd_msg_ (error, master, error_table_$fatal_error, myname, "The HASP workstation simulator driver requires a line: statement in iod_tables."); return; /* quit now */ end; if iodd_static.assigned_devices > 1 then do; /* remember, we can only use one device per process */ call iodd_msg_ (error, master, error_table_$fatal_error, myname, "The HASP workstation simulator driver only supports one minor device per process."); return; end; iodd_static.dev_io_stream, iodd_static.dev_in_stream = "Undefined_stream!"; /* we don't use these in this proc */ on daemon_logout call drop_device; on daemon_slave_logout go to logout_slave; on daemon_new_device call drop_device; on no_coord call drop_device; on cleanup call detach_device; /* locate major args for this device in the i/o daemon tables text area */ major_args_ptr = add_char_offset_ (addr (text_strings.chars), iodd_static.major_args.first_char - 1); major_args_length = iodd_static.major_args.total_chars; /* see if user wants major args to be found in a segment */ major_args_name = iodd_parse_$args ("indirect=", major_args); if major_args_name ^= "" then do; /* yes, grab that segment */ call initiate_the_file (major_args_name, major_args_ptr, major_args_length, "major_args", code); if code ^= 0 then go to clean_out; end; station = iodd_parse_$args ("station=", major_args); /* station in major must be defined */ if station = "" then do; /* station not defined */ call iodd_msg_ (error, master, error_table_$fatal_error, myname, "No station specified in major args."); go to clean_out; end; static_receive_data.version = receive_file_data_version_1; static_receive_data.flags = "0"b; /* clear the default operating modes */ static_receive_data.testing = iodd_static.test_entry; /* copy the testing bit */ static_receive_data.request_type = "Undefined!"; static_receive_data.device_type = 0; /* illegal value */ term_info.version = terminal_info_version; /* set version number once for all possible calls */ term_info.baud_rate = 0; /* initialize to no-op just in case */ p = iodd_static.driver_ptr; /* this was set by iodd_ */ p -> driver_status.dev_out_iocbp = null (); p -> driver_status.dev_ctl_ptr = null (); p -> driver_status.bit_rate_est = 0; /* no output rate defined yet */ p -> driver_status.defer_time_limit = 0; /* make operator specify */ p -> driver_status.dev_out_stream = "null_stream"; /* locate minor args for this minor device in the i/o daemon tables text area */ minor_args_ptr = add_char_offset_ (addr (text_strings.chars), p -> driver_status.minor_args.first_char -1); minor_args_length = p -> driver_status.minor_args.total_chars; /* see if user wants minor args to be found in a segment */ minor_args_name = iodd_parse_$args ("indirect=", minor_args); if minor_args_name ^= "" then do; /* yes, grab that segment */ call initiate_the_file (minor_args_name, minor_args_ptr, minor_args_length, "minor_args", code); if code ^= 0 then go to clean_out; end; device_type = iodd_parse_$args ("dev=", minor_args); /* copy for easy reference */ if device_type = "reader_out" then do; p -> driver_status.attached = "1"b; /* we will get requests from coord for this one */ call iodd_msg_ (normal, both, 0, "", "^/Initializing reader output device: ^a", p -> driver_status.device_id); p -> driver_status.generic_type = "punch"; /* we expect user dpunch functions for this one */ call minor_attach (device_type); p -> driver_status.elem_size = 9; /* in this driver, this is just a place holder */ p -> driver_status.message_type = 2; /* type of dprint msg expected */ p -> driver_status.ready = "1"b; /* mark as ready to save operator cmd */ call iox_$control (p -> driver_status.dev_out_iocbp, "terminal_info", addr (term_info), code); if code = 0 then p -> driver_status.bit_rate_est = term_info.baud_rate; else p -> driver_status.bit_rate_est = initial_punch_rate; if p -> driver_status.rqti_ptr ^= null then call iodd_msg_ (normal, master, 0, myname, "This driver cannot decode an rqti seg."); end; else if device_type = "printer_in" | device_type = "punch_in" then do; p -> driver_status.attached = "0"b; /* it is never attached as far as coord knows */ call iodd_msg_ (normal, both, 0, "", "^/Initializing ^[printer^;punch^] input device: ^a", (device_type = "printer_in"), p -> driver_status.device_id); p -> driver_status.generic_type = device_type; call minor_attach (device_type); call iox_$control (p -> driver_status.dev_in_iocbp, "read_status", addr (read_info), code); if code ^= 0 then go to clean_out; sw_info_p = addr (static_sw_info); /* init the local switch info for receive_file_ */ sw_info.version = sw_info_version_1; sw_info.iocbp (1) = iodd_static.master_in; sw_info.ev_chan (1) = iodd_static.chan_list_ptr -> ev_chan_list.channel (1); last = 2; /* default to 2 channels: master & device */ if iodd_static.slave.active then do; /* 3 channels if there is a slave */ sw_info.iocbp (last) = iodd_static.slave_in; /* put the salve after the master */ sw_info.ev_chan (last) = iodd_static.slave_ev_chan; /* for lower priority */ last = last + 1; /* bump index of where the last iocbp will go */ end; sw_info.iocbp (last) = p -> driver_status.dev_in_iocbp; /* put the device in the last place */ sw_info.ev_chan (last) = read_info.read_ev_chan; sw_info.wait_list.n_channels = last; /* set the list count to the index */ sw_info.n_iocb_ptrs = last; /* also here */ value_string = iodd_parse_$args ("auto_queue=", minor_args); if (value_string = "") | (value_string = "yes") then /* defaults to auto_queue if not given */ static_receive_data.no_ident, static_receive_data.auto_queue = "1"b; else if (value_string = "no") then static_receive_data.no_ident, static_receive_data.auto_queue = "0"b; else do; /* bad value for the keyword */ call iodd_msg_ (normal, master, 0, myname, "Invalid ""auto_queue="" argument ""^a"" for minor device ^a.", value_string, p -> driver_status.device_id); go to clean_out; end; if device_type = "printer_in" then /* set device_type before checking for request types */ static_receive_data.device_type = printer_input_device; else static_receive_data.device_type = punch_input_device; value_string = iodd_parse_$args ("request_type=", minor_args); if (value_string = "") then /* not specified: try rqt keyword */ value_string = iodd_parse_$args ("rqt=", minor_args); if (value_string = "") then /* use default request type */ static_default_request_type, static_receive_data.request_type = default_request_types (static_receive_data.device_type); else do; /* request type was specified */ if length (value_string) > length (local_request_type) then do; call iodd_msg_ (normal, master, error_table_$bigarg, myname, "For minor device ^a: request type name must be less than ^d characters long; not ""^a"".", p -> driver_status.device_id, (length (local_request_type) + 1), value_string); go to clean_out; end; local_request_type = value_string; call iod_info_$generic_type (local_request_type, generic_type, code); if code ^= 0 then do; call iodd_msg_ (normal, master, code, myname, """^a"" for minor device ^a.", local_request_type, p -> driver_status.device_id); go to clean_out; end; if ((static_receive_data.device_type = printer_input_device) & (generic_type ^= "printer")) | ((static_receive_data.device_type = punch_input_device) & (generic_type ^= "punch")) then do; /* wrong type of request type for this driver */ call iodd_msg_ (normal, master, 0, myname, "For minor device ^a: request type ""^a"" must be of generic type ^[printer^;punch^]; not ""^a"".", p -> driver_status.device_id, local_request_type, static_receive_data.device_type, generic_type); go to clean_out; end; static_default_request_type, static_receive_data.request_type = local_request_type; end; if iodd_static.test_entry then /* use a dummy pool root under pool_dir for test */ pool_dir = rtrim (iodd_static.sys_dir_ptr -> sys_dir) || ">card_pool"; /* the test pool root */ else pool_dir = "System_Card_Pool"; /* otherwise use the one coded in */ call pool_manager_$init (pool_dir, 10, "1000"b, code); /* use 10 pages of quota initially */ /* and set s *.*.* on initial acl of access class pool */ if code ^= 0 then do; /* oops! */ call iodd_msg_ (normal, master, code, myname, "Unable to initialize card pool."); go to clean_out; end; end; else do; /* someone slipped in a zinger */ call iodd_msg_ (normal, master, 0, myname, "Invalid ""dev="" arg ""^a"" for minor device ^a.", device_type, p -> driver_status.device_id); go to clean_out; end; call set_iod_val ("station_id", rtrim (station)); iodd_static.admin_ec_name = rtrim (station) || "_admin.ec"; iodd_static.slave_hold = "1"b; /* we override the rqti on auto_go */ call date_time_ (clock (), date_string); /* get set for ready message */ call iodd_msg_ (normal, both, 0, "", "^/^a driver on channel ^a ready at ^16a^/", iodd_static.major_device, iodd_static.attach_name, date_string); if (device_type = "printer_in") | (device_type = "punch_in") then do; /* check for auto_receive */ value_string = iodd_parse_$args ("auto_receive=", minor_args); if (value_string = "yes") then do; call iodd_msg_ (normal, source, 0, "", "Waiting for file input."); on command_level goto abort_auto_receive; /* grab control after record quota overflow */ call receive_file_ (pool_dir, addr (static_sw_info), station, addr (static_receive_data), code); if code ^= 0 then call iodd_msg_ (normal, source, myname, code, "From receive_file_ "); abort_auto_receive: end; /* and go to command level afterwards */ else if (value_string = "no") then ; /* nothing special need be done here */ else do; call iodd_msg_ (normal, master, 0, myname, "Invalid ""auto_receive="" value ""^a"" for minor device ^a.", value_string, p -> driver_status.device_id); go to clean_out; end; end; else do; /* don't accept auto_receive for readers */ if iodd_parse_$args ("auto_receive=", minor_args) ^= "" then do; call iodd_msg_ (normal, master, 0, myname, "auto_receive parameter may not be specified for the reader_in minor device ^a.", p -> driver_status.device_id); go to clean_out; end; end; call iodd_listen_ (stat_p); clean_out: /* This is only for error recovery during initialization. The listener will never return here. */ call drop_device; return; logout_slave: /* logout the slave device but not the process */ iodd_static.re_init_in_progress = "1"b; /* we do this by re-initializing the driver */ call date_time_ (clock (), date_string); /* get set for message */ iodd_static.slave.log_msg = "1"b; /* send to log and slave */ call iodd_msg_ (log, both, 0, "", "Logout for station: ^a at ^a", station, date_string); call iox_$control (iodd_static.slave_out, "runout", null, code); call iox_$control (iodd_static.slave_out, "end_write_mode", null, code); call drop_device; call iodd_msg_ (normal, master, 0, "", "Driver starting re-initialization."); go to iodd_static.re_init_label; /* this will do everything */ %page; /* Issue a hangup to the device before detaching */ drop_device: procedure (); dcl send_hangup bit (1); dcl p ptr; send_hangup = "1"b; /* tell close_and_detach proc to send hangup */ go to device_common; detach_device: entry (); send_hangup = "0"b; /* tell close_and_detach proc to not send hangup */ device_common: p = iodd_static.driver_ptr; call close_and_detach (p -> driver_status.dev_out_iocbp, send_hangup); call continue_to_signal_ ((0)); /* in case this is called from a handler */ return; end drop_device; %page; /* This entry is called by iodd_listen_ when a request has been received from the coordinator for the remote device. Here we just check to be sure that we can understand the request format and the requested punch data format. Then the request is passed on to output_request_ which actually handles processing of the request */ request: entry (); p = iodd_static.driver_ptr; /* find the current driver */ p2 = addr (p -> driver_status.descriptor); /* find the request descriptor */ dmp = addr (p -> driver_status.message); /* get ptr to message */ if dmp -> queue_msg_hdr.hdr_version ^= queue_msg_hdr_version_1 then do; /* trouble */ call iodd_msg_ (log, both, 0, "", "Invalid message header. Cannot read request ^d.^d.", p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q); p2 -> request_descriptor.keep_in_queue = "1"b; /* save for conversion later */ go to be_nice; end; if dmp -> queue_msg_hdr.message_type ^= p -> driver_status.message_type then do; call iodd_msg_ (log, both, 0, "", /* log the error */ "Incorrect message type.^/Request ^d.^d for ^a (segment ^a) not processed.", p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q, p2 -> request_descriptor.mseg_message_info_copy.sender_id, dmp -> queue_msg_hdr.ename); p2 -> request_descriptor.cancelled = "1"b; /* we don't want this one again */ be_nice: p2 -> request_descriptor.dont_delete = "1"b; /* save the user's data */ p2 -> request_descriptor.finished = "1"b; /* mark it done */ return; /* it wasn't for us after all */ end; if dprint_msg.version ^= dprint_msg_version_5 /* Current version */ & dprint_msg.version ^= dprint_msg_version_4 /* Previous version */ & dprint_msg.version ^= dprint_msg_version_3 /* Previous version */ then do; /* other trouble? */ call iodd_msg_ (log, both, 0, "", "Wrong message version found.^/Request ^d.^d for ^a (segment ^a) not processed", p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q, p2 -> request_descriptor.mseg_message_info_copy.sender_id, dmp -> queue_msg_hdr.ename); p2 -> request_descriptor.keep_in_queue = "1"b; go to be_nice; end; if dprint_msg.version < dprint_msg_version_4 then /* Disallow line numbers before version 4 */ dprint_msg.control.line_nbrs = "0"b; format_code = dprint_msg.output_module; /* get the user defined format */ if format_code = punch_rmcc_mode then do; /* for character output */ element_size = 9; /* for output_request_ */ end; else do; /* be sure it is defined */ call iodd_msg_ (log, both, 0, "", "Illegal output format in user request.^/Request ^d.^d for ^a (segment ^a) not processed", p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q, p2 -> request_descriptor.mseg_message_info_copy.sender_id, dmp -> queue_msg_hdr.ename); p2 -> request_descriptor.cancelled = "1"b; /* we don't want this one again */ go to be_nice; end; iodd_static.quit_during_request = "0"b; /* start clean */ %page; on cleanup begin; call iox_$control (p -> driver_status.dev_out_iocbp, "end_write_mode", null, (0)); end; call output_request_ ((p -> driver_status.dev_out_stream), element_size, stat_p, print_banner, code); if code ^= 0 then do; iodd_static.slave_hold = "1"b; /* on errors go to command level for guidance */ if code = error_table_$io_no_permission then do; /* in case of hangup... */ call iodd_msg_ (error, master, code, myname, "Device in inconsistent state or hungup. Must re-initialize."); signal re_init; end; end; call iox_$control (p -> driver_status.dev_out_iocbp, "end_write_mode", null, code); if code = 0 then do; /* we were able to release the line */ call timer_manager_$sleep (time, "11"b); /* sleep a few seconds */ /* so remote device can send if needed */ end; else if code = error_table_$undefined_order_request then do; /* this is ok also */ if iodd_static.test_entry then /* be able to set a reasonable pace */ if time > 1 then call timer_manager_$sleep (time, "11"b); /* simulate device */ end; else do; /* this is a real error */ call iodd_msg_ (error, master, code, myname, "From ""end_write_mode"" control"); iodd_static.slave_hold = "1"b; end; if iodd_static.slave.active then /* flush any messages */ call iox_$control (iodd_static.slave_out, "runout", null, code); return; %page; /* For this driver, this entry is almost a no-op: we do not send banners around our reader output to the host */ print_banner: entry (a_stream, a_banner_type, a_data_ptr, a_code); banner_type = a_banner_type; a_code, code = 0; p = iodd_static.driver_ptr; /* save driver_ptr in short name variable */ p2 = addr (p -> driver_status.descriptor); /* get descriptor ptr just in case */ if banner_type = head_banner then do; /* reset the accounting data for each request copy */ call iox_$control (p -> driver_status.dev_out_iocbp, "reset", null, code); end; a_code = code; if code ^= 0 then p2 -> request_descriptor.keep_in_queue = "1"b; /* defer the request */ return; %page; /* Process a driver command */ command: entry (a_source, a_state, a_argp, a_code); argp = a_argp; /* define the arg_list structure which contains "command" */ source = a_source; state = a_state; on conversion begin; /* handler for conversion errors */ call iodd_msg_ (normal, source, 0, "", "Argument conversion error. Try again."); go to cmd_error; end; save_code = a_code; /* save the called value */ a_code, code = 0; /* say we handled it for now */ if command = "help" then do; call iodd_msg_ (normal, source, 0, "", "^/** Commands for the HASP workstation simulator driver **^/"); if static_receive_data.device_type ^= 0 then do; /* an input device (printer or punch) */ call iodd_msg_ (normal, source, 0, "", "receive"); call iodd_msg_ (normal, source, 0, "", "auto_queue yes | no"); call iodd_msg_ (normal, source, 0, "", "request_type rqt_name"); call iodd_msg_ (normal, source, 0, "", "clean_pool "); end; else do; /* output device (reader) */ call iodd_msg_ (normal, source, 0, "", "pause_time []"); call iodd_msg_ (normal, source, 0, "", "single"); end; go to end_cmd; end; if command = "pause_time" | command = "pausetime" then do; if static_receive_data.device_type ^= 0 then do; /* only valid for output devices */ call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device."); go to cmd_error; end; if arg_list.n_tokens > 1 then do; value = convert (value, arg_list.arg (1)); if value < 0 | value > 30 then do; call iodd_msg_ (normal, source, 0, "", "pause_time range: 0 to 30 seconds "); go to cmd_error; end; time = value; go to end_cmd; end; else do; time = 10; /* return to the default */ go to end_cmd; end; end; if command = "single" then do; /* make a single copy of the current request */ if static_receive_data.device_type ^= 0 then do; /* only valid for output devices */ call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device."); go to cmd_error; end; if iodd_static.request_in_progress then do; iocbp = iodd_static.driver_ptr -> driver_status.dev_out_iocbp; call iox_$modes (iocbp, "single", omode, ignore); /* set single mode */ call output_request_$set_single_copy (); end; else call iodd_msg_ (normal, source, 0, "", "No current request."); go to end_cmd; end; if command = "receive" then do; if static_receive_data.device_type = 0 then do; /* only valid for input devices */ call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device."); go to cmd_error; end; call iodd_msg_ (normal, source, 0, "", "Waiting for file input."); on command_level goto abort_read; /* grab control after record quota overflow */ call receive_file_ (pool_dir, addr (static_sw_info), station, addr (static_receive_data), code); if code ^= 0 then call iodd_msg_ (normal, source, myname, code, "From receive_file_ "); go to end_cmd; abort_read: call iodd_msg_ (normal, source, 0, "", "Use the ""clean_pool"" command and retry card input."); go to cmd_error; end; if command = "auto_queue" | command = "autoqueue" then do; if static_receive_data.device_type = 0 then do; /* wrong driver type */ call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device."); go to cmd_error; end; if arg_list.n_tokens < 2 then do; /* must define what he wants */ call iodd_msg_ (normal, source, 0, "", "Argument yes or no must be given."); go to cmd_error; end; if arg_list.arg (1) = "yes" then static_receive_data.no_ident, /* don't look for ++IDENT */ static_receive_data.auto_queue = "1"b; /* queue request to print/punch file */ else if arg_list.arg (1) = "no" then static_receive_data.no_ident, /* look gor ++IDENT */ static_receive_data.auto_queue = "0"b; /* don't queue request to print/punch file */ else do; call iodd_msg_ (normal, source, 0, "", "Argument must be either yes or no."); go to cmd_error; end; go to end_cmd; end; if command = "request_type" | command = "requesttype" | command = "rqt" then do; if static_receive_data.device_type = 0 then do; /* wrong type of driver (input only) */ call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device."); go to cmd_error; end; if arg_list.n_tokens < 2 then do; /* default to the type specified in iod_tables */ static_receive_data.request_type = static_default_request_type; go to end_cmd; end; if length (arg_list.arg (1)) > length (local_request_type) then do; call iodd_msg_ (normal, source, error_table_$bigarg, myname, "Request type name must be less than ^d characters long; not ""^a"".", (length (local_request_type) + 1), arg_list.arg (1)); go to cmd_error; end; local_request_type = arg_list.arg (1); /* get the request type */ call iod_info_$generic_type (local_request_type, generic_type, code); if code ^= 0 then do; call iodd_msg_ (normal, source, code, myname, "^a", local_request_type); go to cmd_error; end; if ((static_receive_data.device_type = printer_input_device) & (generic_type ^= "printer")) | ((static_receive_data.device_type = punch_input_device) & (generic_type ^= "punch")) then do; /* wrong type of request type for this driver */ call iodd_msg_ (normal, source, 0, "", "Request type ""^a"" must be of generic type ^[printer^;punch^]; not ""^a"".", local_request_type, static_receive_data.device_type, generic_type); go to cmd_error; end; static_receive_data.request_type = local_request_type; go to end_cmd; end; if command = "clean_pool" | command = "cleanpool" then do; /* garbage collect the card pool */ if static_receive_data.device_type = 0 then do; /* only valid for input devices */ call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device."); go to cmd_error; end; if source = slave then do; call iodd_msg_ (normal, source, 0, "", "The clean_pool command is restricted to the master terminal."); go to cmd_error; end; if arg_list.n_tokens < 2 then do; /* we must have an age arg */ call iodd_msg_ (normal, source, 0, "", "Argument missing: days allowed to remain in the pool."); go to cmd_error; end; age = convert (age, arg_list.arg (1)); /* convert to binary */ if age < 1 then do; /* be sure the value is right */ call iodd_msg_ (normal, source, 0, "", "Invalid argument: ^a", arg_list.arg (1)); go to cmd_error; end; call pool_manager_$clean_pool (pool_dir, age, 10, code); /* let pool_manager_ do the work */ if code ^= 0 then call iodd_msg_ (normal, source, code, myname, "Unable to clean up pool storage."); go to end_cmd; end; /* When control passes here, the command is unknown: just return and let iodd_command_processor_ handle it */ a_code = save_code; return; end_cmd: a_code = code; /* pass back any defined errors */ return; cmd_error: a_code = error_table_$action_not_performed; /* cause a resetread */ return; default_handler: entry (condition_info_ptr); dcl condition char (32); /* fixed string for the call */ condition = condition_info.condition_name; /* this will indent funny */ if iodd_static.request_in_progress then call output_request_$error_during_request (condition); /* take it away */ return; /* output_request_ should not return, but.... */ close_and_detach: proc (a_iocbp, send_hangup); dcl a_iocbp ptr; dcl send_hangup bit (1); dcl code fixed bin (35); /* local error code */ if a_iocbp = null then return; if send_hangup then call iox_$control (a_iocbp, "hangup", null, code); call iox_$close (a_iocbp, code); call iox_$detach_iocb (a_iocbp, code); a_iocbp = null; return; end close_and_detach; minor_attach: procedure (Device); dcl Device char (*) parameter; dcl desc char (256) varying; dcl io_module char (32) var; dcl dev_opt char (32) var; dcl mode fixed bin; if Device = "reader_out" then do; /* for this one we are simulating a reader to the host */ io_module = "remote_punch_"; /* use the special feature of the punch io module */ dev_opt = "reader_simulator"; /* by the special -device option */ mode = Stream_output; /* open mode is for stream output */ end; else do; /* otherwise, we are receiving print/punch files */ io_module = "remote_input_"; /* so use the other type io module */ dev_opt = rtrim (Device); /* this will be printer_in or punch_in, don't care which */ mode = Stream_input; /* open mode is for stream input */ end; desc = io_module || " -tty " || rtrim (iodd_static.attach_name); /* build the attach description */ desc = desc || space || iodd_parse_$args ("desc=", major_args); desc = desc || space || iodd_parse_$args ("desc=", minor_args); desc = desc || " -device " || dev_opt; /* be sure this is last */ p -> driver_status.dev_out_stream = get_switch_name (Device); call iox_$attach_ioname ((p -> driver_status.dev_out_stream), p -> driver_status.dev_out_iocbp, (desc), code); if code ^= 0 & code ^= error_table_$not_detached & code ^= error_table_$ionmat then goto attach_error; call iox_$open (p -> driver_status.dev_out_iocbp, mode, ""b, code); if code ^= 0 & code ^= error_table_$not_closed then do; attach_error: call iodd_msg_ (error, master, code, myname, "Attaching minor device: ^a^/Attach desc: ^a.", p -> driver_status.device_id, desc); goto clean_out; end; p -> driver_status.dev_in_iocbp = p -> driver_status.dev_out_iocbp; /* make them the same */ call set_hangup_proc (p -> driver_status.dev_out_iocbp); end minor_attach; get_switch_name: procedure (Device) returns (character (32)); declare index fixed bin internal static init (0); declare Device char (*); index = index + 1; if index > 999 then index = 1; /* keep it reasonable */ return (Device || "_" || ltrim (character (index))); end get_switch_name; set_hangup_proc: proc (iocbp); dcl iocbp ptr; /* this internal proc will set the device hangup procedure for the specified switch */ hangup_info.entry = iodd_hangup_$iodd_hangup_; hangup_info.data_ptr = stat_p; hangup_info.priority = 1; call iox_$control (iocbp, "hangup_proc", addr (hangup_info), code); if code ^= 0 then do; call iodd_msg_ (error, master, code, myname, "Fatal error. Unable to set hangup proc."); goto clean_out; end; return; end set_hangup_proc; %page; initiate_the_file: proc (pathname_string, args_ptr, args_length, message, code); dcl pathname_string char (256) varying; dcl args_ptr ptr; dcl args_length fixed bin; dcl message char (*); dcl code fixed bin (35); dcl dirname char (168); dcl entname char (32); dcl compname char (32); dcl args_bc fixed bin (24); call expand_pathname_$component ((pathname_string), dirname, entname, compname, code); if code ^= 0 then return; call initiate_file_$component (dirname, entname, compname, R_ACCESS, args_ptr, args_bc, code); if code ^= 0 then return; args_length = divide (args_bc + 8, 9, 17, 0); end initiate_the_file; %page; %include access_mode_values; %page; %include condition_info; %page; %include dprint_msg; %page; %include driver_ptr_list; %page; %include driver_status; %page; %include find_input_sw_info; %page; %include iod_tables_hdr; %page; %include iod_constants; %page; %include iodd_static; %page; %include iox_modes; %page; %include mseg_message_info; %page; %include output_request_data; %page; %include queue_msg_hdr; %page; %include receive_file_data; %page; %include request_descriptor; %page; %include terminal_info; end hasp_ws_sim_driver_;  receive_file_.pl1 03/15/89 0843.0r w 03/15/89 0800.0 339021 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Procedure to receive a file from a remote host and put it into some pool storage */ /* Created, Feb 1980, by J. C. Whitmore - based on the read_cards_ proc */ /* Modified: September 1980 by G. Palter to add the request_type keyword to ++CONTROL, make processing of ++FORMAT and ++CONTROL never generate fatal errors, and make use of auto_queue when ++IDENT required not delete */ /* Modified: 30 September 1981 by G. Palter to convert to version 6 dprint_arg (longer request type names) and enable I/O daemon escape processing (logical channel skips) by default when queueing print files */ /* Modified: 8 October 1981 by G. Palter to bypass the "classic" segment to MSF conversion problem */ /* Modified: 27 December 1984 by Keith Loepere for version 2 create_branch_info. */ /****^ HISTORY COMMENTS: 1) change(87-05-10,Gilcrease), approve(87-05-13,MCR7686), audit(88-02-01,Farley), install(88-02-02,MR12.2-1019): Updated to use latest version (9) of dprint_arg. END HISTORY COMMENTS */ receive_file_: procedure (a_root_dir, a_sw_info_p, a_station, a_data_ptr, a_code); /* Parameters */ dcl a_root_dir char (*) parameter; /* pool root directory */ dcl a_sw_info_p ptr parameter; /* pointer to the sw_info structure */ dcl a_station char (*) parameter; /* remote_station name for messages */ dcl a_data_ptr ptr parameter; /* pointer to receive_file_data structure of caller */ dcl a_code fixed bin (35) parameter; /* Remaining declarations */ dcl aclec fixed bin; dcl add_nl bit (1); dcl bc fixed bin (24); /* bit count of seg */ dcl record_buffer char (1024) aligned; /* read buffer for character input */ dcl record char (2000) var; dcl record_len fixed bin (24); dcl chars_left_in_seg fixed bin (24); dcl left fixed bin (24); dcl code fixed bin (35); dcl component fixed bin; dcl contin bit (1); dcl file_name char (32) var; /* user supplied name of file */ dcl filep ptr ; dcl dirname char (168); /* pathname of personid directory in pool */ dcl done bit (1); dcl default_person char (32); dcl default_project char (32); dcl default_personid char (32); dcl element_size fixed bin; /* element size for file format */ dcl fcbp ptr; dcl field (40) char (80) var; dcl field_cnt fixed bin; dcl ignore fixed bin (35); dcl input_modes char (256); dcl input_mode_bits bit (36); dcl control_mode_bits bit (36); dcl key char (32) var; dcl key_mode char (32); dcl len fixed bin (24); dcl long char (100); /* space to expand an error_table_ code */ dcl lower_case bit (1); dcl max_chars fixed bin (24); dcl chars_in_last_seg fixed bin (24); /* number of elements transmitted */ dcl new_file_name char (32); /* internal name of file */ dcl overwrite bit (1); dcl person char (32); /* person part of personid */ dcl personid char (32); dcl pool_open bit (1); dcl proc_auth bit (72); /* access class of the process */ dcl project char (32); /* and the project part */ dcl file_path char (168) var; dcl read_done bit (1); dcl root_dir char (168); dcl source fixed bin; /* iocbp index in sw_info structure */ dcl station char (32) var init ("remote-file-input"); dcl short char (8); /* dummy for convert_status_code_ */ dcl tag fixed bin; /* dupe name counter */ dcl testing bit (1); /* our local test mode flag */ dcl user_defined bit (1); dcl user_msg char (136); dcl log_msg char (256); dcl test_iocbp ptr; dcl trim bit (1); dcl data_idx fixed bin; dcl file_in_progress bit (1) init ("0"b); dcl master_iocbp ptr; /* iocb pointers which we will use */ dcl slave_iocbp ptr; dcl input_iocbp ptr; dcl (record_quota_overflow, command_level, cleanup) condition; dcl (addr, null, index, substr, verify, length, multiply, divide, rtrim, before, after, unspec, search, ltrim) builtin; dcl string char (string_len) based; dcl string_len fixed bin; dcl based_chars (2000) char (1) based; dcl 1 acle (2) aligned, /* ACL entry */ 2 name char (32), 2 mode bit (36), 2 pad bit (36), 2 code fixed bin (35); dcl 1 cb_info aligned like create_branch_info auto; dcl 1 file_data aligned like receive_file_data; /* our working copy of the running parms */ dcl 1 count_structure aligned, /* structure used for the get_count control order */ 2 line fixed bin, /* most fields are pads, because this structure */ 2 page_len fixed bin, /* is based on the printer defined structure */ 2 lmarg fixed bin, /* shown in prt_order_info.incl.pl1 */ 2 rmarg fixed bin, 2 records fixed bin (35), /* this is the normal line count field */ 2 page_count fixed bin; dcl tell_user bit (1) int static init ("1"b) options (constant); dcl silent bit (1) int static init ("0"b) options (constant); dcl max_record_len fixed bin (24) int static options (constant) init (1024); dcl control_modes char (32) int static init ("^add_nl,lower_case,trim.") options (constant); dcl ESC_c char (2) int static options (constant) init ("c"); dcl ETX char (1) int static options (constant) init (""); dcl SP char (1) int static options (constant) init (" "); dcl NL char (1) int static options (constant) init (" "); dcl FF char (1) int static options (constant) init (" "); dcl sys_info$max_seg_size fixed bin (35) ext static; dcl (error_table_$bad_arg, error_table_$bigarg, error_table_$short_record, error_table_$end_of_info, error_table_$eof_record, error_table_$namedup, error_table_$noarg, error_table_$unimplemented_version) fixed binary (35) external; dcl card_util_$modes entry (char (*), bit (36), char (*), fixed bin (35)); dcl card_util_$translate entry (bit (36), char (*) var); dcl send_mail_ entry (char (*), char (*), ptr, fixed bin (35)); dcl msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35)); dcl convert_status_code_ entry (fixed bin (35), char (8), char (100)); dcl cu_$level_get entry returns (fixed bin); dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl dprint_ entry (char (*), char (*), ptr, fixed bin (35)); dcl find_input_switch_ entry (ptr, bit (1), fixed bin, fixed bin (35)); dcl get_authorization_ entry returns (bit (72)); dcl get_group_id_ entry returns (char (32)); dcl msf_manager_$close entry (ptr); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)); dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)); dcl msf_manager_$acl_add entry (ptr, ptr, fixed bin, fixed bin (35)); dcl hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl iod_info_$generic_type entry (character (*), character (32), fixed binary (35)); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$get_chars entry (ptr, ptr, fixed bin (24), fixed bin (24), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (24), fixed bin (35)); dcl iox_$control entry (ptr, char (*) aligned, ptr, fixed bin (35)); dcl pool_manager_$add_quota entry (char (*), fixed bin, fixed bin (35)); dcl pool_manager_$close_user_pool entry (char (*), char (*), fixed bin, bit (36), fixed bin (35)); dcl pool_manager_$open_user_pool entry (char (*), char (*), char (*), fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); %page; %include find_input_sw_info; %include receive_file_data; %page; %include create_branch_info; %page; %include send_mail_info; %page; %include dprint_arg; %page; /* receive_file_: procedure (a_root_dir, a_sw_info_p, a_station, a_test_mode, a_code); */ a_code = 0; root_dir = a_root_dir; station = a_station; receive_file_data_ptr = a_data_ptr; if receive_file_data.version ^= receive_file_data_version_1 then do; bad_version: code = error_table_$unimplemented_version; return; end; sw_info_p = a_sw_info_p; /* setup automatic based references */ if sw_info.version ^= sw_info_version_1 then go to bad_version; /* set up iocb pointers we will use according to the conventions */ data_idx = sw_info.n_iocb_ptrs; /* save index of the data iocbp - last one */ if data_idx < 2 | data_idx > 10 then do; /* must have what we need */ bad_arg: a_code = error_table_$bad_arg; /* reject immediately, no opr messages */ return; end; master_iocbp = sw_info.iocbp (1); /* 1 = master console (user_io) required. */ if data_idx > 2 then slave_iocbp = sw_info.iocbp (2); /* 2 = slave console (if any - optional) */ else slave_iocbp = null; /* be sure we mark it as undefined if not given */ /* 3 = control console (also optional) - not used here */ input_iocbp = sw_info.iocbp (data_idx); /* last one is the data input iocbp - required */ if input_iocbp = null | master_iocbp = null then go to bad_arg; /* check out pointers */ call INITIALIZE_STUFF; /* use the internal proc to make this cleaner */ on record_quota_overflow call overflow_handler; on cleanup begin; code = 0; if file_in_progress then /* should we tell the operator about this */ call report ("receive_file_: Aborting file input." || NL, silent); /* don't tell user */ call clean_up; /* delete any partial input */ end; start: call RESET_PARAMETERS; key_mode = "IDENT search"; /* this is for log debugging messages */ /* check for command input or next file start */ read_ident: call find_input_switch_ (sw_info_p, "1"b, source, code); /* look for input, block if nothing waiting */ if code ^= 0 then call abort (code, "Returning to command level."); if source ^= data_idx then return; /* allow commands to have priority */ /* We have some data coming in. If we don't require ++IDENT record, all must go into a segment */ if file_data.no_ident then do; call report ("Begin file: " || file_name || NL, silent); go to get_pool_dir; end; call read_control_record (key, field (*), field_cnt, code); /* parse record into key and arg fields */ if code = error_table_$eof_record then go to start; /* ignore an unexpected EOF record */ if key ^= "++ident" then do; /* flush anything out of sync */ key_mode = "IDENT flush"; /* show that we are dumping data */ go to read_ident; end; key_mode = "IDENT found"; /* we matched on something */ if field_cnt ^= 3 & field_cnt ^= 2 then call abort_read (0, "Invalid ++IDENT record format: " || record, silent); file_name = field (1); /* first field after ++IDENT is the file name */ if field_cnt = 3 then do; /* next is person.project or person project */ person = field (2); project = field (3); end; else if field_cnt = 2 then do; person = before (field (2), "."); project = after (field (2), "."); end; if person = "*" | person = "" then /* a personid of * is illegal */ call abort_read (0, "Invalid person name: " || record, silent); if project = "*" | project = "" then call abort_read (0, "Invalid project name: " || record, silent); personid = rtrim (person) || "." || project; user_defined = "1"b; /* we now have something we can identify */ call ioa_$rsnnl ("Station ""^a"" receiving file ""^a"" for ^a." || NL, user_msg, len, station, file_name, personid); call report (rtrim (user_msg), silent); /* this is a log message */ /* Look for any other control records, up to ++INPUT and digest them */ done = "0"b; do while (^done); read_next_control_record: call read_control_record (key, field (*), field_cnt, code); /* read and split into key + arg fields */ if code = error_table_$eof_record then do; call report ("Unexpected EOF record among control records." || NL, silent); go to start; end; else if code ^= 0 then call abort (code, "Read error. Aborting"); else if key = "++input" then done = "1"b; else if key = "++format" then /* user defined format data */ call decode_format_args (field (*), field_cnt); else if key = "++control" then call decode_control_args (field (*), field_cnt); else if key = "++ident" then call abort_read (0, "Out of sequence ++IDENT record", tell_user); else call control_record_error (0, "Unrecognized control record ignored: " || record, tell_user); end; /* We now have all the control records for receiving the file. Get ready to read the file text. */ /* First, we must have a place to write the data. Create an output file in the pool directory */ get_pool_dir: file_in_progress = "1"b; /* mark our progress for recovery */ call pool_manager_$open_user_pool (root_dir, person, dirname, code); /* get dir path name for this person */ if code ^= 0 then /* pool error is very bad */ call abort (code, "Unable to open pool storage."); pool_open = "1"b; /* be sure we close the pool on error */ unspec (cb_info) = "0"b; cb_info.version = create_branch_version_2; cb_info.mode = "101"b; cb_info.rings (1), cb_info.rings (2), cb_info.rings (3) = cu_$level_get (); cb_info.userid = get_group_id_ (); cb_info.access_class = proc_auth; tag, code = -1; do while (code ^= 0); /* loop on name dup errors */ tag = tag + 1; /* change the name to "name.n" */ if tag > 499 then /* avoid infinite loop, but try hard */ call abort_read (0, "Aborting file: 500 duplicate files in " || dirname, tell_user); call ioa_$rsnnl ("^a.^d", new_file_name, len, file_name, tag); if len > 32 then call abort_read (0, "File name too long: " || substr (new_file_name, 1, len), tell_user); call hcs_$create_branch_ (dirname, new_file_name, addr (cb_info), code); if code = error_table_$namedup & overwrite then code = 0; if code ^= 0 & code ^= error_table_$namedup then /* also very bad */ call abort_read (code, "Unable to create branch in pool dir: " || rtrim (dirname), silent); end; file_path = rtrim (dirname) || ">" || rtrim (new_file_name); /* make error msgs easier */ call msf_manager_$open (dirname, new_file_name, fcbp, code); if code ^= 0 then call abort_read (code, "Unable to open new pool entry " || file_path, silent); component = 0; /* start with the first component - 0 */ call msf_manager_$get_ptr (fcbp, component, "0"b, filep, bc, code); if filep = null then call abort_read (code, "Unable to initiate new pool entry " || file_path, silent); /* Set up the translation modes for the record text. */ call ioa_$rsnnl ("^[^^^]trim,^[^^^]lower_case,^[^^^]add_nl,^[^^^]contin.", input_modes, len, ^trim, ^lower_case, ^add_nl, ^contin); call card_util_$modes (input_modes, input_mode_bits, "", code); if code ^= 0 then call abort_read (code, "Unable to set file input modes", tell_user); call iox_$control (input_iocbp, "reset", null, ignore); /* clear any accounting data */ /* This procedure ASSUMES an element size of 9 bits, I.E. chars */ element_size = 9; /* 9 bits per character */ max_chars = divide ((sys_info$max_seg_size * 36), element_size, 35); /* get number of chars in a segment */ chars_in_last_seg = 0; /* set the number of chars used in last MSF component */ chars_left_in_seg = max_chars; /* set number of chars remaining in segment */ read_next_record: record_len = 0; record_buffer = ""; call iox_$get_chars (input_iocbp, addr (record_buffer), max_record_len, record_len, code); if code ^= 0 then do; if code = error_table_$eof_record then goto end_read_loop; /* NORMAL EXIT */ else if code = error_table_$end_of_info | code = error_table_$short_record then code = 0; else call abort_read (code, "Error while reading data. Aborting file.", silent); /* ERROR EXIT */ end; record = substr (record_buffer, 1, record_len); /* put into var string for translation */ call card_util_$translate (input_mode_bits, record); record_len = length (record); /* get the new length after translation */ left = chars_left_in_seg - record_len; /* must be at least 1 char left to bump ptr */ if left <= 0 then do; /* if not enough, put in part and start new component */ string_len = chars_left_in_seg; /* set size of based string */ filep -> string = substr (record, 1, chars_left_in_seg); component = component + 1; /* start the next MSF component */ if component = 1 then do; /* about to force conversion to MSF ... */ call pool_manager_$add_quota (root_dir, 260, code); /* ... need extra quota during conversion */ if code ^= 0 then do; /* couldn't get it: let the operator try to correct it ... */ call report (NL || "Insufficient quota in pool to convert to MSF." || NL, silent); signal command_level; call pool_manager_$add_quota (root_dir, 260, code); /* ... and try again */ end; if code ^= 0 then call abort_read (code, "Insufficient quota in pool to convert to MSF.", silent); end; call msf_manager_$get_ptr (fcbp, component, "1"b, filep, bc, code); if filep = null then call abort_read (code, "Unable to initiate next MSF component", silent); if component = 1 then /* give back the quota we got temporarily */ call pool_manager_$add_quota (root_dir, -260, (0)); if left = 0 then record = ""; /* if it fit exactly.... */ else record = substr (record, chars_left_in_seg + 1); /* set image to last part of record */ string_len = length (record); /* set the based string size */ filep -> string = record; /* write the record into the output file */ filep = addr (filep -> based_chars (string_len + 1)); /* move output pointer to where the next char goes */ chars_left_in_seg = max_chars - string_len; /* room left in this component */ chars_in_last_seg = string_len; /* restart last component count */ end; else do; /* the full record (+ 1 char) will fit this MSF component */ string_len = length (record); /* set the length of the based string */ filep -> string = record; /* and write out the data */ filep = addr (filep -> based_chars (string_len + 1)); /* move output pointer to where the next char goes */ chars_left_in_seg = left; /* do the accounting */ chars_in_last_seg = chars_in_last_seg + string_len; /* update the number received */ end; go to read_next_record; /* - - - we don't fall through here - - - - */ end_read_loop: read_done = "1"b; /* tell abort handler not to look for EOF */ bc = multiply (chars_in_last_seg, element_size, 24, 0); /* set bitcount of last component ... all others are max_seg_size * 36 */ call msf_manager_$adjust (fcbp, component, bc, "111"b, code); if code ^= 0 then call abort_read (code, "Error setting bit-count.", silent); unspec (acle) = "0"b; /* get the acl structure ready */ acle (1).name = rtrim (personid) || ".*"; /* put the file sender on the acl */ acle (1).mode = "100"b; /* read access only */ aclec = 1; call msf_manager_$acl_add (fcbp, addr (acle), aclec, code); if code ^= 0 then call abort_read (code, "Error setting ACL.", silent); if fcbp ^= null then call msf_manager_$close (fcbp); fcbp = null; if pool_open then do; call pool_manager_$close_user_pool (root_dir, person, 1, "100"b|| (33)"0"b, code); /* close the pool */ if code ^= 0 then call abort_read (code, "Error closing user's pool dir.", silent); end; pool_open = "0"b; /* all is well */ unspec (count_structure) = ""b; /* clear the value in case of non inplemented order */ call iox_$control (input_iocbp, "get_count", addr (count_structure), ignore); /* get record total */ /* this can be used for charging in the future */ call ioa_$rsnnl ("End-of-file for: ^a ^[(^d records)^]^/", user_msg, len, file_name, (count_structure.records > 0), count_structure.records); call report (substr (user_msg, 1, len), silent); /* log the end of file input */ if file_data.auto_queue then do; substr (dprint_arg.destination, 1, length (dprint_arg.destination)) = substr (personid, 1, length (dprint_arg.destination)); substr (dprint_arg.request_type, 1, length (dprint_arg.request_type)) = substr (file_data.request_type, 1, length (dprint_arg.request_type)); dprint_arg.bit_count = (component * 36 * sys_info$max_seg_size) + bc; if ^file_data.no_ident then /* user requested dprint/dpunch on ++CONTROL record ... */ dprint_arg.delete = 0; /* ... so don't delete file before they can copy it */ call dprint_ (dirname, new_file_name, dpap, code); if code ^= 0 then go to let_it_stay; call ioa_$rsnnl ("File ""^a"" from station ^a queued for ^[dprint^;dpunch^].^/", user_msg, len, file_name, station, (file_data.device_type = printer_input_device)); call notify_user (substr (user_msg, 1, len)); /* inform the user if defined */ end; else do; let_it_stay: call ioa_$rsnnl ("File ""^a"" from station ^a stored in ^a^/", user_msg, len, file_name, station, file_path); call notify_user (substr (user_msg, 1, len)); /* inform the user if defined */ end; if testing then do; call iox_$put_chars (test_iocbp, addr (user_msg), len, code); if code ^= 0 then testing = "0"b; end; goto start; /* see if there is another file to read */ abort_exit: call clean_up; a_code = code; return; abort: proc (code, message); dcl message char (*); dcl code fixed bin (35); dcl abort_msg char (256); dcl len fixed bin (24); if code ^= 0 then call convert_status_code_ (code, short, long); else long = ""; call ioa_$rsnnl ("receive_file_: Unable to continue input function.^[^/^a^;^s^]^/^a^/", abort_msg, len, (code ^= 0), long, message); call report (rtrim (abort_msg), silent); /* tell just the operator */ goto abort_exit; end abort; notify_user: proc (message); dcl message char (*); if user_defined then /* be sure user from ++IDENT is defined */ call send_mail_ (personid, message, addr (send_mail_info), (0)); return; end notify_user; %page; abort_read: proc (code, message, tell_user); dcl code fixed bin (35); dcl message char (*); dcl tell_user bit (1); dcl abort_msg char (256); dcl len fixed bin (24); dcl count fixed bin (24); if code ^= 0 then call convert_status_code_ (code, short, long); else long = ""; call ioa_$rsnnl ("Aborting input of file^[ ""^a"" (for ^a)^;^2s^] from station ^a.^/^[^a^/^;^s^]^a^/", abort_msg, len, user_defined, file_name, personid, station, (code ^= 0), long, message); call report (rtrim (abort_msg), tell_user); /* route the message as requested */ call clean_up; if read_done | ^file_in_progress then go to start; /* was the EOF already read? */ call report ("Skipping to EOF record." || NL, silent); code = 0; do count = 0 by 1 while (code ^= error_table_$eof_record); call iox_$get_chars (input_iocbp, addr (record_buffer), max_record_len, record_len, code); if code ^= 0 then do; if code = error_table_$end_of_info | code = error_table_$short_record then code = 0; if code ^= error_table_$eof_record then call abort (code, "Read error."); end; end; if testing then do; call ioa_$rsnnl ("Aborted ^d records before EOF.^/", log_msg, len, count); call iox_$put_chars (test_iocbp, addr (log_msg), len, code); if code ^= 0 then testing = "0"b; end; go to start; /* go back and check for commands and next ++IDENT */ end abort_read; %page; /* Report a non-fatal error encountered during control record processing */ control_record_error: procedure (code, message, tell_user); dcl code fixed binary (35) parameter; dcl message character (*) parameter; dcl tell_user bit (1) parameter; dcl error_message character (256); if code ^= 0 then /* include system error message in report */ call convert_status_code_ (code, short, long); else long = ""; /* just to be safe; it won't be in ioa_ string anyway */ call ioa_$rsnnl ("During input of file ""^a"" (for ^a) from station ^a.^/^[^a^/^;^s^]^a^/", error_message, (0b), file_name, personid, station, (code ^= 0), long, message); /* include supplied message */ call report (rtrim (error_message), tell_user); /* issue the complaint */ return; /* and that's all: it's not fatal... */ end control_record_error; %page; report: proc (message, tell_user); dcl code fixed bin (35); dcl message char (*); dcl tell_user bit (1); dcl opr_iocbp ptr; if tell_user then call notify_user (message); if slave_iocbp = null then opr_iocbp = master_iocbp; else opr_iocbp = slave_iocbp; write_msg: call iox_$put_chars (opr_iocbp, addr (message), length (message), code); if code ^= 0 then do; if opr_iocbp = slave_iocbp then do; /* tell the master if slave gets error */ opr_iocbp = master_iocbp; go to write_msg; end; /* For other errors we can't do much, so just return. */ end; if testing then do; call iox_$put_chars (test_iocbp, addr (message), length (message), code); if code ^= 0 then testing = "0"b; end; return; end report; read_control_record: proc (key, field, field_cnt, code); dcl key char (*) var parameter; dcl field (40) char (80) var parameter; dcl field_cnt fixed bin parameter; dcl code fixed bin (35) parameter; dcl arg_string char (160) var; dcl scan_done bit (1); dcl field_begin fixed bin; dcl field_len fixed bin; dcl i fixed bin; dcl len fixed bin (24); key = ""; /* clear the return parameters */ field (*) = ""; field_cnt = 0; call iox_$get_chars (input_iocbp, addr (record_buffer), max_record_len, record_len, code); if code ^= 0 then do; if code = error_table_$eof_record then return; else if code = error_table_$end_of_info | code = error_table_$short_record then code = 0; else call abort (code, "Read error."); end; if record_len = 0 then do; code = error_table_$end_of_info; return; end; record = substr (record_buffer, 1, record_len); /* use varying string for translation */ if testing then do; /* keep a log of all control records read */ call ioa_$rsnnl ("CTL (^a):^21t^a^/", log_msg, len, key_mode, record); call iox_$put_chars (test_iocbp, addr (log_msg), len, code); if code ^= 0 then testing = "0"b; code = 0; /* just in case, make it quiet */ end; i = index (record, ESC_c); /* check for slew control chars and flush them */ if i = 1 then do; /* this is the pre-slew sequence */ i = index (record, ETX); /* find the closing ETX */ /* if not found, strip nothing */ record = substr (record, i + 1); end; else if i > 1 then do; /* this is the post slew sequence */ record = substr (record, 1, i - 1); /* take up to the slew, and junk the rest */ end; record = ltrim (record, NL || FF || SP); /* strip any other pad or slew control */ record = rtrim (record, NL || FF || SP); call card_util_$translate (control_mode_bits, record); len = search (record, " "); /* find the first space char */ if len = 0 then do; /* no spaces, maybe ++input */ key = record; /* try it */ return; end; key = substr (record, 1, len - 1); /* this is the ++ keyword */ arg_string = ltrim (rtrim (substr (record, len))); /* args are the remainder of the record */ field_begin = 1; scan_done = "0"b; do i = 1 to 40 while (^scan_done); /* 40 args max */ field_len = search (substr (arg_string, field_begin), " "); if field_len = 0 then do; field_len = length (arg_string) - field_begin + 1; scan_done = "1"b; end; else field_len = field_len - 1; field (i) = substr (arg_string, field_begin, field_len); field_begin = field_begin + field_len + verify (substr (arg_string, field_begin + field_len), " ") - 1; field_cnt = i; end; return; end read_control_record; decode_format_args: proc (field, field_cnt); dcl field (40) char (80) var; dcl field_cnt fixed bin; dcl i fixed bin; if field_cnt < 1 then do; call control_record_error (0, "Incorrect ++FORMAT record ignored: " || record, tell_user); go to read_next_control_record; end; do i = 1 to field_cnt; if field (i) = "trim" then trim = "1"b; else if field (i) = "notrim" then trim = "0"b; else if field (i) = "lowercase" then lower_case = "1"b; else if field (i) = "noconvert" then lower_case = "0"b; else if field (i) = "addnl" then add_nl = "1"b; else if field (i) = "noaddnl" then add_nl = "0"b; else if field (i) = "contin" then contin = "1"b; else if field (i) = "nocontin" then contin = "0"b; else call control_record_error (0, "Undefined mode ignored on ++FORMAT record: " || field (i), tell_user); end; return; end decode_format_args; %page; /* Process ++CONTROL record */ decode_control_args: procedure (fields, n_fields); dcl fields (40) character (80) varying parameter; dcl n_fields fixed binary parameter; dcl idx fixed binary; dcl generic_type character (32); dcl local_request_type character (24); if n_fields < 1 then do; call control_record_error (0, "Incorrect ++CONTROL record ignored: " || record, tell_user); go to read_next_control_record; end; do idx = 1 to n_fields; if (fields (idx) = "overwrite") then /* overwrite previous versions in compiler pool */ overwrite = "1"b; else if (fields (idx) = "auto_queue") then /* automatically queue file for printing/punching */ file_data.auto_queue = "1"b; else if ((fields (idx) = "request_type") | (fields (idx) = "rqt")) then do; /* specific request type for automatic queuing */ if (idx = n_fields) then do; call control_record_error (error_table_$noarg, "Request type name must follow ""request_type"" key on ++CONTROL record; the ""request_type"" key is ignored.", tell_user); return; /* this was the last field on the record */ end; idx = idx + 1; /* request type name is next field */ if length (fields (idx)) > length (local_request_type) then do; call control_record_error (error_table_$bigarg, "Request type name must be less than 25 characters long; not """ || fields (idx) || """; the ""request_type"" key is ignored.", tell_user); go to check_next_control_field; end; local_request_type = fields (idx); call iod_info_$generic_type (local_request_type, generic_type, code); if code ^= 0 then do; call control_record_error (code, """" || fields (idx) || """; the ""request_type"" key is ignored.", tell_user); go to check_next_control_field; end; if ((file_data.device_type = printer_input_device) & (generic_type ^= "printer")) | ((file_data.device_type = punch_input_device) & (generic_type ^= "punch")) then do; /* wrong type of request type */ call control_record_error (0, "Request type """ || fields (idx) || """ specified on ++CONTROL record has incorrect generic type; the ""request_type"" key is ignored.", tell_user); go to check_next_control_field; end; file_data.request_type = local_request_type; /* got a valid one */ end; else call control_record_error (0, "Unknown key on ++CONTROL record ignored: " || fields (idx), tell_user); check_next_control_field: end; return; end decode_control_args; %page; clean_up: proc; dcl ignore fixed bin (35); if fcbp ^= null then do; call msf_manager_$close (fcbp); fcbp = null; /* don't repeat this */ call delete_$path (dirname, new_file_name, "100100"b, "", ignore); end; if pool_open then do; call pool_manager_$close_user_pool (root_dir, person, 1, "100"b || (33)"0"b, ignore); pool_open = "0"b; end; return; end clean_up; overflow_handler: proc; dcl code fixed bin (35); call pool_manager_$add_quota (root_dir, 10, code); /* add 10 pages and keep going */ if code ^= 0 then do; call report (NL ||"No available quota in pool." || NL, silent); signal command_level; /* allow operator to respond */ end; return; /* restart where we stopped if it returns */ end overflow_handler; INITIALIZE_STUFF: proc; file_data = receive_file_data; /* set up our working copy of the control data */ testing = file_data.testing; /* grab this once, we may need to cancel it */ default_personid = get_group_id_ (); /* get names to be used for no_ident case */ default_person = before (default_personid, "."); default_project = before (after (default_personid, "."), "."); default_personid = rtrim (default_person) || "." || default_project; /* omit the instance tag */ dpap = addr (dprint_arg_buf); /* where we build the message for dprint_ */ dprint_arg.version = dprint_arg_version_9; dprint_arg.copies = 1; dprint_arg.queue = 0; /* use the drfault queue at all times */ dprint_arg.delete = 1; /* always delete after print/punch */ dprint_arg.pt_pch = file_data.device_type; /* they just happen to match */ dprint_arg.notify = 0; dprint_arg.heading = ""; /* later */ if file_data.device_type = printer_input_device then dprint_arg.output_module = 1; /* 1 = print */ else dprint_arg.output_module = 3; /* 3 = MCC or character output */ dprint_arg.dest = ""; /* obsolete, but initialize */ dprint_arg.carriage_control = ""b; /* no options ... */ if file_data.device_type = printer_input_device then do; /* (printer only) */ dprint_arg.nep = "1"b; /* ... except -no_endpage */ dprint_arg.esc = "1"b; /* ... and escape processing (logical channel skips) */ end; dprint_arg.forms = ""; dprint_arg.lmargin = 0; dprint_arg.line_lth = 0; /* again use the default */ dprint_arg.class = ""; /* obsolete, but initialize */ dprint_arg.page_lth = 0; dprint_arg.top_label = ""; dprint_arg.bottom_label = ""; dprint_arg.bit_count = 0; dprint_arg.form_name = ""; dprint_arg.destination = ""; /* later */ dprint_arg.chan_stop_path = ""; substr (dprint_arg.request_type, 1, length (dprint_arg.request_type)) = substr (file_data.request_type, 1, length (dprint_arg.request_type)); dprint_arg.defer_until_process_termination = 0; unspec (send_mail_info) = "0"b; send_mail_info.version = send_mail_info_version_2; send_mail_info.sent_from = station; send_mail_info.wakeup = "1"b; send_mail_info.always_add = "1"b; send_mail_info.never_add = "0"b; send_mail_info.notify = "0"b; send_mail_info.acknowledge = "0"b; proc_auth = get_authorization_ (); /* get caller's authorization to use for create_branch_ */ call card_util_$modes (control_modes, control_mode_bits, "", code); /* get a bit string for control records */ if code ^= 0 then call abort (code, "Unable to set control modes."); test_iocbp = null; /* no place to write log messages defined yet */ if testing then do; /* see if we have a side file to log control records */ /* Test mode for this procedure consists of writing control records and messages into a log file. */ /* We assume that the IO switch "test_output" is attached through vfile_ to the log file. */ /* Test mode is cancelled if this switch is not found or an error occurs while writing. */ call iox_$look_iocb ("test_output", test_iocbp, code); if code ^= 0 | test_iocbp = null then testing = "0"b; /* if not cancel test mode */ else do; call ioa_$rsnnl ("^/receive_file_: Entry initialization for station ^a.^2/", log_msg, len, station); call iox_$put_chars (test_iocbp, addr (log_msg), len, code); if code ^= 0 then testing = "0"b; /* cancel on errors */ end; end; end INITIALIZE_STUFF; RESET_PARAMETERS: proc; file_data = receive_file_data; /* reset to caller's defaults */ file_name = unique_chars_ (""b); /* in case of the no_ident option */ dirname = ""; person = default_person; project = default_project; personid = default_personid; input_mode_bits = "0"b; pool_open = "0"b; /* the user pool is not yet open */ read_done = "0"b; file_in_progress = "0"b; user_defined = "0"b; filep, fcbp = null; add_nl = "0"b; /* set the default data translation modes */ lower_case = "0"b; overwrite = "0"b; contin = "0"b; trim = "0"b; substr (dprint_arg.request_type , 1, length (dprint_arg.request_type )) = substr (file_data.request_type, 1, length (dprint_arg.request_type)); dprint_arg.heading = rtrim (station) || " Output OPERATOR PLEASE LOOK INSIDE FOR BANNER"; dprint_arg.bit_count = 0; return; end RESET_PARAMETERS; end receive_file_; 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