convert_string_.pl1 10/17/88 1109.1rew 10/17/88 1032.3 177678 /****^ *********************************************************** * * * 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. * * * *********************************************************** */ convert_string_: proc; /* Created by wholesale modification of tty_read 1/78 by D. Vinograd */ /* Modified by D. Vinograd, 11/78, to avoid calling canonicalize_ unless really necessary. */ /****^ HISTORY COMMENTS: 1) change(88-01-26,Brunelle), approve(88-01-26,MCR7813), audit(88-10-05,Blair), install(88-10-17,MR12.2-1171): Upgraded to handle special char sequences of 15 instead of 3 chars (c_chars). END HISTORY COMMENTS */ /* PARAMETERS */ dcl input_string char (*) var; dcl output_string char (*) var; dcl specp ptr; dcl seqp ptr; dcl mvtp ptr; dcl tctp ptr; dcl code fixed bin (35); /* AUTOMATIC */ dcl kill_char char (1); dcl erase_char char (1); dcl entry fixed bin; dcl escape_index fixed bin; dcl buffer_1 char (720) aligned; dcl buffer_2 char (720) aligned; dcl digit fixed bin; dcl break_found bit (1); dcl chars_moved bit (1); dcl source_ptr ptr; dcl target_ptr ptr; dcl old_sourcep ptr; dcl old_targetp ptr; dcl source_len fixed bin; dcl ret_len fixed bin; dcl target_len fixed bin; dcl xr fixed bin; /* used for result of index builtin */ dcl bx fixed bin; /* used in verify of white space */ dcl i fixed bin; /* temporary work variable */ dcl next_char char (1) aligned; dcl 1 seq based (seqp) aligned like c_chars; /* template of special chars sequence */ dcl 1 octal aligned, 2 pad bit (27) unal, 2 result fixed bin (8) unal; /* so arithmetic value can be easily addressed as char */ dcl 1 util aligned, /* structure passed to convert_string_util_$tct */ /* first 3 items in this structure are */ /* also used as general automatic variables */ 2 stringp ptr, 2 stringl fixed bin, 2 ctally fixed bin, 2 tablep ptr, 2 indicator fixed bin, 2 pad (3) fixed bin; /* workspace for convert_string_util_ */ /* INTERNAL STATIC CONSTANTS */ dcl backspace char (1) int static init ("") options (constant); /* backspace */ dcl space char (1) static init (" "); dcl tab char (1) static init (" "); dcl cr char (1) static init (" "); dcl input fixed bin static init (1); dcl output fixed bin static init (2); /* various strange-looking character strings */ dcl right_motion char (2) aligned int static options (constant) init (" "); /* HT, SP */ dcl nl char (1) aligned int static options (constant) init (" "); /* NL */ dcl bs char (1) aligned int static options (constant) init (""); /* BS */ dcl based_onechar char (1) based; /* ENTRIES */ dcl convert_string_util_$find_char entry (ptr); dcl canonicalize_ entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35)); dcl convert_string_util_$tct entry (ptr); dcl convert_string_util_$mvt entry (ptr); /* EXTERNAL STATIC */ dcl error_table_$improper_data_format ext static fixed bin (35); /* BASED */ dcl based_chars (0:10) char (1) unal based; dcl based_one_char char (1) unal based; dcl based_string char (util.stringl) based (util.stringp); dcl based_ret char (source_len) based (source_ptr); dcl based_source char (source_len) based (old_sourcep); dcl based_target char (target_len) based (old_targetp); dcl table (0: 127) fixed bin (8) unaligned based; dcl based_fb8 fixed bin (8) unal based; dcl 1 mvt_args aligned based (addr (util)), /* overlay of util structure for convert_string_util_$mvt */ 2 stringp ptr, 2 stringl fixed bin, 2 pad fixed bin, 2 tablep ptr, 2 targetp ptr; /* BUILTINS */ dcl (addr, index, null, substr, verify, length, reverse) builtin; %include remote_ttt_info; %include prt_info; %include prt_conv_info; %include tty_convert; input: entry (input_string, rttp, output_string, code); entry = input; mvtp = remote_ttt_info.input_mvtp; tctp = remote_ttt_info.input_tctp; goto common; output: entry (input_string, rttp, output_string, code); entry = output; mvtp = remote_ttt_info.output_mvtp; tctp = remote_ttt_info.output_tctp; common: specp = remote_ttt_info.specp; erase_char = remote_ttt_info.erase_char; kill_char = remote_ttt_info.kill_char; buffer_1 = input_string; buffer_2 = ""; source_ptr = addr (buffer_1); target_ptr = addr (buffer_2); source_len = length (input_string); /* the number of chars in buffer_1 now */ util.stringp = source_ptr; if entry = output then do; if remote_ttt_info.escape_output then call escape_output; if remote_ttt_info.translate_output then call translate; end; else do; if remote_ttt_info.translate_input then call translate; if remote_ttt_info.escape_input then call escape_input; if remote_ttt_info.erase_input then call erase; if remote_ttt_info.canonicalize_input & index (based_ret, cr || tab || backspace) ^= 0 then call canonicalize_ (source_ptr, source_len, source_ptr, source_len, code); end; ret_len = source_len; output_string = based_ret; finish: return; table_error: code = error_table_$improper_data_format; goto finish; translate: proc; if mvtp ^= null then do; mvt_args.stringp = source_ptr; mvt_args.stringl = source_len; mvt_args.tablep = mvtp; mvt_args.targetp = target_ptr; call convert_string_util_$mvt (addr (util)); /* this does the translation */ source_ptr = mvt_args.targetp; target_ptr = mvt_args.stringp; target_len = source_len; end; end translate; erase: proc; /* ** ERASE/KILL PROCESSING ** */ old_sourcep = source_ptr; old_targetp = target_ptr; if entry = output then do; util.ctally = 0; target_len = 0; util.stringl = source_len ; util.stringp = source_ptr; end; else do; util.stringl = source_len; util.stringp = source_ptr; end; /* kill first */ xr = 0; do while (xr < util.stringl); /* search from the right, only last kill is interesting */ xr = util.stringl - index (reverse (based_string), kill_char); if xr < util.stringl /* found one */ then do; xr = xr + 1; /* makes xr actual index of kill */ if ^escaped () /* it's a real kill */ then do; source_ptr, util.stringp = addr (util.stringp -> based_chars (xr)); /* point to char after kill */ source_len = source_len - xr; xr = util.stringl; /* so as not to index again */ end; else do; /* it was escaped, we must scan rest of string */ util.stringl = xr - 2; xr = 0; end; end; end; /* finished with kills */ /* now erase */ util.stringl = source_len; target_len = 0; xr = 1; do while (xr ^= 0 & util.stringl > 0); xr = index (based_string, erase_char); /* look for first erase */ if xr = 1 /* first char */ then do; if target_len ^= 0 /* if not first char in whole string */ then do; /* we have to erase some already copied chars */ bx = verify (reverse (based_target), right_motion); /* skip white space */ if bx = 0 /* all white */ then do; target_ptr = old_targetp; /* wipe it all out */ target_len = 0; end; else do; if bx ^= 1 /* there's some white space */ then util.ctally = bx - 1; /* we'll erase it all */ /* no white, check for overstrikes */ else do util.ctally = 1 to target_len - 2 by 2 while (substr (based_target, target_len-util.ctally, 1) = bs); end; target_len = target_len - util.ctally; target_ptr = addr (old_targetp -> based_chars (target_len)); end; end; if target_len <= 0 /* we erased whole target string */ then source_len = util.stringl - 1; end; /* not first char, see if it's escaped */ else if xr ^= 0 then do; if escaped () then util.ctally = xr; /* copy everything */ else do; bx = verify (reverse (substr (based_string, 1, xr-1)), right_motion); if bx = 0 /* all white */ then util.ctally = 0; /* copy nothing */ else if bx ^= 1 /* some white */ then util.ctally = xr - bx; /* which will not be copied */ else do util.ctally = xr - 2 to 2 by -2 while (substr (based_string, util.ctally, 1) = bs); end; end; if util.ctally > 0 then call copy_chars; else source_len = source_len - xr; end; if xr > 0 /* if we're going around again */ then do; source_ptr, util.stringp = addr (util.stringp -> based_chars (xr)); /* point past erase */ util.stringl = util.stringl - xr; end; end; /* end of erase search */ if target_len > 0 /* if we moved any */ then do; if util.stringl > 0 /* if there are any more */ then do; util.ctally = util.stringl; call copy_chars; end; source_len = target_len ; source_ptr = old_targetp; target_ptr = old_sourcep; /* switch buffers */ end; end erase; escape_output: proc; if tctp ^= null /* must have output conversion table */ & specp ^= null /* and special chars table too */ then do; old_targetp = target_ptr; old_sourcep = source_ptr; chars_moved = "0"b; util.tablep = tctp; target_len = 0; /* initially */ util.ctally = 0; util.stringp = source_ptr; util.stringl = source_len ; do while (util.stringl > 0); /* main formatting loop */ call convert_string_util_$find_char (addr (util)); /* find next interesting character */ if util.indicator = 0 & util.stringl = 0 & ^chars_moved then; /* nothing found */ else do; chars_moved = "1"b; /* we'll have to do some moving */ if util.ctally > 0 /* we have some uninteresting ones to pick up */ then call copy_chars; /* do it */ /* now examine indicator */ if util.indicator = 0 /* no interesting characters */ then; /* otherwise go around again */ else if util.indicator = 3 /* tab or multiple blank */ then do; util.ctally = 1; do while (util.stringl > 0 & (util.stringp -> based_onechar = space | util.stringp -> based_onechar = tab)); call copy_chars; util.stringl = util.stringl - 1; util.stringp = addr (util.stringp -> based_chars (1)); end; end; else if util.indicator > 16 then do; /* special escape sequence */ escape_index = util.indicator - 16; if escape_index > specp -> special_chars.escape_length /* not a good index */ then goto table_error; if remote_ttt_info.edited then seqp = addr (specp -> special_chars.edited_escapes (escape_index)); else seqp = addr (specp -> special_chars.not_edited_escapes (escape_index)); call insert_sequence ; end; else goto table_error; if util.stringl > 0 /* if we're going around again */ then source_ptr = util.stringp; /* update source pointer */ end; end; if target_len ^= 0 then do; source_ptr = old_targetp; source_len = target_len ; target_ptr = old_sourcep; end; end; return; end escape_output; escape_input: proc; /* ** ESCAPE AND BREAK PROCESSING ** */ if tctp ^= null /* can't do this without input conversion table */ then do; old_targetp = target_ptr; target_len = 0; break_found = "0"b; util.stringp = source_ptr; util.stringl = source_len; util.tablep = tctp; do while (util.stringl > 0); call convert_string_util_$tct (addr (util)); /* scan string */ if util.indicator = 0 & util.stringl = 0 & target_len = 0 /* never no nothing */ then; else do; /* there's work to do */ if util.ctally > 0 /* copy uninteresting characters */ then do; old_sourcep = source_ptr; call copy_chars; end; if util.indicator = 0 then; else if util.indicator = 1 /* break char */ then do; break_found = "1"b; /* it can't be escaped or we'd have found the escape */ if util.ctally > 0 /* scan back for preceding white space */ then do; bx = verify (reverse (substr (based_source, 1, util.ctally)), right_motion) - 1; if bx < 0 /* all white */ then bx = util.ctally; if bx > 0 /* any white */ then do; target_len = target_len - bx; target_ptr = addr (old_targetp -> based_chars (target_len)); end; end; /* target_ptr shows where to put nl now in any case */ go to insert_and_update; end; else if util.indicator = 2 /* escape char */ then do; if util.stringl <= 1 /* there's nothing after it */ then go to insert_and_update; if util.ctally > 0 /* check for overstruck escape */ then do; i = -1; /* necessary to make compiler accept next statement */ if util.stringp -> based_chars (i) = bs then go to insert_and_update; end; next_char = util.stringp -> based_chars (1); if next_char = bs then go to insert_and_update; if util.stringl > 2 /* check for following character overstruck */ then if util.stringp -> based_chars (2) = bs then go to insert_and_update; if tctp -> table (addr (next_char) -> based_fb8) = 2 | /* next char is escape */ next_char = erase_char | next_char = kill_char then do; util.stringp = addr (util.stringp -> based_chars (1)); /* skip over escape */ util.stringl = util.stringl - 1; go to insert_and_update; /* put in following char as is */ end; /* check for octal escape */ digit = char_value (next_char); if digit >= 0 then do; /* we have octal digit(s) */ octal.result = 0; util.stringp = addr (util.stringp -> based_chars (1)); /* look at next */ do i = 1 to 3 while (digit >= 0); octal.result = 8*octal.result + digit; if util.stringl > i & i < 3 then do; digit = char_value ((util.stringp -> based_chars (i))); if digit >= 0 /* next char is digit, see if it's overstruck */ then if util.stringl > i + 1 then if util.stringp -> based_chars (i+1) = bs then digit = -1; end; else digit = -1; /* no more chars, or we already have 3 */ end; call insert_char ((addr (octal.result) -> based_one_char)); util.stringp = addr (util.stringp -> based_chars (i-1)); /* skip over octal digits */ util.stringl = util.stringl - i; end; /* check for escaped nl with white space */ else if verify (substr (based_string, 2, util.stringl-2), right_motion) = 0 & substr (based_string, util.stringl, 1) = nl then do; if util.stringl = source_len /* first thing in the string? */ then source_len = 0; /* then nothing */ util.stringl = 0; /* we've reached end */ end; else do; /* look up next_char in input escape table */ if specp = null /* no table means no escapes */ | specp -> special_chars.input_escapes.len = 0 then go to insert_and_update; xr = index (specp -> special_chars.input_escapes.str, next_char); if xr ^= 0 /* it's there */ then do; call insert_char ((substr (specp -> special_chars.input_results.str, xr, 1))); util.stringp = addr (util.stringp -> based_chars (2)); /* move ptr */ util.stringl = util.stringl - 2; end; else go to insert_and_update; end; end; /* of escape character */ else if util.indicator = 3 /* throw away */ then call skip (1); else if util.indicator = 4 /* form feed */ then do; insert_and_update: call insert_char ((util.stringp -> based_one_char)); util.stringp = addr (util.stringp -> based_chars (1)); util.stringl = util.stringl - 1; end; else if util.indicator = 5 /* hardware control sequence */ then ; else goto table_error; /* what else could it be? */ source_ptr = util.stringp; end; end; /* of tct loop */ if target_len ^= 0 then do; source_ptr = old_targetp; source_len = target_len; end; end; end escape_input; /* ** INTERNAL PROCEDURES ** */ copy_chars: proc; /* this procedure copies util.ctally characters from source_ptr to target_ptr. It updates both pointers */ /* and increments target_len by util.ctally */ dcl tally_chars char (util.ctally) based; target_ptr -> tally_chars = source_ptr -> tally_chars; source_ptr = addr (source_ptr -> based_chars (util.ctally)); target_ptr = addr (target_ptr -> based_chars (util.ctally)); target_len = target_len + util.ctally; return; end copy_chars; insert_char: proc (i_char); /* this procedure inserts one character at target_ptr, and increments target_ptr and target_len by one character */ dcl i_char char (1) ; target_ptr -> based_one_char = i_char; target_ptr = addr (target_ptr -> based_chars (1)); target_len = target_len + 1; return; end insert_char; skip: proc (to_skip); /* this procedure discards a specified number of characters from util.stringp */ dcl to_skip fixed bin; util.stringp = addr (util.stringp -> based_chars (to_skip)); /* skip over character */ if source_len = util.stringl /* if it's first character in the string */ then source_len = source_len - to_skip; /* then make sure it doesn't get picked up */ util.stringl = util.stringl - to_skip; end skip; escaped: proc returns (bit (1) aligned); /* this procedure returns "1"b if the character at index xr in the string based on util.stringp */ /* is preceded by a non-overstruck escape character; otherwise it returns "0"b */ if xr <= 1 /* no preceding character */ then return ("0"b); if tctp = null /* no conversion table so no escapes */ then return ("0"b); if tctp -> table (addr (substr (based_string, xr-1, 1)) -> based_fb8) ^= 2 /* not preceded by an escape */ then return ("0"b); if xr = 2 /* escape can't be overstruck, it's first char */ then return ("1"b); if substr (based_string, xr-2, 1) = bs /* escape is overstruck */ then return ("0"b); else return ("1"b); end escaped; char_value: proc (a_char) returns (fixed bin); /* this procedure returns the numeric equivalent of an ASCII character if the character is 0 to 7; */ /* otherwise it returns -1 */ dcl a_char char (1) aligned; dcl numeric fixed bin; numeric = addr (a_char) -> based_fb8; if numeric >= 48 /* i.e., "0" */ & numeric <= 55 /* i.e., "7" */ then return (numeric - 48); else return (-1); end char_value; insert_sequence: proc ; /* This procedure inserts the character sequence pointed to by seqp */ dcl i fixed bin; if seq.count = 0 then return; /* no sequence */ if seq.count < 0 | seq.count > hbound (seq.chars, 1) /* probably not a real sequence */ then go to table_error; target_len = target_len + seq.count; do i = 1 to seq.count; target_ptr -> based_onechar = seqp -> seq.chars (i); target_ptr = addr (target_ptr -> based_chars (1)); /* bump pointer */ end; return; end insert_sequence ; end convert_string_;  convert_string_util_.alm 11/15/82 1900.8rew 11/15/82 1535.0 81864 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name convert_string_util_ " " " " " " " " " " " " " " " " " " " " " " " " " " " Utilities for the tty DIM. " " These routines perform certain scanning and editing " functions for the tty DIM which are faster and " easier to do in ALM. " " Coded 10/15/75 by Mike Grady " " " " " " " " " " " " " " " " " " " " " " " " " " segdef find_char segdef mvt segdef scm segdef illegal_char segdef tct " symbols for storage in callers automatic storage equ stringp,0 equ stringl,2 equ tally,3 equ tablep,4 equ bit,4 equ match,5 equ indicator,6 equ targetp,6 " some temporary storage also in callers stack frame equ w1,8 equ w2,9 " " " " " " " " " " " " " " " " " " " " " " " " " " " " find_char finds the next interesting char for the " caller. It looks first for high bits (> 177) and " then for double blanks, and finally for chars in " a tct table. " " Input: " stringp - pointer to string to scan " stringl - length of string " tablep - pointer to table to use for tct " " Output: " tally - number of uninteresting chars " indicator - number which indicates char found " 3 for white space " 7 for escape char " value from tct otherwise " " " " " " " " " " " " " " " " " " " " " " " " " " find_char: epp1 pr0|2,* get ptr to block of storage in epp1 pr1|0,* callers stack epp2 pr1|stringp,* load ptr to string ldq pr1|stringl load string length cmpq 2000,dl use min(stringl,2000) to be quick tmi 2,ic all set ldq 2000,dl stz pr1|tally zero tally tsx2 find_high_bits look for interesting bits tra look_for_blanks none, continue ldq pr1|w1 get result tze have_high_bit first char - done look_for_blanks: scd (pr,rl),(du) look for two blanks desc9a pr2|0,ql aci " " arg pr1|w2 store result here ttn no_double_blanks none in string lda pr1|w2 get length up to double blanks ora =o400000,du set high order bit as flag sta pr1|w1 save as count ldq pr1|w2 reduce stringl again no_double_blanks: epp3 pr1|tablep,* load table pointer tct (pr,rl) look into tct table for interesting chars desc9a pr2|0,ql arg pr3|0 arg pr1|w2 ttf tct_hit we got hit in tct, process lda 3,dl get indicator value szn pr1|w1 any high bits or double blanks? tze return_full_string no, return the whole thing tmi 2,ic double blanks found have_high_bit: lda 7,dl get indicator for \nnn type sta pr1|indicator return it to caller lxl0 pr1|w1 get count sxl0 pr1|tally tra tct_done done tct_hit: lda pr1|w2 get char value hit on arl 27 shift down sta pr1|indicator return to caller cmpa 5,dl one of the special types? tpl return_normal nope lxl0 pr1|w2 get the count tze return_normal hit on first char in string sblx0 1,du decrement the count to point a prev char cmpc (pr,x0),(),fill(0) desc9a pr2|0,1 look for blank desc9a blank,1 tnz return_normal not blank, all ok lda 3,dl get blank indicator sta pr1|indicator return to caller sxl0 pr1|tally set tally to blank locn tra tct_done done return_normal: lxl0 pr1|w2 get the count from the tct sxl0 pr1|tally return to caller tra tct_done done return_full_string: stq pr1|tally use whole thing stz pr1|indicator set indicator tct_done: ldq pr1|tally get tally lda pr1|indicator load the indicator tze tct_nbump zero, no bump cmpa 3,dl is it blank? tze tct_nbump yes, done cmpa 7,dl is it escape char type? tze tct_nbump yes, done adq 1,dl bump input char count tct_nbump: a9bd pr2|0,ql bump ptr spri2 pr1|stringp stq pr1|w1 store for subtract lda pr1|stringl get stringl sba pr1|w1 decrement sta pr1|stringl reset stringl short_return blank: aci " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " this routine does an mvt to translate chars. " " Input: " stringp - points to input string " stringl - length of string " tablep - pointer to translate table " " Output: " targetp - pointer to output string " " " " " " " " " " " " " " " " " " " " " " " " " " mvt: epp1 pr0|2,* get ptr to arg ptr epp1 pr1|0,* get ptr to callers block epp2 pr1|stringp,* get ptr to the string ldq pr1|stringl load length of string epp3 pr1|tablep,* load ptr to mvt table epp5 pr1|targetp,* get ptr to target string mvt (pr,rl),(pr,rl),fill(0) do the mvt desc9a pr2|0,ql desc9a pr5|0,ql arg pr3|0 short_return that was easy " " " " " " " " " " " " " " " " " " " " " " " " " " " " routine to scan for high bits in chars and return ptr to " matched char. " " Input: " stringp - points to string " stringl - length " bit - bit pattern looked for " " Output: " tally - number of chars to char with bit " match - "1"b if bit matched " " " " " " " " " " " " " " " " " " " " " " " " " " scm: epp1 pr0|2,* get ptr to arg ptr epp1 pr1|0,* get ptr to arg block epp2 pr1|stringp,* get ptr to string ldq pr1|stringl get string length stz pr1|match indicate initial failure lda pr1|bit look at the bit we want ana =o400000,du use it to select scm tnz scm4 on, we want highest bit scm (pr,rl),(pr),mask(577) off, we must want bit 8 desc9a pr2|0,ql arg pr1|bit arg pr1|tally tra scm_ck look at results scm4: scm (pr,rl),(pr),mask(377) scan string for 9th bit desc9a pr2|0,ql arg pr1|bit arg pr1|tally result scm_ck: ttn scm_done no hits lda =o400000,du get flag bit sta pr1|match indicate success scm_done: sbq pr1|tally reduce stringl stq pr1|stringl return to caller ldq pr1|tally fetch tally word a9bd pr2|0,ql bump stringp spri2 pr1|stringp store for caller short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " routine to look for any char with bit 8 or 9 on. " " Input: " stringp - points to string " stringl - length " " Output: " tally - number of chars up to bad one " match - if bad one found "1"b " " " " " " " " " " " " " " " " " " " " " " " " " " illegal_char: epp1 pr0|2,* get ptr to ptr to block epp1 pr1|0,* get ptr to block epp2 pr1|stringp,* get ptr to string ldq pr1|stringl get length stz pr1|match zero return bit stq pr1|tally set max tally tsx2 find_high_bits see if any high bits on tra no_illegal_chars none, continue lxl0 pr1|w1 get the result sxl0 pr1|tally return lda =o400000,du get match bit sta pr1|match no_illegal_chars: sbq pr1|tally reduce stringl stq pr1|stringl return to caller ldq pr1|tally fetch tally word a9bd pr2|0,ql bump stringp spri2 pr1|stringp store for caller short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " routine to do input tct function, similar to " find_char, but does only tct function " " " " " " " " " " " " " " " " " " " " " " " " " " tct: epp1 pr0|2,* get ptr to arg ptr epp1 pr1|0,* get ptr to arg block epp2 pr1|stringp,* get ptr to string ldq pr1|stringl get string length stz pr1|tally zero the tally word epp3 pr1|tablep,* get ptr to table tct (pr,rl) do the tct desc9a pr2|0,ql arg pr3|0 arg pr1|w2 result goes here ttn tct_nohit no good chars lda pr1|w2 get the indicator value arl 27 shift down sta pr1|indicator lxl0 pr1|w2 get the tally sxl0 pr1|tally ldq pr1|tally load tally for ptr update tra tct_ptr_inc tct_nohit: stq pr1|tally return whole string stz pr1|indicator no indicator tct_ptr_inc: a9bd pr2|0,ql spri2 pr1|stringp return ptr lda pr1|stringl get string length sba pr1|tally reduce amount processed sta pr1|stringl short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " internal proc to find high bits. " return+1 -> none found " return+2 -> high bit found " " " " " " " " " " " " " " " " " " " " " " " " " " find_high_bits: scm (pr,rl),(du),mask(377) look for chars with bit9 on desc9a pr2|0,ql vfd o9/400,27/0 arg pr1|w1 result here ttn scm_other_bit not this one try bit8 szn pr1|w1 did we hit on first char? tze found_first_bit yes, return scm (pr,rl),(du),mask(577) look for bit8 on desc9a pr2|0,ql vfd o9/200,27/0 arg pr1|w2 save result ttn check_which_bit not bit8, must be bit9 tra found_other_bit scm_other_bit: scm (pr,rl),(du),mask(577) look for bit8 on desc9a pr2|0,ql vfd o9/200,27/0 arg pr1|w2 save result ttn no_high_bits good, neither bit8 or 9 was on found_other_bit: szn pr1|w2 did we hit first char? tnz check_which_bit no, find which one stz pr1|w1 indicate offset of zero in w1 tra found_first_bit return info check_which_bit: lda pr1|w2 get second count cmpa pr1|w1 compare with first tpl 2,ic more, use w1 sta pr1|w1 less use w2 as length found_first_bit: tra 1,2 return no_high_bits: stz pr1|w1 reset the high bits indicator tra 0,2 return end  get_ttt_info_.pl1 10/17/88 1109.1r w 10/17/88 1034.1 24129 /****^ *********************************************************** * * * 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. * * * *********************************************************** */ /****^ 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. END HISTORY COMMENTS */ get_ttt_info_: proc (rttp, code); dcl code fixed bin (35); dcl 1 local_terminal_type_data like terminal_type_data; dcl ttt_info_$terminal_data entry (char (*) aligned, fixed bin, fixed bin, ptr, fixed bin (35)); dcl (addr, null) builtin; %include remote_ttt_info; %include prt_conv_info; %include prt_info; %include tty_convert; %include terminal_type_data; ttdp = addr (local_terminal_type_data); terminal_type_data.version = ttd_version_3; call ttt_info_$terminal_data (remote_ttt_info.terminal_type, -1, 300, ttdp, code); if code ^= 0 then return; if terminal_type_data.input_tr_ptr ^= null then remote_ttt_info.input_mvtp = addr (terminal_type_data.input_tr_ptr -> cv_trans_struc.cv_trans); if terminal_type_data.output_tr_ptr ^= null then remote_ttt_info.output_mvtp = addr (terminal_type_data.output_tr_ptr -> cv_trans_struc.cv_trans); if terminal_type_data.input_cv_ptr ^= null then remote_ttt_info.input_tctp = addr (terminal_type_data.input_cv_ptr -> cv_trans_struc.cv_trans); if terminal_type_data.output_cv_ptr ^= null then remote_ttt_info.output_tctp = addr (terminal_type_data.output_cv_ptr -> cv_trans_struc.cv_trans); if terminal_type_data.input_cv_ptr ^= null then remote_ttt_info.input_tctp = addr (terminal_type_data.input_cv_ptr -> cv_trans_struc.cv_trans); if terminal_type_data.special_ptr ^= null then remote_ttt_info.specp = addr (terminal_type_data.special_ptr -> special_chars_struc.special_chars); remote_ttt_info.specp = addr (terminal_type_data.special_ptr -> special_chars_struc.special_chars); remote_ttt_info.erase_char = terminal_type_data.erase; remote_ttt_info.kill_char = terminal_type_data.kill; return; end get_ttt_info_;  iodd_hblp_banner_pages_.pl1 11/14/88 1106.2rew 11/14/88 1100.1 387135 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * ******************************************** */ /****^ HISTORY COMMENTS: 1) change(88-07-25,Brunelle), approve(88-07-25,MCR7911), audit(88-10-25,Wallman), install(88-11-08,MR12.2-1199): Created 2) change(88-11-03,Brunelle), approve(88-11-03,MCR7911), audit(88-11-08,Wallman), install(88-11-08,MR12.2-1199): Removed code to put box around charges on tail sheet. 3) change(88-11-14,Brunelle), approve(88-11-14,PBF7911), audit(88-11-14,Wallman), install(88-11-14,MR12.2-1212): Handle null ptr to ordata if printing separator only and output the separator only message in the aim display area. END HISTORY COMMENTS */ /* format: style4 */ /* head and tail sheet programs for the Honeywell Bull model 80 laser printers liberally taken from head_sheet_ and tail_sheet_ */ iodd_hblp_banner_pages_: proc; /* no entry here */ return; /* Parameters */ dcl a_code fixed bin (35) parameter; /* Return error code */ dcl a_message char (*) parameter; dcl a_ordatap ptr parameter; /* ptr to output_request_data */ dcl a_prt_ctl_ptr pointer parameter; /* pointer to prt_ctl */ dcl a_switch pointer parameter; /* IOCB ptr for same */ /* External Procedures & Variables */ dcl bigletter_$five entry (char (*), entry); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$modes entry (pointer, char (*), char (*), fixed bin (35)); dcl iox_$put_chars entry (pointer, pointer, fixed bin (21), fixed bin (35)); dcl system_info_$installation_id entry (char (*) aligned); dcl system_info_$max_rs_number entry (fixed bin); dcl system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)); /* Builtins */ dcl (addr, after, before, byte, divide, hbound, length, ltrim, max, null, reverse, rtrim, string, substr) builtin; /* Internal Static */ dcl CR char (1) defined CR_NL_FF position (1); dcl CR_NL char (2) defined CR_NL_FF position (1); dcl FF char (1) defined CR_NL_FF position (3); /* The following line is defined with CR NL FF */ dcl CR_NL_FF char (3) int static options (constant) init (" "); dcl HEAD fixed bin int static options (constant) init (1); dcl SEPARATOR fixed bin int static options (constant) init (3); dcl TAIL fixed bin int static options (constant) init (2); dcl copy_offset fixed bin int static; /* where to put the copy number data for copy 2, 3,... */ dcl installation char (32) aligned int static; /* Local installation ID */ dcl last_request_no fixed bin int static; /* request number of the last request */ dcl max_rs_number fixed bin int static init (-1); /* maximum rate structure number */ dcl rs_names (-1:9) char (32) static int init ((11) ("tail_sheet_ uninitialized")); dcl sysdir char (168) int static init (">daemon_dir_dir>io_daemon_dir"); dcl templates_ptr ptr int static init (null); dcl time_format char (64) internal static options (constant) init ("^dn, ^dm ^mn ^9999yc, ^Hd:^MH ^za"); dcl TOP_RQT_LINE fixed bin internal static options (constant) init (1); dcl BOTTOM_RQT_LINE fixed bin internal static options (constant) init (2); dcl TOP_SHORT_PATH fixed bin internal static options (constant) init (3); dcl BOTTOM_SHORT_PATH fixed bin internal static options (constant) init (4); dcl TOP_LONG_PATH fixed bin internal static options (constant) init (5); dcl BOTTOM_LONG_PATH fixed bin internal static options (constant) init (6); dcl ACCESS_CLASS fixed bin internal static options (constant) init (7); dcl BIG_ACCESS_CLASS fixed bin internal static options (constant) init (8); dcl HS_DATE_INSTALLATION fixed bin internal static options (constant) init (9); dcl HS_BIG_DESTINATION fixed bin internal static options (constant) init (10); dcl HS_BIG_HEADER fixed bin internal static options (constant) init (11); dcl HS_HEAD_DESTINATION fixed bin internal static options (constant) init (12); dcl HS_LANDSCAPE_DEST fixed bin internal static options (constant) init (13); dcl HS_LANDSCAPE_HEAD fixed bin internal static options (constant) init (14); dcl TS_TIME_REQUESTED fixed bin internal static options (constant) init (15); dcl TS_TIME_OUTPUT fixed bin internal static options (constant) init (16); dcl TS_OUTPUT_MODE fixed bin internal static options (constant) init (17); dcl TS_FORMS_CONTROL fixed bin internal static options (constant) init (18); dcl TS_RQT_QUEUE fixed bin internal static options (constant) init (19); dcl TS_HEAD_DESTINATION fixed bin internal static options (constant) init (20); dcl TS_PAGE_CHARGE fixed bin internal static options (constant) init (21); dcl TS_LINE_CHARGE fixed bin internal static options (constant) init (22); dcl TS_CHARGE_TO fixed bin internal static options (constant) init (23); dcl TS_RATE_STRUCTURE fixed bin internal static options (constant) init (24); /* Automatic */ dcl (i, j, n) fixed bin; /* misc indices */ dcl advert_bc fixed bin (24); /* bitcount of advertising page */ dcl advert_ptr ptr; /* ptr to advertising page */ dcl buffer char (buffer_length) based (buffer_ptr); /* current output buffer */ dcl buffer_length fixed bin (21) based (buffer_length_ptr);/* length of output buffer */ dcl buffer_ptr ptr; /* ptr to current output buffer */ dcl buffer_length_ptr ptr; /* ptr to current length of output buffer */ dcl calc_page_charge float bin; /* temporary storage for page charge */ dcl calc_line_charge float bin; /* temporary storage for line charge */ dcl dest char (64) aligned; /* temp destination string */ dcl head char (64) aligned; dcl iocbp pointer; /* ptr to IOCB to output on */ dcl line_75_chars char (75); dcl line_90_chars char (90); dcl message char (200) var; /* internal copy of message to output */ dcl real_page_count fixed bin; /* Actual page count taking -no_separator into account. */ dcl real_line_count fixed bin; /* Actual line count taking -no_separator into account. */ dcl temp char (280) aligned; /* temp copy of message */ dcl xcode fixed bin (35); /* Based */ dcl 1 templates based (templates_ptr), 2 head_sheet, 3 lngth fixed bin (21), 3 strng char (4096), 2 tail_sheet, 3 lngth fixed bin (21), 3 strng char (4096), 2 access_class, 3 lngth fixed bin (21), 3 strng char (1024), 2 current_head_sheet, 3 lngth fixed bin (21), 3 strng char (8192), 2 current_tail_sheet, 3 lngth fixed bin (21), 3 strng char (8192), 2 position (24), 3 horizontal fixed bin (17) unaligned, 3 vertical fixed bin (17) unaligned; %page; /* output the front banner page for the output request. the head_sheet_ entrypoint has not been reproduced here since it was an old entrypoint used in the ios_ days */ print_head_sheet: entry (a_switch, a_prt_ctl_ptr, a_ordatap, a_code); iocbp = a_switch; a_code = 0; /* no errors yet */ ordatap = a_ordatap; /* locate data about the output request */ dmp = ordata.dpmp; /* get ptr to dprint_msg */ call create_head_sheet; if a_code ^= 0 then return; call print_the_banner_page (HEAD); return; %page; /* output the back banner page for the output request. the tail_sheet_ entrypoint has not been reproduced here since it was an old entrypoint used in the ios_ days */ print_tail_sheet: entry (a_switch, a_prt_ctl_ptr, a_ordatap, a_code); iocbp = a_switch; a_code = 0; /* no errors yet */ ordatap = a_ordatap; /* locate data about the output request */ dmp = ordata.dpmp; /* get ptr to dprint_msg */ call create_tail_sheet; if a_code ^= 0 then return; call print_the_banner_page (TAIL); return; %page; /* output a separator page. the separator entrypoint has not been reproduced here since it was an old entrypoint used in the ios_ days. */ print_separator: entry (a_switch, a_prt_ctl_ptr, a_message, a_code); iocbp = a_switch; ordatap = null; /* this is not a real request for head_sheet */ message = ltrim (rtrim (a_message)); /* copy and clean the message */ a_code = 0; call create_head_sheet; /* build a dummy head sheet page */ if a_code ^= 0 then return; last_request_no = -1; /* mark last head sheet as destroyed */ copy_offset = 0; /* if the message is real, center it using small bigletters */ if message ^= "" then do; temp = ltrim (rtrim (message)); /* strip leading & trailing spaces */ i = length (temp); /* real message length */ head = ""; /* clear the heading */ /* Switch to 12 pitch and 8 LPI to make bigletters more readable. */ Select_font.body = 2; call output_string (string (Select_font)); call output_string (Set_default_hmi); Set_vmi.body = byte (7); call output_string (string (Set_vmi)); Absolute_vertical_position.body = templates.position (BIG_ACCESS_CLASS).vertical; call output_string (string (Absolute_vertical_position)); substr (head, max (1, divide (13 - i, 2, 17) + 1)) = substr (temp, 1, 13); call bigletter_$five (substr (head, 1, 13), output_bigletters); /* write the big message */ end; /* add control chars to make the head sheet print */ call output_string (CR); call output_string (FF); call print_the_banner_page (SEPARATOR); return; %page; /* tail_save.pl1 for the tail_sheet_ code goes here */ %page; /* ------- INIT ENTRY ------- */ init: entry (); last_request_no = 0; return; /* ------- SET CTL ENTRY ------- */ set_ctl: entry (a_prt_ctl_ptr, a_code); /* This entry is used to get data on how the head sheet is to be aligned and how banner bars are to be printed */ /* we ignore since it has no meaning for us */ a_code = 0; return; /* ------- TEST ENTRY ------- */ test: entry (a_sys_dir); /* define new directory to locate the advertising page in */ dcl a_sys_dir char (*); sysdir = a_sys_dir; /* for testing the new notice mechanism */ return; %page; build_templates: proc; /* this internal proc will create the buffer and set all the internal static values. It will create the head and tail sheet templates based on an 8.5 X 11 inch paper specification. There are a lot of numeric literal values here being plugged into many escape strings. These escape strings are for the Honeywell Bull Model 80 laser printer and are documented in the . PRU7260/7261/7262 Printer Programming Handbook . Order number HK12 */ a_code = 0; /* start clean */ if templates_ptr = null then do; /* initialize buffer seg in process dir */ call hcs_$make_seg ("", "banner_pages_.template", "", 01010b, templates_ptr, a_code); if templates_ptr = null then return; /* if it didn't work, return code to caller */ end; call hcs_$truncate_seg (templates_ptr, 0, a_code); if a_code ^= 0 then return; call system_info_$installation_id (installation); buffer_ptr = addr (templates.head_sheet.strng); buffer_length_ptr = addr (templates.head_sheet.lngth); buffer_length = 0; /* Both the head sheet and tail sheet have much in common, so we first generate the common part. */ /* initialize printer to known state */ call output_string (Soft_reset); /* Select Courier 10 font. */ Select_font.body = 1; call output_string (string (Select_font)); /* Set page orientation to portrait. */ Set_page_orientation.body = 1; /* Portrait */ call output_string (string (Set_page_orientation)); /* Set the left and right margins. */ Set_left_margin.body = 42; call output_string (string (Set_left_margin)); Set_right_margin.body = 942; call output_string (string (Set_right_margin)); /* Draw border box. The border box is 18/720 inches in width and slightly inside the page limits. */ Draw_box.left_edge = 180; Draw_box.top_edge = 0; Draw_box.right_edge = 5526; Draw_box.bottom_edge = 7542; Draw_box.line_width = 18; call output_string (string (Draw_box)); /* Draw necessary horizontal lines. Each line is 18/720 inches thick and begins just inside the left edge of the border box. All lines are the same length, ending at the inside of the right edge of the border box. The only difference in the lines is where they are drawn relative to the top limit. */ Draw_line.left_edge = 198; /* same for all lines */ Draw_line.right_edge = 5508; /* same for all lines */ Draw_line.bottom_edge = 18; /* same for all lines */ Draw_line.top_edge = 320; /* line 1 */ call output_string (string (Draw_line)); Draw_line.top_edge = 640; /* line 2 */ call output_string (string (Draw_line)); Draw_line.top_edge = 2364; /* line 5 */ call output_string (string (Draw_line)); Draw_line.top_edge = 2684; /* line 6 */ call output_string (string (Draw_line)); Draw_line.top_edge = 6902; /* line 7 */ call output_string (string (Draw_line)); Draw_line.top_edge = 7222; /* line 8 */ call output_string (string (Draw_line)); /* This is the end of the common head/tail sheet template. Copy what's done to the tail sheet string. */ templates.tail_sheet.lngth = buffer_length; templates.tail_sheet.strng = buffer; /* Add on the normal head sheet specific stuff. */ Draw_line.left_edge = 198; /* same for all lines */ Draw_line.right_edge = 5508; /* same for all lines */ Draw_line.bottom_edge = 18; /* same for all lines */ Draw_line.top_edge = 1342; /* line 3 */ call output_string (string (Draw_line)); Draw_line.top_edge = 1662; /* line 4 */ call output_string (string (Draw_line)); Assign_font.body.font_number = 5; Assign_font.body.orientation = 2; Assign_font.body.font_name = "LETTER GOTHIC 15"; call output_string (string (Assign_font.header)); call output_string (rtrim (string (Assign_font.body))); call output_string (string (Assign_font.trailer)); /* Generate normal tail sheet specific parts. */ /**** buffer_ptr = addr (templates.tail_sheet.strng); buffer_length_ptr = addr (templates.tail_sheet.lngth); Draw_box.left_edge = 430; Draw_box.top_edge = 773; Draw_box.right_edge = 4864; Draw_box.bottom_edge = 1440; Draw_box.line_width = 9; call output_string (string (Draw_box)); ****/ /* Now generate access class specific stuff. */ buffer_ptr = addr (templates.access_class.strng); buffer_length_ptr = addr (templates.access_class.lngth); buffer_length = 0; Draw_line.left_edge = 198; /* same for all lines */ Draw_line.right_edge = 5508; /* same for all lines */ Draw_line.bottom_edge = 18; /* same for all lines */ Draw_line.top_edge = 3386; call output_string (string (Draw_line)); Draw_line.top_edge = 3706; call output_string (string (Draw_line)); /* Finally, store the horizontal and vertical positions for the various text lines used in the head and tail sheets. */ templates.position (*).horizontal = 0; templates.position (*).vertical = 0; templates.position (TOP_RQT_LINE).vertical = 14; templates.position (BOTTOM_RQT_LINE).vertical = 494; templates.position (TOP_SHORT_PATH).vertical = 35; templates.position (BOTTOM_SHORT_PATH).vertical = 474; templates.position (TOP_LONG_PATH).vertical = 32; templates.position (BOTTOM_LONG_PATH).vertical = 470; templates.position (ACCESS_CLASS).vertical = 239; templates.position (BIG_ACCESS_CLASS).vertical = 193; templates.position (HS_BIG_DESTINATION).vertical = 57; templates.position (HS_HEAD_DESTINATION).vertical = 103; templates.position (HS_DATE_INSTALLATION).vertical = 171; templates.position (HS_BIG_HEADER).vertical = 125; templates.position (HS_LANDSCAPE_DEST).vertical, templates.position (HS_LANDSCAPE_HEAD).vertical = 8; templates.position (HS_LANDSCAPE_HEAD).horizontal = 1260; templates.position (TS_TIME_REQUESTED).horizontal = 120; templates.position (TS_TIME_REQUESTED).vertical = 62; templates.position (TS_TIME_OUTPUT).horizontal = 120; templates.position (TS_TIME_OUTPUT).vertical = 70; templates.position (TS_OUTPUT_MODE).horizontal = 120; templates.position (TS_OUTPUT_MODE).vertical = 86; templates.position (TS_FORMS_CONTROL).horizontal = 120; templates.position (TS_FORMS_CONTROL).vertical = 94; templates.position (TS_RQT_QUEUE).horizontal = 120; templates.position (TS_RQT_QUEUE).vertical = 150; templates.position (TS_PAGE_CHARGE).horizontal = 120; templates.position (TS_PAGE_CHARGE).vertical = 110; templates.position (TS_LINE_CHARGE).horizontal = 120; templates.position (TS_LINE_CHARGE).vertical = 118; templates.position (TS_CHARGE_TO).horizontal = 120; templates.position (TS_CHARGE_TO).vertical = 126; templates.position (TS_RATE_STRUCTURE).horizontal = 120; templates.position (TS_RATE_STRUCTURE).vertical = 134; templates.position (TS_HEAD_DESTINATION).vertical = 171; templates.current_head_sheet.strng, templates.current_tail_sheet.strng = ""; templates.current_head_sheet.lngth, templates.current_tail_sheet.lngth = 0; /* if we've never done it before, get all the rate_structure names. For RS numbers > max_rs_number, system_info_ will return a name of the form " INVALID_RS_n". */ if max_rs_number < 0 then do; call system_info_$max_rs_number (max_rs_number); do i = 0 to hbound (rs_names (i), 1); call system_info_$rs_name (i, rs_names (i), (0)); end; end; return; end build_templates; %page; create_head_sheet: proc; /* this is a special-purpose routine to generate the head sheet for the Honeywell Bull laser printer */ dcl copies_string char (22) aligned; /* temp string where we build "Copy X of Y" */ dcl copies_string_len fixed bin; /* length of copies_string */ dcl request_number char (20); /* space for the 1st header line */ dcl request_number_len fixed bin; /* length of valid chars in request_number */ if templates_ptr = null then do; call build_templates; if a_code ^= 0 then return; end; /* copy in the common portion of the head sheet into the buffer */ buffer_ptr = addr (templates.current_head_sheet.strng); buffer_length_ptr = addr (templates.current_head_sheet.lngth); buffer_length = templates.head_sheet.lngth; buffer = templates.head_sheet.strng; /* get out of no output request data to process */ if ordatap = null then return; /* if we need to display the access class, add the access class specific strings */ if ordata.access_class_string ^= "" then do; i = buffer_length; buffer_length = buffer_length + templates.access_class.lngth; substr (buffer, i + 1) = substr (templates.access_class.strng, 1, templates.access_class.lngth); end; /* Build the line with the request number, requestor, and optional copies. */ line_75_chars = ""; call ioa_$rsnnl ("^d", request_number, request_number_len, ordata.request_no); substr (line_75_chars, 1, request_number_len) = substr (request_number, 1, request_number_len); substr (line_75_chars, length (line_75_chars) - request_number_len + 1) = substr (request_number, 1, request_number_len); substr (line_75_chars, request_number_len + 5, 32) = ordata.requestor; if ordata.copies > 1 then do; if ordata.no_separator then call ioa_$rsnnl ("^d copies", copies_string, copies_string_len, ordata.copies); else call ioa_$rsnnl ("copy ^d of ^d", copies_string, copies_string_len, ordata.copy_no, ordata.copies); substr (line_75_chars, length (line_75_chars) - copies_string_len - request_number_len - 3, copies_string_len) = substr (copies_string, 1, copies_string_len); end; Absolute_vertical_position.body = templates.position (TOP_RQT_LINE).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (line_75_chars); Absolute_vertical_position.body = templates.position (BOTTOM_RQT_LINE).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (line_75_chars); /* Output the full pathname. If the pathname is longer than can be displayed on a single 10-pitch line (>75 characters), then switch to 12-pitch. If the pathname is longer than can be displayed on a single 12-pitch line (>90 characters), then display the pathname on two lines. */ if length (rtrim (ordata.full_path)) > length (line_75_chars) then do; /* switch to 12 pitch */ Select_font.body = 2; /* Elite 12 font */ call output_string (string (Select_font)); call output_string (Set_default_hmi); /* 12 pitch */ if length (rtrim (ordata.full_path)) > length (line_90_chars) then do; /* 2-line pathname */ Set_vmi.body = byte (7); /* 8 LPI */ call output_string (string (Set_vmi)); Absolute_vertical_position.body = templates.position (TOP_LONG_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (substr (ordata.full_path, 1, length (line_90_chars))); call output_string (CR_NL); call output_string (rtrim (substr (ordata.full_path, length (line_90_chars) + 1))); Absolute_vertical_position.body = templates.position (BOTTOM_LONG_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (substr (ordata.full_path, 1, length (line_90_chars))); call output_string (CR_NL); call output_string (rtrim (substr (ordata.full_path, length (line_90_chars) + 1))); end; else do; /* 1-line pathname */ Absolute_vertical_position.body = templates.position (TOP_SHORT_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.full_path)); call output_string (string (End_auto_center_mode)); Absolute_vertical_position.body = templates.position (BOTTOM_SHORT_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.full_path)); call output_string (string (End_auto_center_mode)); end; Select_font.body = 1; /* Courier 10 */ call output_string (string (Select_font)); call output_string (Set_default_hmi); /* 10 pitch */ end; else do; /* 1-line pathname, 10 pitch */ Absolute_vertical_position.body = templates.position (TOP_SHORT_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.full_path)); call output_string (string (End_auto_center_mode)); Absolute_vertical_position.body = templates.position (BOTTOM_SHORT_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.full_path)); call output_string (string (End_auto_center_mode)); end; /* Build the date/time string and installation identifier. */ line_75_chars = date_time_$format (time_format, ordata.time_start_request, "system_zone", "system_lang"); substr (line_75_chars, length (line_75_chars) - length (rtrim (installation)) + 1) = rtrim (installation); Absolute_vertical_position.body = templates.position (HS_DATE_INSTALLATION).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (line_75_chars); /* Print destination and header in shadowed big letters. */ if dprint_msg.destination = "" then dest = before (after (ordata.requestor, "."), "."); else dest = dprint_msg.destination; if dprint_msg.heading = "" then head = before (ordata.requestor, "."); else if substr (dprint_msg.heading, 1, 5) = " for " then head = substr (dprint_msg.heading, 6); else head = dprint_msg.heading; /* Switch to 12 pitch and 8 LPI to make bigletters more readable. */ Select_font.body = 2; call output_string (string (Select_font)); call output_string (Set_default_hmi); Set_vmi.body = byte (7); call output_string (string (Set_vmi)); Absolute_vertical_position.body = templates.position (HS_BIG_DESTINATION).vertical; call output_string (string (Absolute_vertical_position)); call bigletter_$five (rtrim (substr (dest, 1, 13)), output_bigletters); Absolute_vertical_position.body = templates.position (HS_BIG_HEADER).vertical; call output_string (string (Absolute_vertical_position)); call bigletter_$five (rtrim (substr (head, 1, 13)), output_bigletters); if ordata.access_class_string ^= "" then do; Absolute_vertical_position.body = templates.position (BIG_ACCESS_CLASS).vertical; call output_string (string (Absolute_vertical_position)); call bigletter_$five (rtrim (substr (ordata.access_class_string, 1, 13)), output_bigletters); end; Absolute_vertical_position.body = templates.position (HS_HEAD_DESTINATION).vertical; call output_string (string (Absolute_vertical_position)); if length (rtrim (head)) + length (rtrim (dest)) + 2 > length (line_75_chars) then do; line_90_chars = dest; substr (line_90_chars, length (line_90_chars) - length (rtrim (head)) + 1) = rtrim (head); call output_string (CR); call output_string (line_90_chars); end; else do; line_75_chars = dest; substr (line_75_chars, length (line_75_chars) - length (rtrim (head)) + 1) = rtrim (head); Select_font.body = 1; call output_string (string (Select_font)); call output_string (Set_default_hmi); Set_vmi.body = byte (9); call output_string (string (Set_vmi)); call output_string (CR); call output_string (line_75_chars); end; if ordata.access_class_string = "" then ; else do; Select_font.body = 1; call output_string (string (Select_font)); call output_string (Set_default_hmi); Set_vmi.body = byte (9); call output_string (string (Set_vmi)); Absolute_vertical_position.body = templates.position (ACCESS_CLASS).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.access_class_string)); call output_string (string (End_auto_center_mode)); end; /* Now switch to landscape orientation and print the destination/header. */ Set_page_orientation.body = 2; call output_string (string (Set_page_orientation)); Select_font.body = 5; call output_string (string (Select_font)); /* call output_string (Begin_proportional_mode); */ Absolute_horizontal_position.body = templates.position (HS_LANDSCAPE_DEST).horizontal; call output_string (string (Absolute_horizontal_position)); Absolute_vertical_position.body = templates.position (HS_LANDSCAPE_DEST).vertical; call output_string (string (Absolute_vertical_position)); call output_string (rtrim (dest)); Absolute_horizontal_position.body = templates.position (HS_LANDSCAPE_HEAD).horizontal; call output_string (string (Absolute_horizontal_position)); call output_string (Begin_backward_print_mode); call output_string (reverse (rtrim (head))); call output_string (End_backward_print_mode); /* call output_string (End_proportional_mode); */ /* add control strings so printer notice will print out in a reasonable manner */ Set_page_orientation.body = 1; call output_string (string (Set_page_orientation)); Select_font.body = 1; call output_string (string (Select_font)); call output_string (CR); call output_string (FF); return; end create_head_sheet; %page; create_tail_sheet: proc; /* this is a special-purpose routine to generate the tail sheet for the Honeywell Bull laser printer */ dcl copies_string char (22) aligned; /* temp string where we build "Copy X of Y" */ dcl copies_string_len fixed bin; /* length of copies_string */ dcl request_number char (20); /* space for the 1st header line */ dcl request_number_len fixed bin; /* length of valid chars in request_number */ if templates_ptr = null then do; call build_templates; if a_code ^= 0 then return; end; /* copy in the common portion of the tail sheet into the buffer */ buffer_ptr = addr (templates.current_tail_sheet.strng); buffer_length_ptr = addr (templates.current_tail_sheet.lngth); buffer_length = templates.tail_sheet.lngth; buffer = templates.tail_sheet.strng; /* if we need to display the access class, add the access class specific strings */ if ordata.access_class_string ^= "" then do; i = buffer_length; buffer_length = buffer_length + templates.access_class.lngth; substr (buffer, i) = substr (templates.access_class.strng, 1, templates.access_class.lngth); end; /* Build the line with the request number, requestor, and optional copies. */ line_75_chars = ""; call ioa_$rsnnl ("^d", request_number, request_number_len, ordata.request_no); substr (line_75_chars, 1, request_number_len) = substr (request_number, 1, request_number_len); substr (line_75_chars, length (line_75_chars) - request_number_len + 1) = substr (request_number, 1, request_number_len); substr (line_75_chars, request_number_len + 5, 32) = ordata.requestor; if ordata.copies > 1 then do; if ordata.no_separator then call ioa_$rsnnl ("^d copies", copies_string, copies_string_len, ordata.copies); else call ioa_$rsnnl ("copy ^d of ^d", copies_string, copies_string_len, ordata.copy_no, ordata.copies); substr (line_75_chars, length (line_75_chars) - copies_string_len - request_number_len - 3, copies_string_len) = substr (copies_string, 1, copies_string_len); end; Absolute_vertical_position.body = templates.position (TOP_RQT_LINE).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (line_75_chars); Absolute_vertical_position.body = templates.position (BOTTOM_RQT_LINE).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (line_75_chars); /* Output the full pathname. If the pathname is longer than can be displayed on a single 10-pitch line (>75 characters), then switch to 12-pitch. If the pathname is longer than can be displayed on a single 12-pitch line (>90 characters), then display the pathname on two lines. */ if length (rtrim (ordata.full_path)) > length (line_75_chars) then do; /* switch to 12 pitch */ Select_font.body = 2; /* Elite 12 font */ call output_string (string (Select_font)); call output_string (Set_default_hmi); /* 12 pitch */ if length (rtrim (ordata.full_path)) > length (line_90_chars) then do; /* 2-line pathname */ Set_vmi.body = byte (7); /* 8 LPI */ call output_string (string (Set_vmi)); Absolute_vertical_position.body = templates.position (TOP_LONG_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (substr (ordata.full_path, 1, length (line_90_chars))); call output_string (CR_NL); call output_string (rtrim (substr (ordata.full_path, length (line_90_chars) + 1))); Absolute_vertical_position.body = templates.position (BOTTOM_LONG_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (substr (ordata.full_path, 1, length (line_90_chars))); call output_string (CR_NL); call output_string (rtrim (substr (ordata.full_path, length (line_90_chars) + 1))); end; else do; /* 1-line pathname */ Absolute_vertical_position.body = templates.position (TOP_SHORT_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.full_path)); call output_string (string (End_auto_center_mode)); Absolute_vertical_position.body = templates.position (BOTTOM_SHORT_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.full_path)); call output_string (string (End_auto_center_mode)); end; Select_font.body = 1; /* Courier 10 */ call output_string (string (Select_font)); call output_string (Set_default_hmi); /* 10 pitch */ end; else do; /* 1-line pathname, 10 pitch */ Absolute_vertical_position.body = templates.position (TOP_SHORT_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.full_path)); call output_string (string (End_auto_center_mode)); Absolute_vertical_position.body = templates.position (BOTTOM_SHORT_PATH).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.full_path)); call output_string (string (End_auto_center_mode)); end; line_75_chars = "Requested: " || rtrim (date_time_$format (time_format, dprint_msg.msg_time, "system_zone", "system_lang")); call output_position_and_string (TS_TIME_REQUESTED, rtrim (line_75_chars)); line_75_chars = "Output: " || rtrim (date_time_$format (time_format, ordata.time_start_request, "system_zone", "system_lang")); call output_position_and_string (TS_TIME_OUTPUT, rtrim (line_75_chars)); if ordata.output_mode ^= "" then do; call output_position_and_string (TS_OUTPUT_MODE, "Output mode: " || rtrim (ordata.output_mode)); end; if dprint_msg.version < dprint_msg_version_5 then do; if dprint_msg.forms ^= "" then call output_position_and_string (TS_FORMS_CONTROL, "Forms control: " || rtrim (dprint_msg.forms)); end; else if dprint_msg.forms_name_lth > 0 then call output_position_and_string (TS_FORMS_CONTROL, "Forms control: " || dprint_msg.forms_name); call ioa_$rsnnl ("^a queue ^d^12x^a", temp, j, ordata.request_type, ordata.queue, ordata.device_name); call output_position_and_string (TS_RQT_QUEUE, rtrim (temp)); if ordata.no_separator then real_page_count = ordata.page_count * ordata.copies; else real_page_count = ordata.page_count; if ordata.charge > 0e0 then /* calculate the page charge */ calc_page_charge = real_page_count * ordata.price_per_n_pages / ordata.n_pages_for_price; else calc_page_charge = 0e0; call ioa_$rsnnl ("^d pages^[ at $^.2f per ^d pages ^52t^10.2f^;^3s^]", line_75_chars, n, real_page_count, (calc_page_charge > 0e0), ordata.price_per_n_pages, ordata.n_pages_for_price, calc_page_charge); call output_position_and_string (TS_PAGE_CHARGE, rtrim (line_75_chars)); if ordata.no_separator then real_line_count = ordata.line_count * ordata.copies; else real_line_count = ordata.line_count; if ordata.charge > 0e0 then calc_line_charge = real_line_count * ordata.price_per_n_lines / ordata.n_lines_for_price; else calc_line_charge = 0e0; call ioa_$rsnnl ("^d lines^[ at $^.2f per ^d lines ^52t^10.2f^;^3s^]", line_75_chars, n, real_line_count, (calc_line_charge > 0e0), ordata.price_per_n_lines, ordata.n_lines_for_price, calc_line_charge); call output_position_and_string (TS_LINE_CHARGE, rtrim (line_75_chars)); call ioa_$rsnnl ("Charge to ^32a^52t^10.2f", line_75_chars, n, ordata.requestor, ordata.charge); call output_position_and_string (TS_CHARGE_TO, rtrim (line_75_chars)); if max_rs_number > 0 | ^ordata.no_accounting then do; call ioa_$rsnnl (" Rate structure ^[unknown, ^a used^;^a^].", line_75_chars, n, ordata.rs_unavailable, rs_names ((ordata.rs_number))); call output_position_and_string (TS_RATE_STRUCTURE, rtrim (line_75_chars)); end; if ordata.access_class_string ^= "" then do; Absolute_vertical_position.body = templates.position (ACCESS_CLASS).vertical; call output_string (string (Absolute_vertical_position)); call output_string (CR); call output_string (string (Begin_auto_center_mode)); call output_string (rtrim (ordata.access_class_string)); call output_string (string (End_auto_center_mode)); Select_font.body = 2; call output_string (string (Select_font)); call output_string (Set_default_hmi); Set_vmi.body = byte (7); call output_string (string (Set_vmi)); Absolute_vertical_position.body = templates.position (BIG_ACCESS_CLASS).vertical; call output_string (string (Absolute_vertical_position)); call bigletter_$five (rtrim (substr (ordata.access_class_string, 1, 13)), output_bigletters); end; Absolute_vertical_position.body = templates.position (TS_HEAD_DESTINATION).vertical; call output_string (string (Absolute_vertical_position)); if dprint_msg.destination = "" then dest = before (after (ordata.requestor, "."), "."); else dest = dprint_msg.destination; if dprint_msg.heading = "" then head = before (ordata.requestor, "."); else if substr (dprint_msg.heading, 1, 5) = " for " then head = substr (dprint_msg.heading, 6); else head = dprint_msg.heading; if length (rtrim (head)) + length (rtrim (dest)) + 2 > length (line_75_chars) then do; Select_font.body = 2; call output_string (string (Select_font)); call output_string (Set_default_hmi); Set_vmi.body = byte (7); call output_string (string (Set_vmi)); line_90_chars = dest; substr (line_90_chars, length (line_90_chars) - length (rtrim (head)) + 1) = rtrim (head); call output_string (CR); call output_string (line_90_chars); end; else do; Select_font.body = 1; call output_string (string (Select_font)); call output_string (Set_default_hmi); Set_vmi.body = byte (9); call output_string (string (Set_vmi)); line_75_chars = dest; substr (line_75_chars, length (line_75_chars) - length (rtrim (head)) + 1) = rtrim (head); call output_string (CR); call output_string (line_75_chars); end; call output_string (CR); call output_string (FF); return; end create_tail_sheet; %page; output_bigletters: proc (strp, lth); /* this is routine bigletter_ calls with the expanded line */ dcl strp ptr; dcl lth fixed bin; dcl bcs char (lth) based (strp); dcl i fixed bin; dcl temp char (204) aligned; temp = bcs; /* copy to a clean string */ i = length (rtrim (temp)); /* see how long it actually is */ /* we must manually insert CR & NL characters on each line. Also, we surround the bigletter_ string with printer commands to make the asterisks appear in shadow mode to make them stand out a little more */ call output_string (CR); call output_string (Begin_shadow_mode); call output_string (substr (temp, 1, i)); call output_string (End_bold_and_shadow_mode); call output_string (CR_NL); return; end output_bigletters; output_position_and_string: proc (position_index, string_to_output); dcl position_index fixed bin; dcl string_to_output char (*); Absolute_horizontal_position.body = templates.position (position_index).horizontal; Absolute_vertical_position.body = templates.position (position_index).vertical; call output_string (string (Absolute_horizontal_position)); call output_string (string (Absolute_vertical_position)); call output_string (string_to_output); end output_position_and_string; output_string: proc (cs); /* routine to copy the string it was passed into the current output buffer defined by buffer_ptr and buffer_length */ dcl cs char (*) parameter; dcl start_char fixed bin; dcl num_chars fixed bin; start_char = buffer_length + 1; num_chars = length (cs); buffer_length = buffer_length + num_chars; substr (buffer, start_char, num_chars) = cs; return; end output_string; %page; print_the_banner_page: proc (which_page); /* output the desired banner page */ dcl which_page fixed bin; /* 1 = head sheet 2 = tailsheet 3 = separator */ if which_page = HEAD | which_page = SEPARATOR then do; /* use head sheet buffer */ buffer_ptr = addr (templates.current_head_sheet.strng); buffer_length_ptr = addr (templates.current_head_sheet.lngth); end; else do; /* use tail sheet buffer */ buffer_ptr = addr (templates.current_tail_sheet.strng); buffer_length_ptr = addr (templates.current_tail_sheet.lngth); end; /* The laser printer's banner pages requires rawo mode and no prt_conv_ intervention. Also, we must reenable print mode if a head sheet, since tail sheet code disables it when it's through outputing the tail sheet. This trick prevents any blank pages between the tail sheet of one request and the head sheet of the next. */ if which_page = HEAD | which_page = SEPARATOR then call iox_$modes (iocbp, "print", "", xcode); /* enable printing */ call iox_$put_chars (iocbp, buffer_ptr, 0, xcode); call iox_$modes (iocbp, "rawo", "", xcode); call iox_$control (iocbp, "prt_conv_off", null (), xcode); call iox_$put_chars (iocbp, buffer_ptr, buffer_length, a_code); call iox_$control (iocbp, "prt_conv_on", null (), xcode); call iox_$modes (iocbp, "^rawo", "", xcode); if which_page = TAIL then do; /* if tail sheet page */ call iox_$modes (iocbp, "^print", "", xcode);/* disenable printing */ return; /* that all for tail sheet */ end; if a_code ^= 0 then return; /* see if there is an printer notice page, if so print it if we are outputting the head sheet */ if which_page = SEPARATOR then return; call hcs_$initiate_count (sysdir, "printer_notice", "", advert_bc, 0, advert_ptr, xcode); if advert_ptr ^= null then if advert_bc > 0 then do; call iox_$modes (iocbp, "default", (""), a_code); call iox_$put_chars (iocbp, advert_ptr, divide (advert_bc, 9, 21, 0), a_code); call hcs_$terminate_noname (advert_ptr, xcode); end; a_code = 0; return; end print_the_banner_page; %page; %include dprint_msg; %page; %include output_request_data; %page; %include prt_ctl; %page; %include queue_msg_hdr; %page; %include iodd_hblp_commands; end iodd_hblp_banner_pages_;  iodd_hblp_support_.pl1 12/05/88 1245.9rew 12/05/88 1244.4 303363 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * ******************************************** */ /****^ HISTORY COMMENTS: 1) change(88-06-07,Brunelle), approve(88-06-07,MCR7911), audit(88-10-25,Wallman), install(88-10-28,MR12.2-1199): Created. 2) change(88-11-14,Brunelle), approve(88-11-14,PBF7911), audit(88-11-14,Wallman), install(88-11-14,MR12.2-1212): Correct problem of going into raw output mode for bold faced chars and never returning to normal mode. Also drop the top line on each page enough so the page is centered vertically. 3) change(88-12-05,Brunelle), approve(88-12-05,MECR0005), audit(88-12-05,Wallman), install(88-12-05,MR12.2-1219): Correct first page of document not being properly aligned at top of page. END HISTORY COMMENTS */ /* format: style4 */ iodd_hblp_support_: proc; return; /* no entry here */ /* this module contains the following utility subroutines for the Honeywell Bull Model 80 laser printer: complete_attach - This completes the attachment for the initial iox_$attach call. open - iox_$open replacement for remote_printer_, control - iox_$control replacement for remote_printer_, modes - iox_$modes replacement for remote_printer_, put_chars - iox_$put_chars replacement for remote_printer_. */ /* Arguments */ dcl a_code fixed bin (35) parameter; /* error code */ dcl a_data_chars fixed bin (21) parameter; /* # of chars to output */ dcl a_data_ptr ptr parameter; /* ptr to data to output */ dcl a_iocbp ptr parameter; /* iocb ptr to process on */ dcl a_mode fixed bin parameter; /* open mode */ dcl a_new_modes char (*) parameter; /* new modes to assign */ dcl a_old_modes char (*) parameter; /* current modes */ dcl a_order char (*) parameter; /* control order to process */ dcl a_orderp ptr parameter; /* options control order info ptr */ dcl a_sw bit (1) parameter; /* com_err_ switch for attach */ /* External Procedures and Variables */ dcl continue_to_signal_ entry (fixed bin (35)); dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$bad_mode fixed bin (35) ext static; dcl error_table_$not_attached fixed bin (35) ext static; dcl error_table_$not_closed fixed bin (35) ext static; dcl error_table_$not_open fixed bin (35) ext static; dcl error_table_$request_pending fixed bin (35) ext static; dcl error_table_$timeout fixed bin (35) ext static; dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$propagate entry (ptr); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl prt_conv_ entry (ptr, fixed bin (21), ptr, fixed bin (21), ptr); dcl remote_driver_$problem_notification entry (char (*)); dcl remote_printer_$remote_printer_position external entry; dcl remote_printer_$remote_printer_close external entry; dcl remote_printer_control_ entry (ptr, char (*), ptr, fixed bin (35)); dcl remote_printer_modes_ entry (ptr, char (*), char (*), fixed bin (35)); dcl sys_info$max_seg_size fixed bin (35) ext static; dcl timed_io_$get_chars entry (ptr, fixed bin (71), ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl (addr, copy, currentsize, divide, index, length, mod, null, rtrim, string, substr, unspec) builtin; dcl any_other condition; /* Internal Static */ dcl VT_or_FF char (2) int static options (constant) init (" "); dcl CR char (1) int static options (constant) init (" "); dcl FF char (1) defined VT_or_FF position (2); dcl NL char (1) int static options (constant) init (" "); dcl last_char_was_ff bit (1) internal static init ("1"b); dcl my_area area based (my_area_ptr); dcl my_area_ptr ptr int static init (null); dcl printer_device char (32) int static options (constant) init ("printer"); dcl prt_conv_on bit (1) int static init ("1"b); /* ON if should call prt_conv_ */ /* save data for label processing if needed */ dcl 1 labels int static, 2 delta_lines fixed bin, /* number of lines needed for labels */ 2 need_initial_ff bit (1) init ("1"b), 2 have_labels bit (1) init ("0"b), /* ON if we have top and/or bottom labels */ 2 have_top_label bit (1) init ("0"b), /* ON if we have a top label */ 2 have_bottom_label bit (1) init ("0"b); /* ON if we have a bottom label */ /* Automatic */ dcl charp ptr; /* ptr to chars to output */ dcl code fixed bin (35); /* error code */ dcl cur_page fixed bin (24); dcl ec fixed bin (35); /* internal error code */ dcl get_printer_status bit (1); dcl i fixed bin; dcl ignore fixed bin (35); dcl iocbp ptr; /* copy of iocb ptr */ dcl mask bit (36) aligned; /* for setting ips mask */ dcl old_modes char (512); dcl open_mode fixed bin; /* copy of opening mode */ dcl order char (32); /* copy of order to process */ dcl output_string char (record_len) based (prt_conv_outp); dcl prt_conv_outp ptr; dcl record_len fixed bin (21); dcl remaining_chars fixed bin (21); /* # of chars left to process in this put_chars call */ dcl runout_mode bit (1); /* set ON if check_printer_status is called for "runout" control order */ dcl send_raw bit (1); dcl temp_line char (1024) varying; dcl top_line_drop_count fixed bin; dcl total_chars fixed bin (24); /* # of chars requested by put_chars */ dcl osdata_ptr ptr; dcl osdata_line_count fixed bin; dcl osdata_line_size fixed bin; dcl osdata_temp_ptr ptr; dcl 1 osdata based (osdata_ptr), 2 max_line_count fixed bin, /* max # overstruck lines */ 2 line_count fixed bin, /* # overstruck lines */ 2 line_size fixed bin, /* # chars in each line */ 2 bolding (osdata_line_size refer (osdata.line_size)) bit (1) unaligned, 2 line ( osdata_line_count refer (osdata.max_line_count), osdata_line_size refer (osdata.line_size)) char (1) unaligned; %page; /* entrypoint to complete the processing for the iox_$attach call in remote_printer_. This starts propagating any special processing required for the new device. In our case, it merely causes the open entry in the IOCB to point to our open entry. */ complete_attach: entry (a_iocbp, a_code); /* copy input args */ iocbp = a_iocbp; /* ptr to iocb to alter */ a_code = 0; if my_area_ptr = null then my_area_ptr = get_system_free_area_ (); /* mask & alter the IOCB */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.open = hblp_open; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; /* place init_iocbp does a non-local goto to get out through if not attached */ return_now: return; %page; /* replacement for iox_$open in remote_printer_ */ /* this entrypoint is identical to that in remote_printer_ EXCEPT . it opens it's output switch for input/output where remote_printer_ only opens for output. . it uses our control, modes and put_chars entrypoints. */ hblp_open: entry (a_iocbp, a_mode, a_sw, a_code); call init_iocbp ("0"b); open_mode = a_mode; if ^((open_mode = Stream_output) | (open_mode = Stream_input_output)) then do; a_code = error_table_$bad_mode; return; end; /* We will attempt to open the stream for sequential I/O first. If that fails we will then go for stream I/O. In either case we will make note of what worked in ad.record_io. */ call iox_$open (ad.terminal_iocbp, Sequential_input_output, "0"b, a_code); if a_code = 0 then do; ad.record_io = "1"b; /* we have record interface approval */ call hcs_$make_ptr (null, "remote_conv_", "printer", ad.cv_proc, a_code); if a_code ^= 0 then return; end; else do; ad.record_io = "0"b; /* we have stream interface only */ call iox_$open (ad.terminal_iocbp, Stream_input_output, "0"b, a_code); if a_code ^= 0 then return; call hcs_$make_ptr (null, ad.terminal || "conv_", "printer", ad.cv_proc, a_code); if a_code ^= 0 then return; end; ad.open_description = rtrim (iox_modes (open_mode)); ad.static_overstrike_data_ptr = null; mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); /* These are system entries */ iocbp -> iocb.put_chars = hblp_put_chars; iocbp -> iocb.control = hblp_control; iocbp -> iocb.modes = hblp_modes; /* these are my entries */ iocbp -> iocb.position = remote_printer_$remote_printer_position; iocbp -> iocb.close = remote_printer_$remote_printer_close; iocbp -> iocb.open_descrip_ptr = addr (ad.open_description); call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; %page; /* replacement for iox_$control in remote_printer_ */ /* this entrypoint is used so we can pre/post process some of the control orders */ hblp_control: entry (a_iocbp, a_order, a_orderp, a_code); if debug then call debug_display (1); call init_iocbp ("1"b); orderp = a_orderp; order = a_order; code = 0; if order = "io_call" then do; /* set up for command call */ if a_orderp = null then do; code = error_table_$bad_arg; go to control_return; end; order = orderp -> io_call_info.order_name; orderp = null; end; /* remember to ignore or call prt_conv_ when processing data */ else if order = "prt_conv_on" | order = "prt_conv_off" then do; prt_conv_on = (order = "prt_conv_on"); go to control_return; end; /* make sure printer has printed everything sent to it */ else if order = "runout" then do; runout_mode = "1"b; call check_printer_status; end; /* issued by do_prt_request_ only to get to bottom of current page, 1 line past where bottom label would be printed on the page. If we are not outputting labels, fake out prt_conv_ so it thinks it is there, otherwise pass the control order on only if we have a bottom label to output. */ else if order = "end_of_page" then do; if ^labels.have_bottom_label then do; pci.line = pci.phys_page_length - 2; go to control_return; end; end; /* issued by do_prt_request_ to get to the proper page before starting to display. fake out prt_conv_ by eating the orders here else if order = "inside_page" | order = "outside_page" then do; go to control_return; end; */ /* process here so we can handle sheets_per_page properly and return a 0 error code if all goes well */ else if order = "paper_info" then do; /* Set new physical paper characteristics. */ if paper_info.lines_per_inch ^= 6 & paper_info.lines_per_inch ^= 8 then do; bad_arg: code = error_table_$bad_arg; go to control_return; end; if paper_info.phys_page_length < 10 | paper_info.phys_page_length > 127 then go to bad_arg; if paper_info.phys_line_length < 10 | paper_info.phys_line_length > 255 then go to bad_arg; pci.phys_page_length = paper_info.phys_page_length; pci.phys_line_length = paper_info.phys_line_length; pci.lpi = paper_info.lines_per_inch; /* This is the equivalent of call to prtdim_changemode$remote_printer_modes_ passing in a null new modes. It insures the consistency of prt_conv_info structure. It was moved here so we can special case the sheets_per_page data */ pci.rmarg = pci.phys_line_length; pci.lmarg = 0; if pci.overflow_off then do; pci.top_label_length, /* "noskip" and page labels are inconsistent */ pci.bot_label_length = 0; pci.page_length = pci.phys_page_length; /* max number of lines on each page */ pci.sheets_per_page = 1; /* one sheet per page in noskip mode */ end; /* "^noskip" mode, compute module 10 lines perpage & physical sheets of paper per page */ else do; pci.page_length = pci.phys_page_length - mod (pci.phys_page_length, 10); pci.sheets_per_page = divide (pci.page_length - 1 + pci.phys_page_length, pci.phys_page_length, 17, 0); end; go to control_return; end; /* let the prtdim control order processor have at the control order. If it returns an error code, it probabily couldn't handle it. In that case we will pass it to the next I/O module following us which may be able to handle it. */ call remote_printer_control_ (iocbp, order, orderp, code); if code ^= 0 then do; /* if not done or partially completed, pass it on */ call iox_$control (ad.terminal_iocbp, order, orderp, ec); if ec = 0 then code = 0; /* let the code from remote_printer_control prevail */ end; /* we will post-process the following control orders to allow for any special processing required for the laser printer */ /* We will reset pci.page_length to physical page length modulo 10 */ if order = "reset" then do; unspec (labels) = "0"b; /* reset our page labels data */ last_char_was_ff = "1"b; /* we will always start on fresh page */ prt_conv_on = "1"b; /* we will always handle conversion ourselves */ pci.page_length = pci.phys_page_length - mod (pci.phys_page_length, 10); if ad.static_overstrike_data_ptr ^= null then do; free ad.static_overstrike_data_ptr -> osdata; ad.static_overstrike_data_ptr = null; end; end; /* set up our internal control orders to handle prt_conv_'s label processing */ else if order = "page_labels" then do; unspec (labels) = "0"b; /* reset our page labels data */ if pci.top_label_length ^= 0 then do; labels.delta_lines = labels.delta_lines + 2; labels.have_labels = "1"b; labels.have_top_label = "1"b; labels.need_initial_ff = "1"b; end; if pci.bot_label_length ^= 0 then do; labels.delta_lines = labels.delta_lines + 2; labels.have_labels = "1"b; labels.have_bottom_label = "1"b; labels.need_initial_ff = "1"b; end; if pci.page_length + labels.delta_lines > pci.phys_page_length then pci.page_length = pci.phys_page_length - labels.delta_lines; end; control_return: a_code = code; return; %page; /* replacement for iox_$modes in remote_printer_ */ hblp_modes: entry (a_iocbp, a_new_modes, a_old_modes, a_code); if debug then call debug_display (2); call init_iocbp ("1"b); code = 0; call remote_printer_modes_ (iocbp, a_new_modes, a_old_modes, a_code); /* the following is copied from prtdim_changemode.pl1. It is put here so we can recompute the sheets_per_page field properly */ if ^pci.overflow_off then do; /* "^noskip" mode */ pci.sheets_per_page = divide (pci.page_length - 1 + pci.phys_page_length, pci.phys_page_length, 17, 0); end; if a_new_modes = "default" then do; call iox_$modes (ad.terminal_iocbp, a_new_modes, "", ignore); end; else if index (a_new_modes, "non_edited") ^= 0 then do; i = index (a_new_modes, "non_edited"); if i = 1 then call iox_$modes (ad.terminal_iocbp, "non_edited", "", ignore); else if substr (a_new_modes, i - 1, 1) = "^" then call iox_$modes (ad.terminal_iocbp, "default", "", ignore); else call iox_$modes (ad.terminal_iocbp, "non_edited", "", ignore); end; else if index (a_new_modes, "rawo") ^= 0 then do; i = index (a_new_modes, "rawo"); if i = 1 then call iox_$modes (ad.terminal_iocbp, "rawo", "", ignore); else if substr (a_new_modes, i - 1, 1) = "^" then call iox_$modes (ad.terminal_iocbp, "^rawo", "", ignore); else call iox_$modes (ad.terminal_iocbp, "rawo", "", ignore); end; return; %page; /* replacement for iox_$put_chars in remote_printer_ */ hblp_put_chars: entry (a_iocbp, a_data_ptr, a_data_chars, a_code); dcl (col_no, line_no) fixed bin; if debug then call debug_display (3); call init_iocbp ("1"b); code = 0; if a_data_chars < 0 | a_data_chars > sys_info$max_seg_size * 4 then do; a_code = error_table_$bad_arg; return; end; total_chars, remaining_chars = a_data_chars; /* remaining_chars is decremented as data is sent */ charp = a_data_ptr; /* charp is bumped by prt_conv_ as data is sent */ call iox_$control (ad.terminal_iocbp, "select_device", addr (printer_device), code); if code ^= 0 then go to put_chars_ret; /* allocate the terminal_io_record */ terminal_io_record_element_size = 9; /* character data */ terminal_io_record_n_elements = 3 * ad.phys_line_length; /* enough room for 1 printing character and 2 non-printing characters per column (eg: DC1-u X) */ /* get copy of terminal io record that we will send out */ allocate terminal_io_record in (my_area) set (terminal_io_record_ptr); unspec (terminal_io_record) = "0"b; /* clear everything */ terminal_io_record.version = terminal_io_record_version_1; terminal_io_record.device_type = ad.device_type; terminal_io_record.element_size = terminal_io_record_element_size; terminal_io_record.n_elements = terminal_io_record_n_elements; if ad.record_io then prt_conv_outp = terminal_io_record_ptr; /* full record for record interface */ else prt_conv_outp = addr (terminal_io_record.data); /* use the string portion for stream interface */ send_raw = "0"b; get_printer_status = "0"b; osdata_ptr = ad.static_overstrike_data_ptr; top_line_drop_count = (pci.phys_page_length - pci.page_length - labels.delta_lines) / 2; %page; do while (remaining_chars > 0 | pci.slew_residue > 0); /* so keep trying while there is anything to slew */ cur_page = pci.page_count; /* save the page number */ /* if prt_conv_on switch is ON, use prt_conv_ to parse each line and determine when page breaks occur. */ if prt_conv_on then do; call prt_conv_ (charp, remaining_chars, prt_conv_outp, record_len, pcip); if debug then call debug_display (4); /* see if any overstriking is required for this line */ if (substr (output_string, record_len, 1) = CR | pci.level > 0 | pci.slew_residue < 0) | osdata_ptr ^= null then do; call process_overstrike_string; end; else send_raw = "0"b; /* no special processing on this line */ end; /* if prt_conv_on switch is OFF, just pass all characters on. We will ignore any form feeds because they might be binary data instead of a true form feed. */ else do; prt_conv_outp = charp; record_len = remaining_chars; remaining_chars = remaining_chars - record_len; end; /* if we are not printing, just ignore any of the output code */ if ad.noprint then go to skip_line_print; /* if we are not running in prt_conv_on mode (raw output), just output the line */ if ^prt_conv_on then go to send_line_out; /* skip this line if 2nd sucesssive Form Feed */ if output_string = FF then do; /* have line just containing FF */ if last_char_was_ff then /* already ejected one page */ go to skip_line_print; /* so ignore the line */ last_char_was_ff = "1"b; /* remember this FF */ end; else do; /* have data */ last_char_was_ff = (substr (output_string, record_len, 1) = FF); /* remember if this line ends in FF */ end; /* we just found a form feed. If we are in labels mode, it is 1) the one just following the top label if top labels are being used. . We have to replace it with a new line. If this is the first label being . generated, we issue a form feed to get us to the next page then display . the top label. For all subsequent labels, we just replace the form feed . with a new line since prt_conv_ will space us to the next page properly. 2) The one just following the bottom label if top labels are not being used. . In this case, we will do nothing. If we are not in labels mode, it follows the last line on the previous page so adjust the top line down so it is centered vertically on the page */ if last_char_was_ff then do; if labels.have_labels then do; if labels.have_top_label then do; if labels.need_initial_ff then do; labels.need_initial_ff = "0"b; temp_line = FF; end; else temp_line = ""; temp_line = temp_line || substr (output_string, 1, record_len - 1); temp_line = temp_line || NL; temp_line = temp_line || NL; record_len = length (temp_line); output_string = temp_line; if debug then call debug_display (5); end; end; else do; if top_line_drop_count > 0 then do; temp_line = output_string; temp_line = temp_line || copy (NL, top_line_drop_count); record_len = length (temp_line); output_string = temp_line; end; end; end; /* see if the slew residue denotes there are multiple new lines to follow this one. If not zero, add the extra new lines to this record so that only one call is made to iox_$put_chars instead of one for each slew residue count. */ if pci.slew_residue > 0 then do; i = terminal_io_record.n_elements - record_len; /* determine # chars left in record */ if pci.slew_residue < i then i = pci.slew_residue; temp_line = output_string; temp_line = temp_line || copy (NL, i); record_len = length (temp_line); output_string = temp_line; pci.slew_residue = pci.slew_residue - i; end; /* output the data line itself */ send_line_out: if ad.record_io then do; call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr, 4 * currentsize (terminal_io_record), code); end; else do; /* stream output */ if send_raw then call iox_$modes (ad.terminal_iocbp, "rawo", old_modes, ignore); call iox_$put_chars (ad.terminal_iocbp, prt_conv_outp, record_len, code); if send_raw then call iox_$modes (ad.terminal_iocbp, "^rawo", "", ignore); end; if code ^= 0 then go to put_chars_ret; /* trouble */ skip_line_print: /* compute lines and pages based on function of bytes if running in rawo mode */ if ^prt_conv_on then do; pci.line = 0; pci.line_count = pci.line_count + total_chars / 60; pci.page_count = pci.page_count + total_chars / 3600; end; if cur_page ^= ad.page_count then do; /* did we turn another page? */ ad.stop_counter = ad.stop_counter + 1; /* bump the page stop counter */ if ad.single_page | (ad.stop_every ^= 0 & ad.stop_counter >= ad.stop_every) then do; ad.stop_counter = 0; code = error_table_$request_pending; /* say we were not done yet */ go to put_chars_ret; /* exit the loop and return to caller */ end; end; prt_conv_loop_end: end; put_chars_ret: if terminal_io_record_ptr ^= null then do; free terminal_io_record_ptr -> terminal_io_record in (my_area); end; ad.static_overstrike_data_ptr = osdata_ptr; ad.chars_printed = ad.chars_printed + total_chars - remaining_chars; /* record our progress */ a_code = code; return; %page; process_overstrike_string: proc; /* this routine will do the following: 1. If there is no current overstrike data, it will save the current string and let it be output as is. 2. If there is current overstrike data, compare each character in the new string for matches with all other text outputted for this line. If there are matches it will add a 'Begin_bold" before the characters and follow them with an 'End_bold' command. It will use this new line as the output line. 3. If the current line ends in a line feed, it will release the overstrike structure */ dcl Begin_bold char (2) int static options (constant) /* ESC O */ init ("O"); dcl End_bold char (2) int static options (constant) /* ESC & */ init ("&"); dcl tmp_line char (osdata.line_size) based; dcl bold_on bit (1); /* If we have no current overstrike data available, allocate a buffer for 5 lines. If we already have more than 5 lines of data allocate a larger buffer and add the new line to it */ if osdata_ptr = null then do; osdata_line_count = 5; osdata_line_size = terminal_io_record.n_elements; allocate osdata in (my_area); osdata.line_count = 0; osdata.line (*, *) = ""; osdata.bolding (*) = "0"b; end; else if osdata.line_count + 1 > osdata.max_line_count then do; osdata_line_count = osdata.max_line_count + 5; osdata_line_size = osdata.line_size; allocate osdata in (my_area) set (osdata_temp_ptr); osdata_temp_ptr -> osdata.line_count = osdata.line_count; osdata_temp_ptr -> osdata.bolding (*) = "0"b; osdata_temp_ptr -> osdata.line (*, *) = ""; do i = 1 to osdata.line_count; addr (osdata_temp_ptr -> osdata.line (i, 1)) -> tmp_line = addr (osdata.line (i, 1)) -> tmp_line; end; free osdata; osdata_ptr = osdata_temp_ptr; end; osdata.line_count = osdata.line_count + 1; addr (osdata.line (osdata.line_count, 1)) -> tmp_line = output_string; send_raw = "0"b; /* assume no special chars in output line */ /* if this is the first line then just let that line print as is */ if osdata.line_count = 1 then return; /* Now process the new data line. Check each column position outputted so far for duplicate chars in this line and turn on the bolding bit if found */ osdata.bolding (*) = "0"b; /* no bolding yet */ do col_no = 1 to record_len; do line_no = 1 to osdata.line_count - 1 while (^osdata.bolding (col_no)); if osdata.line (osdata.line_count, col_no) ^= " " then do; if osdata.line (osdata.line_count, col_no) = osdata.line (line_no, col_no) then do; osdata.bolding (col_no) = "1"b; end; end; end; end; /* Now see if any bolding bits were turned on. If so we have to build a new output line putting the Begin/End_bold command sequences around each set of characters to be bolded; otherwise just return */ if index (string (osdata.bolding), "1"b) = 0 then go to process_overstrike_return; temp_line = ""; bold_on = "0"b; do col_no = 1 to record_len; if ^osdata.bolding (col_no) then do; if bold_on then do; send_raw = "1"b; bold_on = "0"b; temp_line = temp_line || End_bold; end; end; else do; if ^bold_on then do; send_raw = "1"b; bold_on = "1"b; temp_line = temp_line || Begin_bold; end; end; temp_line = temp_line || osdata.line (osdata.line_count, col_no); end; if bold_on then do; send_raw = "1"b; bold_on = "0"b; temp_line = temp_line || End_bold; end; /* replace the output line with the new one with bolding characters inserted */ record_len = length (temp_line); output_string = temp_line; /* if this line is last one of an overstrike set, get rid of the overstrike data structure */ process_overstrike_return: if substr (output_string, record_len, 1) = NL then do; free osdata; osdata_ptr = null; if send_raw then do; record_len = record_len + 1; substr (output_string, record_len, 1) = CR; end; end; end process_overstrike_string; %page; check_printer_status: proc; /* this routine will make sure 1. the printer is still talking to the user. 2. it is still in an error free condition (has paper & toner, all covers closed) 3. It has printed everything sent to it. (no data waiting) */ dcl status_requests char (6) unaligned; dcl STX char (1) int static options (constant) init (""); dcl PAGE_TIMEOUT fixed bin (71) int static init (15000000);/* 15 seconds */ dcl PROBLEM_TIMEOUT fixed bin (71) int static init (300000000); /* 5 minutes */ dcl chars_read fixed bin (21); dcl input_buffer char (256); dcl stx_loc fixed bin; dcl timeout_to_use fixed bin (71); dcl 1 status_byte_1 unaligned, 2 pad1 bit (1), 2 parity bit (1), 2 test_in_progress bit (1), 2 no_data bit (1), 2 cover_open bit (1), 2 auto_lf bit (1), 2 no_paper bit (1), 2 hmi bit (1), 2 no_toner bit (1); dcl 1 status_byte_3 unaligned, 2 pad1 bit (1) unaligned, 2 parity bit (1) unaligned, 2 always_zero bit (5) unaligned, 2 exit_paper_jam bit (1) unaligned, 2 feed_paper_jam bit (1) unaligned; get_printer_status = "0"b; /* be nice to caller */ if ("1"b) then return; /* ignore for now */ status_requests = Request_status_byte_1 || Request_status_byte_3; /* make sure modes are such that we can communicate properly */ call iox_$modes (ad.terminal_iocbp, "breakall,rawo,rawi", old_modes, ec); timeout_to_use = PAGE_TIMEOUT; /* allow 15 seconds for it to respond */ request_status_again: /* request the status */ call iox_$put_chars (ad.terminal_iocbp, addr (status_requests), length (status_requests), ec); /* wait for status return from the printer. */ read_status_again: call timed_io_$get_chars (ad.terminal_iocbp, timeout_to_use, addr (input_buffer), length (input_buffer), chars_read, ec); /* if the get_chars times out, it's because the communications stopped. It might be that comm is gone or the printer itself may have a problem. Warn someone about the problem. then wait to see if the have corrected */ if ec ^= 0 then do; if ec = error_table_$timeout then do; call remote_driver_$problem_notification ("The printer is not responding."); timeout_to_use = PROBLEM_TIMEOUT; /* wait for 5 minutes before complaining again */ go to read_status_again; end; end; /* got a response from the printer, look for the STX which starts the message */ stx_loc = index (input_buffer, STX); if stx_loc = 0 then /* not there */ goto read_status_again; /* must be more to read */ /* Now that we have start of message, isolate the status byte and check it */ unspec (status_byte_1) = unspec (substr (input_buffer, stx_loc + 1, 1)); unspec (status_byte_3) = unspec (substr (input_buffer, stx_loc + 3, 1)); if status_byte_1.cover_open then do; call remote_driver_$problem_notification ("The printer has a cover open."); go to request_status_again; end; if status_byte_1.no_paper then do; call remote_driver_$problem_notification ("The printer is out of paper."); go to request_status_again; end; if status_byte_3.feed_paper_jam then do; call remote_driver_$problem_notification ("The printer has a feed paper jam."); go to request_status_again; end; if status_byte_3.exit_paper_jam then do; call remote_driver_$problem_notification ("The printer has a exit paper jam."); go to request_status_again; end; if ^status_byte_1.no_data then /* still has some data in it */ go to request_status_again; /* reset modes back to the way they were when we started */ call iox_$modes (ad.terminal_iocbp, old_modes, "", ec); end check_printer_status; %page; /* subroutines */ /* This proc handles faults that occur while masked */ handler: procedure (); dcl ignore fixed bin (35); /* dummy error code */ if mask then call hcs_$reset_ips_mask (mask, mask); mask = ""b; call continue_to_signal_ (ignore); return; end handler; init_iocbp: proc (check_for_open); /* set up all required variables from the iocb */ dcl check_for_open bit (1); /* if ON, check for iocb being open */ /* if OFF, check for iocb being closed */ iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; go to return_now; end; if ^check_for_open then do; if iocbp -> iocb.open_descrip_ptr ^= null then do; a_code = error_table_$not_closed; go to return_now; end; end; else do; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; go to return_now; end; end; pcip = addr (ad.remote_pci); a_code = 0; end init_iocbp; %page; dcl debug bit (1) int static init ("0"b); dcl ioa_ entry () options (variable); dbgn: entry; debug = "1"b; goto dbg_report; dbgf: entry; debug = "0"b; goto dbg_report; dbgs: entry; dbg_report: call ioa_ ("Debug is ^[ON^;OFF^]", debug); return; debug_display: proc (which_display); dcl which_display fixed bin; if which_display = 1 then call ioa_ ("hblp_control - order = ^a", a_order); else if which_display = 2 then call ioa_ ("hblp_modes - new_modes = ^a", a_new_modes); else if which_display = 3 then call ioa_ ("hblp_put_chars - string length = ^d", a_data_chars); else if which_display = 4 then call ioa_ ("^5d ^5d ^5d ^5d ^5d ^5d ^5d ^[NL^]^[FF^]^[CR^] ^a", pci.page_count, pci.line_count, pci.line, pci.func, pci.level, pci.slew_residue, record_len - 1, (substr (output_string, record_len, 1) = NL), (substr (output_string, record_len, 1) = FF), (substr (output_string, record_len, 1) = CR), substr (output_string, 1, record_len - 1)); else if which_display = 5 then call ioa_ ("print_the_line changing FF to NL & outputting FF"); end debug_display; %page; %include io_call_info; %page; %include iocb; %page; %include iod_tables_hdr; %page; %include iodd_hblp_commands; %page; %include iox_modes; %page; %include mode_string_info; %page; %include prt_conv_info; %page; %include prt_info; %page; %include prt_order_info; %page; %include q_group_tab; %page; %include remote_attach_data; %page; %include terminal_io_record; end iodd_hblp_support_;  remote_conv_.alm 11/15/82 1900.8rew 11/15/82 1535.0 45225 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " remote_conv_: Conversion routine for producing "standard" terminal I/O records for output to an RJE station or a remote " host system by an I/O daemon (driven by either remote_driver_ or workstation_sim_driver_). See the prt_conv_ module " for a description of the manner in which this routine is utilized. " Created: December 1979 by G. Palter name remote_conv_ segdef printer " output destined for a line printer segdef punch " output destined for a card punch (to be obsolete soon) segdef teleprinter " output destined for the RJE station's operator's console " Transfer vectors for the three types of output devices -- printer, punch, and teleprinter printer: tra send_setup_printer " initialize new printer output record tra send_characters " output some characters into the record tra send_slew_pattern " slew (skip) to specified VFU pattern tra send_slew_count " slew (skip) specified number of lines punch: tra send_setup_punch " initialize new punch output record tra send_characters tra pr7|0 " for punch: meaningless to slew to pattern " " for punch: meaningless to slew by count lda 0,du " set residue count to claim entire skip done tra pr7|0 teleprinter: tra send_setup_teleprinter " initialize new teleprinter output record tra send_characters " output some characters into the record tra send_slew_pattern " slew (skip) to specified VFU pattern tra send_slew_count " slew (skip) specified number of lines tempd tior_ptr " -> the record's header tempd saved_pr4 tempd saved_pr5 " include terminal_io_record " " Initialize an output record send_setup_printer: ldq tior_printer_device,dl " need to set device type in record header tra send_setup_common send_setup_punch: ldq tior_punch_device,dl tra send_setup_common send_setup_teleprinter: ldq tior_teleprinter_device,dl " tra send_setup_common send_setup_common: spri3 tior_ptr " save pointer to start of output record stq pr3|tior.device_type " save device type from above ldq tior_version_1,dl " fill in rest of header with "default" settings stq pr3|tior.version ldq slew_single_line " set to slew by 1 line stq pr3|tior.slew_control stz pr3|tior.flags " not binary ldq 9,dl " element size is 9 (characters) stq pr3|tior.element_size stz pr3|tior.n_elements " no data yet ldq 4*tior.data,dl " move pointer past header (to this offset) a9bd pr3|0,ql tra pr7|0 " setup completed slew_single_line: " constant to slew 1 line vfd 18/tior_slew_by_count,18/1 " " Place data (with possible leading whitespace) into the record send_characters: spri4 saved_pr4 " need a pointer to record header epp4 tior_ptr,* eaq 0,2 " whitespace count into QU tmoz no_whitespace " ... none needed qrl 18 " ... put it into QL (sigh) mlr (),(pr,rl),fill(040) " insert requested # of spaces desc9a *,0 desc9a pr3|0,ql a9bd pr3|0,ql " ... update output pointer asq pr4|tior.n_elements " ... update record length in buffer header no_whitespace: lrl 72-18 " put count of characters into QL (sigh) mlr (pr,rl),(pr,rl) " move the data desc9a pr2|0,ql desc9a pr3|0,ql a9bd pr2|0,ql " ... update input pointer a9bd pr3|0,ql " ... update output pointer asq pr4|tior.n_elements " ... update record length in buffer header eax2 0 " be sure X2 is zero (all spaces done) epp4 saved_pr4,* tra pr7|0 " all done " " Slew to specified pattern send_slew_pattern: spri4 saved_pr4 " once again -- need pointer to record header epp4 tior_ptr,* spri5 saved_pr5 " used for RPT instruction epp5 slew_pattern_table eax7 0 " initialize for search rpt n_slew_patterns,2,tze " search for the pattern cmpa pr5|0,7 ldq pr5|-1,7 " pickup the proper slew control word stq pr4|tior.slew_control " ... and put it into the record epp4 saved_pr4,* epp5 saved_pr5,* tra pr7|0 " return " Slew N lines (in A) send_slew_count: spri4 saved_pr4 epp4 tior_ptr,* ora slew_N_lines " put in slew by count opcode sta pr4|tior.slew_control lda 0,du " clear the A (took all lines) epp4 saved_pr4,* tra pr7|0 " Constants equ n_slew_patterns,3 " NOTE: must be changed whenever following table is modified slew_pattern_table: vfd o36/0 " slew to top of page vfd 18/tior_slew_to_top_of_page,18/0 vfd o36/13 " slew to top of inside page vfd 18/tior_slew_to_inside_page,18/0 vfd o36/11 " slew to top of outside page vfd 18/tior_slew_to_outside_page,18/0 slew_N_lines: vfd 18/tior_slew_by_count,18/0 end  remote_driver_.pl1 11/01/88 1243.7rew 11/01/88 1237.7 878697 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ /* format: off */ /* Standard remote device driver control module for the I/O daemon. */ /* Adapted from g115_driver_ by David Vinograd - March 1977 */ /* Modified by J. C. Whitmore, 4/78, for new dprint_msg format and Daemon upgrade */ /* Modified by J. C. Whitmore, 8/78, to defer requests over phys ll and for auto defer time init */ /* Modified by J. C. Whitmore, 10/78, to extend the number of RJE stations */ /* Modified by J. C. Whitmore, 3/79, for minor bug fixes */ /* Modified by C. Hornig, 6/79, for multiple minor devices of the same generic type */ /* Modified by J. C. Whitmore, 10/79, for binary punching and commands sep_cards, punch, pun_control */ /* Modified: 2 April 1981 by G. Palter correct a bug which causes use of "logout", "new_device", etc. requests during the processing of a request to cause a null pointer fault by iox_ followed by flushing the remaining requests in the queue */ /* Modified: October 1981 by C. Hornig to support attach_type 3 (dial_id) */ /* Modified: 9 November 1981 by G. Palter to use read_password_ to get the station password if it is omitted from the station command */ /* Modified: 17 November 1981 by G. Palter to not consider inability to set hangup_proc as fatal */ /* Modified: 11 December 1981 by G. Palter to support auto_go and force_ctl_char for printer minor devices */ /* Modified: November 1983 by C. Marker Added support for force_nsep */ /* Modified: January 1984 by C. Marker Added probe as a legal command in test mode. */ /* Modified 1984-08-17 by E. Swenson for Version 2 PNTs. */ /* Modified 14 Feb 1984 by Jim Homan for logout_on_hangup */ /* Modified: February 23, 1985 by C. Marker to use version 5 message segments */ /****^ HISTORY COMMENTS: 1) change(84-02-14,Homan), approve(87-04-06,MCR7656), audit(87-06-13,Beattie), install(87-08-06,MR12.1-1068): Submit logout_on_hangup changes for installation. 2) change(87-05-01,Gilcrease), approve(87-05-14,MCR7686), audit(88-02-01,Farley), install(88-02-02,MR12.2-1019): Update to version 4 dprint_msg. 3) change(88-02-18,Brunelle), approve(88-06-28,MCR7911), audit(88-10-26,Parisek): Add support for single/continuous paper type. 4) change(88-08-29,Farley), approve(88-06-28,MCR7911), audit(88-10-26,Parisek): Updated for version 5 dprint_msg. 5) change(88-10-31,Brunelle), approve(88-10-31,MCR7911), audit(88-11-01,Wallman): Correct problem of requiring a model name if single sheet mode defined. END HISTORY COMMENTS */ /* format: on */ remote_driver_: procedure (); return; /* this is not a legal 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 */ /* Automatic */ dcl age fixed bin; dcl arg_string char (32); dcl argp ptr; dcl attach_desc char (256) var; dcl banner_type fixed bin; dcl code fixed bin (35); dcl control bit (36) aligned; dcl date_string char (24); dcl device_type char (32); dcl digit char (1); dcl element_size fixed bin; dcl err_msg char (200); dcl format_code fixed bin; dcl header_card2 char (80); dcl (i, idx) fixed bin; /* general index variable */ dcl ignore_code fixed bin (35); /* error code to be ignored */ dcl input_line char (80); dcl len fixed bin; dcl iocbp ptr; dcl major_args char (major_args_length) based (major_args_ptr); dcl major_args_length fixed bin int static; dcl major_args_name char (256) varying; dcl major_comm_module char (32) var; dcl major_desc char (256) var; dcl major_terminal_module char (32) var; dcl major_tty char (32) var; dcl minor_args char (minor_args_length) based (minor_args_ptr); dcl minor_args_length fixed bin int static; dcl minor_args_name char (256) varying; dcl model char (32) var; dcl my_area area based (my_area_ptr); /* area to allocate in */ dcl nchar fixed bin; dcl need_station bit (1); dcl new_ll fixed bin; /* temp for the new phys line length */ dcl new_lpi fixed bin; /* and for the new lines per inch value */ dcl new_pl fixed bin; /* temp for setting the phys page length */ dcl not bit (1); dcl omode char (256); dcl opr_msg char (160); /* message to tell operator we are ready, etc. */ dcl p ptr; dcl p2 ptr; dcl pos fixed bin; dcl pool_dir char (168); /* dirname for the card pool root */ dcl printer_count fixed bin; /* number of printer minor devices (during init) */ dcl punch_count fixed bin; /* number of punch minor devices (during init) */ dcl ready_device bit (1) aligned; /* ON => there's at least one minor device that's ready */ dcl req_string char (12); /* place for the request number as characters */ dcl rqt_string char (168) var; dcl save_code fixed bin (35); dcl source fixed bin; dcl state fixed bin; dcl station char (32); dcl station_password char (8); dcl status bit (72) aligned; /* status code for old ios_ calls */ dcl stream char (32) aligned; dcl temp_password char (8); dcl 1 term_info aligned like terminal_info; dcl tries fixed bin; dcl value fixed bin; dcl st_code fixed bin (35) based; /* first word of the ios_ status */ %page; dcl 1 form_info aligned, /* data from the form paging dim */ 2 page_length fixed bin, 2 line_length fixed bin, 2 line_no fixed bin, 2 carriage_position fixed bin, 2 aligned bit (1) unal, /* tells if the dim considers the forms aligned */ 2 pad bit (35) unal; 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 cmd_list int static aligned, /* iodd_parse_$command structure for request command level */ 2 max fixed bin init (5), /* allow command and four args max */ 2 number_tokens_found fixed bin, 2 cmd char (64) var, /* the command part of the line */ 2 arg (4) char (64) var; /* the arguments */ /* Based Variables */ dcl sys_dir char (168) based; dcl 1 arg_list aligned based (argp), /* iodd_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 pun_ctl_ptr ptr; dcl 1 pun_ctl based (pun_ctl_ptr), /* punch control structure */ 2 sep_cards fixed bin, /* 0 = none, 1 = standard: what type of separators to punch */ 2 modes, 3 auto_punch bit (1) unal; /* FALSE if we should come to request command level */ %page; /* External Entries */ dcl add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; dcl continue_to_signal_ entry (fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl debug entry (); dcl do_prt_request_ entry (ptr, ptr, fixed bin (35)); dcl do_prt_request_$error_during_request entry (char (*)); dcl do_prt_request_$single_copy entry (); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl iodd_command_processor_ entry (fixed bin, fixed bin, char (*) aligned, fixed bin (35)); dcl iodd_get_cmd_ entry (ptr, fixed bin, fixed bin, bit (36) aligned, char (*), fixed bin, fixed bin (35)); dcl iodd_hangup_$iodd_hangup_ entry; dcl iodd_listen_ entry (ptr); dcl iodd_msg_ entry options (variable); dcl iodd_parse_$args entry (char (*) var, char (*)) returns (char (256) var); dcl ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl iox_$look_iocb entry (char (*) aligned, ptr, fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl output_request_ entry (char (*), fixed bin, ptr, entry, fixed bin (35)); dcl output_request_$error_during_request entry (char (*)); dcl output_request_$set_single_copy entry (); dcl iod_info_$evaluate_forms_info entry (ptr, ptr, ptr, fixed bin (35)); dcl iodd_parse_$command entry (char (*) aligned, ptr, fixed bin (35)); dcl message_facility_$send_message_access_class entry (char (*), char (*), char (*), ptr, bit (72) aligned, fixed bin (35)); dcl pool_manager_$clean_pool entry (char (*), fixed bin, fixed bin, fixed bin (35)); dcl pool_manager_$init entry (char (*), fixed bin, bit (36) aligned, fixed bin (35)); dcl probe entry (); dcl read_cards_ entry (char (*), ptr, char (*), bit (1) aligned, fixed bin (35)); dcl read_cards_$set_rqt entry (char (*), char (*), fixed bin (35)); dcl read_cards_$set_station entry (char (*), fixed bin (35)); dcl read_password_$switch entry (ptr, ptr, char (*), char (*), fixed bin (35)); dcl scramble_ entry (char (8)) returns (char (8)); dcl set_iod_val entry (char (*), char (*)); dcl (system_privilege_$ipc_priv_off, system_privilege_$ipc_priv_on, system_privilege_$ring1_priv_off, system_privilege_$ring1_priv_on) entry (fixed bin (35)); dcl timer_manager_$alarm_wakeup entry (fixed bin(71), bit(2), fixed bin(71)); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl validate_card_input_$station entry (char (*), char (*), char (*), fixed bin (35)); dcl write_control_form_ entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)); dcl write_sample_form_ entry (char (*) aligned, char (*) aligned, fixed bin (35)); dcl write_sample_prt_banner_ entry (char (*), ptr, ptr, fixed bin (35)); %page; /* Constants */ dcl FALSE bit (1) int static options (constant) init ("0"b); dcl TRUE bit (1) int static options (constant) init ("1"b); dcl NL char (1) int static options (constant) init (" "); /* the new-line character */ dcl FF char (1) int static options (constant) init (" "); /* the form feed character */ dcl STATION_PW_PROMPT char (23) static options (constant) init ("Enter station password:"); dcl both fixed bin int static options (constant) init (0); /* master and slave for iodd_msg_ */ dcl default_form_wait_time fixed bin int static options (constant) init (5); dcl error fixed bin int static options (constant) init (2); dcl error_message fixed bin int static options (constant) init (3); dcl head_banner fixed bin int static options (constant) init (1); dcl initial_print_rate fixed bin int static options (constant) init (3000); /* bits per second to the printer */ dcl initial_punch_rate fixed bin int static options (constant) init (500); /* same for the punch */ dcl line_length_default fixed bin int static options (constant) init (132); dcl line_length_max fixed bin int static options (constant) init (200); dcl line_length_min fixed bin int static options (constant) init (10); dcl log fixed bin int static options (constant) init (0); dcl lpi_default fixed bin int static options (constant) init (6); dcl lpi_max fixed bin int static options (constant) init (8); dcl lpi_min fixed bin int static options (constant) init (6); dcl master fixed bin int static options (constant) init (1); dcl minimum_quota fixed bin int static options (constant) init (10); dcl myname char (15) int static init ("remote_driver_") options (constant); dcl none fixed bin int static options (constant) init (0); dcl normal fixed bin int static options (constant) init (1); dcl page_length_default fixed bin int static options (constant) init (66); dcl page_length_max fixed bin int static options (constant) init (127); dcl page_length_min fixed bin int static options (constant) init (10); dcl pause_time_default fixed bin int static options (constant) init (10); dcl pause_time_max fixed bin int static options (constant) init (30); dcl printer_mode fixed bin int static options (constant) init (1); dcl printer_request fixed bin int static options (constant) init (1); dcl punch_raw_mode fixed bin int static options (constant) init (4); dcl punch_request fixed bin int static options (constant) init (2); dcl punch_rmcc_mode fixed bin int static options (constant) init (3); dcl request_command_level_state fixed bin int static options (constant) init (3); dcl runout_spacing_max fixed bin int static options (constant) init (60); dcl separator char (80) int static options (constant) init ((80)"<"); dcl slave fixed bin int static options (constant) init (2); dcl slave_login_tries fixed bin int static options (constant) init (10); dcl space char (1) int static options (constant) init (" "); dcl standard fixed bin int static options (constant) init (1); dcl tail_banner fixed bin int static options (constant) init (2); dcl wakeup_time_default fixed bin int static options (constant) init (30); dcl zero fixed bin int static options (constant) init (0); dcl zero_code fixed bin int static options (constant) init (0); /* Internal Static */ dcl alarm_channel fixed bin (71) int static; /* channel used for time out checks */ dcl ctl_msg_sent bit (1) int static init (FALSE); /* flag set when msg sent ok */ dcl default_printer pointer init (null ()) int static; /* default printer driver_status pointer for commands */ dcl default_punch pointer init (null ()) int static; /* default punch driver_status pointer for commands */ dcl hangup_proc_defined bit (1) int static; /* TRUE if the device hangup proc has been set */ dcl major_args_ptr ptr int static init (null); dcl minor_args_ptr ptr int static init (null); dcl my_area_ptr ptr int static init (null); dcl prt_rqt char (32) int static; dcl pun_rqt char (32) int static; dcl reader_attached bit (1) int static; /* TRUE if the read cards command can be used */ dcl save_request_label label int static; /* for transfer on save command at request cmd level */ dcl sys_priv bit (1) int static init ("1"b); /* ON means user can set privs */ dcl teleprinter_iocbp pointer init (null ()) int static; dcl terminal (2) char (32) int static; dcl time fixed bin (71) int static init (10); dcl 1 ctl_wait_list int static aligned, /* ipc wait list for the form terminal */ 2 number fixed bin, 2 channel fixed bin (71); dcl 1 event_info int static aligned, /* info returned from ipc_$block */ 2 chan fixed bin (71), 2 message fixed bin (71), 2 sender bit (36), 2 origin fixed bin, 2 wait_list_index fixed bin; %page; dcl 1 card_info aligned int static like card_stream_info; /* card input stream data */ dcl 1 smi aligned int static like send_mail_info; /* Builtins */ dcl (addr, after, before, char, character, clock, convert, copy, divide, index, length, ltrim, max, mod, null, rtrim, string, substr) builtin; /* Conditions */ dcl (any_other, card_command_level, cleanup, conversion, daemon_logout, daemon_new_device, daemon_slave_logout, linkage_error, no_coord, re_init, size) condition; /* EXTERNAL STATIC -- ERROR TABLE ENTRIES */ dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$fatal_error fixed bin (35) ext static; dcl error_table_$io_no_permission fixed bin (35) ext static; dcl error_table_$ionmat fixed bin (35) ext static; dcl error_table_$no_operation fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$no_forms_table_defined fixed bin (35) ext static; dcl error_table_$not_closed fixed bin (35) ext static; dcl error_table_$not_detached fixed bin (35) ext static; dcl error_table_$undefined_order_request fixed bin (35) ext static; dcl iox_$error_output ext ptr; %page; /* This entrypoint is used to initialize the driver for the major and any minor devices defined. It is called from iodd_. */ init: entry (a_argp); 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; stat_p = a_argp; /* put the arg into static for easy reference */ list_ptr = iodd_static.driver_list_ptr; /* find list of driver status segs */ text_strings_ptr = iodd_static.text_strings_ptr; /* get ptr to i/o daemon table text area */ if iodd_static.attach_type = ATTACH_TYPE_IOM then do; /* this driver expects a tty channel */ call iodd_msg_ (error, master, error_table_$fatal_error, myname, "The remote driver cannot attach to the IOM."); return; /* quit now */ end; do i = 1 to iodd_static.assigned_devices; /* initialize pointers for cleanup handler */ driver_ptr_list.stat_segp (i) -> driver_status.dev_out_iocbp = null (); driver_ptr_list.stat_segp (i) -> driver_status.dev_ctl_ptr = null (); end; teleprinter_iocbp = null; iodd_static.dev_io_stream, iodd_static.dev_in_stream = "Undefined_stream!"; /* we don't use these in this proc */ on cleanup call detach_device; /* this is the Type I station case "line: variable;" from iod_tables */ if iodd_static.attach_type = ATTACH_TYPE_VARIABLE_LINE then do; ltep = addr (iodd_static.ltp -> line_tab.entries (iodd_static.line_tab_idx)); major_terminal_module, major_comm_module, major_tty = ""; call ioa_$rsnnl (return_string (lte.att_desc), major_desc, len, lte.chan_id); teleprinter_iocbp = iodd_static.slave_in; /* copy the iocbp set by iodd_ */ station = iodd_static.major_device; /* these are the same for this case */ do i = 1 to iodd_static.assigned_devices; p = driver_ptr_list.stat_segp (i); p -> driver_status.attached = TRUE; /* all will be used now */ end; hangup_proc_defined = TRUE; /* this was set by iodd_ for this type */ end; else do; /* this is the Type II station case */ hangup_proc_defined = FALSE; /* be sure we set the hangup proc */ /* see if user wants major args to be found in a segment */ 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; 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; major_terminal_module, iodd_static.device_dim = iodd_parse_$args ("terminal=", major_args); major_comm_module = iodd_parse_$args ("comm=", major_args); major_tty = rtrim (iodd_static.attach_name); model = iodd_parse_$args ("model=", major_args); /* start building the attach description */ if iodd_static.attach_type = ATTACH_TYPE_DIAL then major_desc = "-tty ** -dial_id " || major_tty; else major_desc = "-tty " || major_tty; if major_terminal_module ^= "" then major_desc = major_desc || " -terminal " || major_terminal_module; if major_comm_module ^= "" then major_desc = major_desc || " -comm " || major_comm_module; major_desc = major_desc || space || iodd_parse_$args ("desc=", major_args); call iodd_msg_ (normal, master, zero_code, "", "Attaching terminal."); if iodd_parse_$args ("logout_on_hangup=", major_args) = "yes" then iodd_static.logout_on_hangup = TRUE; if iodd_parse_$args ("slave=", major_args) = "yes" then do; /* is device also the slave? */ iodd_static.slave_output = get_switch_name ("teleprinter"); iodd_static.slave_input = iodd_static.slave_output; /* make them the same */ attach_desc = "remote_teleprinter_ " || major_desc; /* build the real attach description */ opr_msg = "ATTACH"; call iox_$attach_ioname ((iodd_static.slave_output), teleprinter_iocbp, (attach_desc), code); if code ^= 0 & code ^= error_table_$ionmat & code ^= error_table_$not_detached then go to tp_err; opr_msg = "OPEN"; call iox_$open (teleprinter_iocbp, Stream_input_output, ""b, code); if code ^= 0 & code ^= error_table_$not_closed then do; tp_err: call iodd_msg_ (error, master, code, myname, "Unable to ""^a"" teleprinter for ^a.", opr_msg, iodd_static.attach_name); call iodd_msg_ (normal, master, zero_code, "", "Attach description: ^a", attach_desc); go to clean_out; end; call set_hangup_proc (teleprinter_iocbp); /* this will work or abort directly */ call iox_$put_chars (teleprinter_iocbp, addr (FF), 1, ignore_code); p2 = addr (status); /* set pointer so we can reference first word */ call ios_$attach ("broadcast_errors", "broadcast_", (iodd_static.slave_output), "", status); if p2 -> st_code = 0 then /* only switch error_output if this works */ call iox_$attach_ptr (iox_$error_output, "syn_ broadcast_errors", null, ignore_code); call iox_$control (teleprinter_iocbp, "read_status", addr (read_info), code); if code ^= 0 then do; /* this is fatal...can't accept input. */ call iodd_msg_ (error, master, code, myname, "Fatal error. Unable to order read_status for teleprinter."); go to clean_out; end; iodd_static.chan_list_ptr -> ev_chan_list.channel (slave) = read_info.read_ev_chan; iodd_static.slave_ev_chan = read_info.read_ev_chan; iodd_static.slave_out = teleprinter_iocbp; /* set the slave iocbp ptrs */ iodd_static.slave_in = teleprinter_iocbp; iodd_static.slave.active = TRUE; /* slave terminal is now defined */ end; /* if a ctl terminal was defined, let it remain and inherit its slave status from iodd_ unless */ /* it was changed above by slave= yes in the args */ if iodd_static.ctl_term.attached then do; ctl_wait_list.number = 1; ctl_wait_list.channel = iodd_static.ctl_ev_chan; alarm_channel = iodd_static.ctl_ev_chan; call iox_$modes (iodd_static.slave_in, "^hndlquit", omode, ignore_code); /* we reset read on quit */ end; else do; ctl_wait_list.number = 0; /* otherwise clear to avoid errors */ ctl_wait_list.channel = 0; alarm_channel = 0; end; if iodd_static.slave.active then do; /* set up switches for slave control */ iodd_static.slave.accept_input = TRUE; iodd_static.slave.allow_quits = TRUE; iodd_static.slave.print_errors = TRUE; if iodd_static.slave_output = iodd_static.ctl_output then iodd_static.slave.log_msg = FALSE; /* kill double messages */ else iodd_static.slave.log_msg = TRUE; /* send log msg to slave if not ctl terminal */ end; else do; iodd_static.slave.accept_input = FALSE; iodd_static.slave.allow_quits = FALSE; iodd_static.slave.print_errors = FALSE; iodd_static.slave.log_msg = FALSE; end; call iox_$look_iocb (iodd_static.slave_output, iodd_static.slave_out, code); if code ^= 0 then do; if iodd_static.slave.active then call iodd_msg_ (error, master, code, myname, "Slave functions terminated."); iodd_static.slave.active = FALSE; /* cannot be active */ iodd_static.slave.print_errors = FALSE; iodd_static.slave.allow_quits = FALSE; iodd_static.slave.accept_input = FALSE; end; /* get iocbp for station password */ call iox_$look_iocb (iodd_static.slave_input, iodd_static.slave_in, code); if code ^= 0 then do; /* no one home? */ if iodd_static.slave.active then call iodd_msg_ (normal, master, code, myname, "Slave input terminated."); iodd_static.slave.accept_input = FALSE; /* like we said */ end; /* find the device station so we can determine which minor devices to use */ station = iodd_parse_$args ("station=", major_args); /* station in major will over-ride */ if station ^= "" then do; /* got one, all minor devices will be used */ do i = 1 to iodd_static.assigned_devices; p = driver_ptr_list.stat_segp (i); /* get ptr to driver status seg */ p -> driver_status.attached = TRUE;/* mark it as attached */ end; need_station = FALSE; /* we don't need to look for station */ end; else do; need_station = TRUE; /* look to the device for the station */ if ^(iodd_static.slave.active & iodd_static.slave.accept_input) then do; call iodd_msg_ (error, master, error_table_$fatal_error, myname, "No slave device to request operator input from."); go to clean_out; end; call iodd_msg_ (normal, master, zero_code, "", "Requesting station identifier."); end; opr_msg = "Enter station command:" || NL; /* ready to ask for device station */ do tries = 1 to 10 while (need_station); /* try up to 10 times before giving up */ call iox_$put_chars (iodd_static.slave_out, addr (opr_msg), length (rtrim (opr_msg)), code); if code ^= 0 then do; try_to_recover: call iodd_msg_ (error, master, code, myname, "Trouble initializing device. Starting reinitialization."); call drop_device; iodd_static.re_init_in_progress = TRUE; go to iodd_static.re_init_label; end; call iox_$control (iodd_static.slave_out, "runout", null, ignore_code); input_line = ""; /* clear any junk */ call iox_$get_line (iodd_static.slave_in, addr (input_line), length (input_line), nchar, code); if code ^= 0 then go to try_to_recover; station = before (iodd_parse_$args ("station", input_line), " "); /* see if it is a good command */ station_password = rtrim (ltrim (after (iodd_parse_$args ("station", input_line), " "))); if station ^= "" then do; /* if defined, check it out */ if station_password = "" then /* ... left off password: ask for it */ call read_password_$switch (iodd_static.slave_out, iodd_static.slave_in, STATION_PW_PROMPT, station_password, ignore_code); if station_password = "*" then /* ... user really wants a blank password */ station_password = ""; if station_password ^= "" then do; temp_password = station_password; station_password = scramble_ (temp_password); temp_password = ""; end; call validate_card_input_$station (station, station_password, err_msg, code); if code ^= 0 then do; call iodd_msg_ (normal, both, zero_code, "***", "^a: ^a", err_msg, station); go to enter_again; /* ask the question once more */ end; else do i = 1 to iodd_static.assigned_devices; /* look at each minor device */ p = driver_ptr_list.stat_segp (i); /* get ptr to driver status seg */ /* see if user wants minor args to be found in a segment */ minor_args_name = iodd_parse_$args ("indirect=", return_string (p -> driver_status.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; else do; /* 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; end; if station = iodd_parse_$args ("station=", minor_args) then do; /* match? */ need_station = FALSE; /* we found a good one */ p -> driver_status.attached = TRUE; /* mark it as attached */ end; else p -> driver_status.attached = FALSE; /* this one is invalid */ end; if need_station then do; /* indicate an error to the operator */ err_msg = "No minor device for station: " || station; call iodd_msg_ (normal, both, zero_code, "***", err_msg); end; end; else do; /* no valid "STATION" command card */ call iodd_msg_ (normal, both, zero_code, "***", "No station command given."); end; enter_again: end; if tries > slave_login_tries then go to logout_slave; /* after 10 times, give up */ call iodd_msg_ (log, master, zero_code, "", "Driver initializing for station: ^a", station); end; /* This is where the two attach types are again handled the same */ terminal (master) = "user_output"; /* master terminal output stream for read_cards command */ terminal (slave) = iodd_static.slave_output; /* For each minor device marked as attached, find the type of device it is */ prt_rqt = "printer"; /* default the request type names to standard */ pun_rqt = "punch"; reader_attached = FALSE; /* reader not available yet */ default_printer = null (); /* no driver status seg for printer yet */ default_punch = null (); /* or for the punch */ printer_count, punch_count = 0; /* but count them as they are found */ rqt_string = ""; /* no request types defined for this station yet */ 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 */ iodd_static.current_devices = 0; /* haven't found any good ones yet */ ready_device = FALSE; /* none of them are ready yet either */ do i = 1 to iodd_static.assigned_devices; p = driver_ptr_list.stat_segp (i); p -> driver_status.ready = FALSE; /* printer devices will honor auto_go */ p -> driver_status.generic_type = ""; /* not defined yet */ p -> driver_status.form_wait_time = default_form_wait_time; /* default wait time per ctl msg */ 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 = "printer" then do; /* check if defined */ if p -> driver_status.attached then do; /* only use the attached one */ if iodd_static.paper_type = PAPER_TYPE_SINGLE then do; if model = "" then model = iodd_parse_$args ("model=", minor_args); if model ^= "" then major_desc = major_desc || space || "-model " || model; end; call iodd_msg_ (normal, both, zero_code, "", "^/Initializing printer device: ^a", p -> driver_status.device_id); printer_count = printer_count + 1; p -> driver_status.generic_type = "printer"; /* only printer functions can be done */ call minor_attach ("printer"); if printer_count = 1 then default_printer = p; prt_rqt = p -> driver_status.req_type_label; /* get the request type */ if index (prt_rqt, ".") > 0 then prt_rqt = before (prt_rqt, "."); /* strip off device class */ call set_iod_val ("request_type", rtrim (prt_rqt)); if index (rqt_string, rtrim (prt_rqt)) = 0 then rqt_string = rqt_string || " " || rtrim (prt_rqt); p -> driver_status.elem_size = BITS_PER_CHAR; p -> driver_status.message_type = printer_request; /* expected dprint message type */ 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_print_rate; /* set starting estimate */ allocate prt_ctl set (p -> driver_status.dev_ctl_ptr); call get_prt_rqti_data (p); /* find the request type info data for printer */ call iox_$control (p -> driver_status.dev_out_iocbp, "channel_stops", addr (prt_ctl.channel_stops), code); if code ^= 0 then do; call iodd_msg_ (normal, both, code, myname, "Bad channel_stops order to printer."); go to logout_slave; end; call set_paper_info (slave, code); if code ^= 0 then go to logout_slave; /* proc gave the message */ end; end; else if device_type = "punch" then do; if p -> driver_status.attached then do; /* only use the attached one */ call iodd_msg_ (normal, both, zero_code, "", "^/Initializing punch device: ^a", p -> driver_status.device_id); punch_count = punch_count + 1; p -> driver_status.generic_type = "punch"; /* only punch functions for this one */ call minor_attach ("punch"); if punch_count = 1 then default_punch = p; /* record the default status seg ptr */ pun_rqt = p -> driver_status.req_type_label; /* get the request type */ if index (pun_rqt, ".") > 0 then pun_rqt = before (pun_rqt, "."); /* strip off device class */ call set_iod_val ("pun_rqt", rtrim (pun_rqt)); if index (rqt_string, rtrim (pun_rqt)) = 0 then rqt_string = rqt_string || " " || rtrim (pun_rqt); p -> driver_status.elem_size = BITS_PER_CHAR; /* in this driver, this is just a place holder */ p -> driver_status.message_type = punch_request; /* type of dprint msg expected */ 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; allocate pun_ctl set (p -> driver_status.dev_ctl_ptr); pun_ctl_ptr = p -> driver_status.dev_ctl_ptr; pun_ctl.sep_cards = standard; /* set the default control parms */ pun_ctl.auto_punch = FALSE; /* make the operator switch to autopunch if desired */ if p -> driver_status.rqti_ptr ^= null then call iodd_msg_ (normal, master, zero_code, myname, "This driver cannot decode a punch rqti seg."); end; end; else if device_type = "reader" then do; /* this is only a dummy minor device used */ /* to get the attach desc for the reader */ if p -> driver_status.attached then do; /* only use the attached one */ p -> driver_status.attached = FALSE; /* it is never attached as far as */ /* the coordinator is concerned */ if reader_attached then do; call iodd_msg_ (normal, master, zero_code, myname, "Multiple reader devices specified. Device ^a ignored.", p -> driver_status.device_id); end; else do; call iodd_msg_ (normal, both, zero_code, "", "^/Initializing reader device: ^a", p -> driver_status.device_id); p -> driver_status.generic_type = "card_rdr"; call minor_attach ("reader"); reader_attached = TRUE; /* tell the read_cards command it can work */ card_info.n_streams = 1; /* remote_driver only supports one format */ card_info.format (1) = "rmcc";/* and that's like MCC */ card_info.control_stream, card_info.name (1) = p -> driver_status.dev_out_stream; /* use the same stream for data */ card_info.el_size (1) = BITS_PER_CHAR; /* input is in characters of 9 bits each */ end; end; end; else do; /* someone slipped in a zinger */ call iodd_msg_ (normal, master, zero_code, myname, "Invalid ""dev="" arg ""^a"" for minor device ^a.", device_type, p -> driver_status.device_id); p -> driver_status.attached = FALSE; /* can't be attached in this case */ end; end; if iodd_static.current_devices = 0 then do; /* trouble */ err_msg = "No minor devices found with ""dev="" arg which is known to this driver."; call iodd_msg_ (error, master, zero_code, myname, err_msg); code = 0; go to logout_slave; /* drop this one */ end; if printer_count > 1 then do; default_printer = null; /* no default if more than one */ prt_rqt = "printer"; call set_iod_val ("request_type", rtrim (prt_rqt)); end; if punch_count > 1 then do; default_punch = null; /* no default if more than one */ pun_rqt = "punch"; call set_iod_val ("pun_rqt", rtrim (pun_rqt)); end; call set_iod_val ("rqt_string", (rqt_string)); call set_iod_val ("station_id", rtrim (station)); iodd_static.admin_ec_name = rtrim (station) || "_admin.ec"; call read_cards_$set_station (station, ignore_code); call read_cards_$set_rqt (prt_rqt, pun_rqt, ignore_code); /* pass default rqt's to card input proc */ iodd_static.form_type = iodd_parse_$args ("form_type=", major_args); /* set form type */ if iodd_static.form_type = "" then iodd_static.form_type = "std_ctl_msg"; /* if not found... */ iodd_static.slave_hold = ^ready_device; /* issue a "go" if at least one device is ^ready */ smi.version = -1; /* init to known state */ call date_time_ (clock (), date_string); /* get set for ready message */ call iodd_msg_ (normal, both, zero_code, "", "^/^a driver on channel ^a ready at ^16a^/", iodd_static.major_device, iodd_static.attach_name, date_string); call iodd_listen_ (stat_p); /* This is only for error recovery during initialization. The listener will never return here. */ clean_out: call drop_device; if iodd_static.attach_type = ATTACH_TYPE_VARIABLE_LINE then do; /* new style, detach and wait for dialup */ iodd_static.re_init_in_progress = TRUE; go to iodd_static.re_init_label; end; return; logout_slave: /* logout the slave device but not the process */ iodd_static.re_init_in_progress = TRUE; /* we do this by re-initializing the driver */ call date_time_ (clock (), date_string); /* get set for message */ iodd_static.slave.log_msg = TRUE; /* send to log and slave */ call iodd_msg_ (log, both, zero_code, "", "Logout for station: ^a at ^a", station, date_string); if iodd_static.slave_out ^= null () then do; call iox_$control (iodd_static.slave_out, "runout", null, ignore_code); call iox_$control (iodd_static.slave_out, "end_write_mode", null, ignore_code); end; call drop_device; call iodd_msg_ (normal, master, zero_code, "", "Driver starting re-initialization."); go to iodd_static.re_init_label; /* this will do everything */ drop_device: procedure (); dcl send_hangup bit (1); /* internal proc to issue a hangup to the device before detaching */ send_hangup = TRUE; /* tell close_and_detach proc to send hangup */ go to device_common; detach_device: entry (); send_hangup = FALSE; /* no send hangup */ device_common: if iodd_static.ctl_term.attached then if iodd_static.ctl_output ^= iodd_static.slave_output then iodd_static.slave.active = FALSE; /* if ctl term is slave, leave it to iodd_ */ else ; else iodd_static.slave.active = FALSE; /* if no ctl terminal, no slave is left */ call close_and_detach (teleprinter_iocbp, send_hangup); list_ptr = iodd_static.driver_list_ptr; do i = 1 to iodd_static.assigned_devices; p = driver_ptr_list.stat_segp (i); call close_and_detach (p -> driver_status.dev_out_iocbp, send_hangup); if p -> driver_status.dev_ctl_ptr ^= null then free p -> driver_status.dev_ctl_ptr -> prt_ctl; /* free the prt_ctl or pun_ctl structures */ /* Lucky free dosn't care about the structure name */ end; call continue_to_signal_ (ignore_code); /* in case this is called from a handler */ return; end drop_device; %page; request: entry; /* This entry is called by iodd_listen_ when a request has been received from the coordinator for either of the logical drivers servicing the remote device. Here we just check to be sure that we can understand the request format and the requested print or punch data format. Then the request is passed on to the proc which can handle that type of request. */ /* for cleanup handler */ evaluate_forms_info_input_ptr, evaluate_forms_info_output_ptr = null; 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, zero_code, "", "Invalid message header. Cannot read request ^d.^d.", p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q); p2 -> request_descriptor.keep_in_queue = TRUE; /* 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, zero_code, "", /* 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 = TRUE; /* we don't want this one again */ be_nice: p2 -> request_descriptor.dont_delete = TRUE; /* save the user's data */ p2 -> request_descriptor.finished = TRUE; /* mark it done */ return; /* it wasn't for us after all */ end; if dprint_msg.version ^= dprint_msg_version_3 /* Previous version */ & dprint_msg.version ^= dprint_msg_version_4 /* Previous version */ & dprint_msg.version ^= dprint_msg_version_5 /* Current version */ then do; /* other trouble? */ call iodd_msg_ (log, both, zero_code, "", "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 = TRUE; go to be_nice; end; if dprint_msg.version < dprint_msg_version_4 then /* Disallow -line_nbrs before version 4 */ dprint_msg.control.line_nbrs = FALSE; format_code = dprint_msg.output_module; /* get the user defined format */ if format_code = printer_mode then do; /* if printer, check line length */ prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* find the control info for this printer */ call evaluate_forms_options (code); /* validate forms data */ if code ^= 0 then do; call iodd_msg_ (log, both, zero_code, "", "Request ^d.^d for ^a (segment ^a) deferred.^/Forms evaluation error '^a'", p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q, p2 -> request_descriptor.mseg_message_info_copy.sender_id, dmp -> queue_msg_hdr.ename, evaluate_forms_info_output.error_string); p2 -> request_descriptor.keep_in_queue = TRUE; /* defer it */ if evaluate_forms_info_output_ptr ^= null then free evaluate_forms_info_output; go to be_nice; end; /* adjust prt_ctl accordingly */ if dprint_msg.line_lth > prt_ctl.phys_line_length then do; /* platten wide enough */ call iodd_msg_ (log, both, zero_code, "", "Request ^d.^d for ^a (segment ^a) deferred.^/Requires a device with line length of ^d.", p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q, p2 -> request_descriptor.mseg_message_info_copy.sender_id, dmp -> queue_msg_hdr.ename, dprint_msg.line_lth); p2 -> request_descriptor.keep_in_queue = TRUE; /* defer it */ go to be_nice; end; end; else if format_code = punch_raw_mode then do; /* for binary output */ element_size = 1; /* treat as 1 bit at a time */ end; else if format_code = punch_rmcc_mode then do; /* for character output */ element_size = BITS_PER_CHAR; /* for output_request_ */ end; else do; /* be sure it is defined */ call iodd_msg_ (log, both, zero_code, "", "Undefined output module 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 = TRUE; /* we don't want this one again */ go to be_nice; end; iodd_static.quit_during_request = FALSE; /* start clean */ ctl_msg_sent = FALSE; /* initialize to no msg yet */ save_request_label = save_return; /* init for non-local transfer on save command */ on cleanup begin; if p ^= null () then /* this one should never be null, but ... */ if p -> driver_status.dev_out_iocbp ^= null () then call iox_$control (p -> driver_status.dev_out_iocbp, "end_write_mode", null, ignore_code); if evaluate_forms_info_input_ptr ^= null then free evaluate_forms_info_input; if evaluate_forms_info_output_ptr ^= null then free evaluate_forms_info_output; end; /* let the I/O Module send an EOF if needed */ if dprint_msg.message_type = printer_request then do; call do_prt_request_ (p -> driver_status.dev_out_iocbp, stat_p, code); if evaluate_forms_info_output_ptr ^= null then free evaluate_forms_info_output; /* this one is for the printer only */ end; else do; call output_request_ ((p -> driver_status.dev_out_stream), element_size, stat_p, print_banner, code); end; if code ^= 0 then do; iodd_static.slave_hold = TRUE; /* 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; save_return: /* return point for save command at request cmd level */ 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, RELATIVE_SECONDS); /* 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 /* simulate device */ call timer_manager_$sleep (time, RELATIVE_SECONDS); end; else do; /* this is a real error */ call iodd_msg_ (error, master, code, myname, "From ""end_write_mode"" control"); iodd_static.slave_hold = TRUE; end; if iodd_static.slave.active then /* flush any messages */ call iox_$control (iodd_static.slave_out, "runout", null, ignore_code); return; %page; /* This entrypoint is used to output the head/tail banner cards for a punch request. It is referenced in the call to output_request_. */ print_banner: entry (a_stream, a_banner_type, a_data_ptr, a_code); stream = a_stream; banner_type = a_banner_type; ordatap = a_data_ptr; 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 */ dmp = addr (p -> driver_status.message); /* get message ptr */ iocbp = p -> driver_status.dev_out_iocbp; /* get iocbp for control and writes */ if dprint_msg.message_type ^= punch_request then do; /* this proc is for dpunch type message banner */ code = error_table_$action_not_performed; /* return an error */ go to banner_ret; end; pun_ctl_ptr = p -> driver_status.dev_ctl_ptr; /* get ready for using pun_ctl structure */ if banner_type = head_banner then do; /* this is for the header */ iodd_static.quit_during_request = FALSE; /* start watching now */ if iodd_static.ctl_term.attached then do; /* are we to inform the ctl terminal? */ call write_control_form_ (iodd_static.form_type, iodd_static.ctl_output, ordatap, code); if code ^= 0 then do; if code ^= error_table_$action_not_performed then do; /* this is normal */ call iodd_msg_ (error, master, code, myname, "Writing message to control terminal."); iodd_static.slave_hold = TRUE;/* go back to command level when done */ end; ctl_msg_sent = FALSE; /* don't wait now */ code = 0; /* we handled it */ end; else ctl_msg_sent = TRUE; /* all set */ if ctl_wait_list.number = 1 then call set_wait_timer; end; else ctl_msg_sent = FALSE; format_code = dprint_msg.output_module; /* get the punch format code */ if format_code = punch_raw_mode then arg_string = "raw"; /* set name for messages */ else arg_string = "rmcc"; /* this is the default */ if ^pun_ctl.auto_punch then do; /* are we to come to command level */ on conversion begin; call iodd_msg_ (normal, source, zero_code, "", "Argument conversion error. Try again."); go to ask; end; on size begin; call iodd_msg_ (normal, source, zero_code, "", "Argument numerical size error. Try again."); go to ask; end; /* set to wait for input, no prompt master for command and to prompt slave for input */ control = "101"b; call iodd_msg_ (log, slave, zero_code, "", " Deck punch format: ^a.", arg_string); ask: call iodd_get_cmd_ (addr (input_line), length (input_line), len, control, "request", source, code); if code ^= 0 then do; /* this is bad news */ iodd_static.slave_hold = TRUE; /* go back to command level */ go to banner_ret; end; call iodd_parse_$command (substr (input_line, 1, len), addr (cmd_list), code); if code ^= 0 then do; if code = error_table_$noarg then go to ask; call iodd_msg_ (normal, source, code, myname, "Unable to parse command line."); go to ask; end; if cmd_list.cmd = "help" then do; /* check which command was given */ call iodd_msg_ (normal, source, zero_code, "", "Standard driver commands may be used, plus:^/"); call iodd_msg_ (normal, source, zero_code, "", " copy N -set the current copy number to N"); call iodd_msg_ (normal, source, zero_code, "", " req_status -get the copy and request numbers"); call iodd_msg_ (normal, source, zero_code, "", " punch -start data transfer"); go to ask; end; if cmd_list.cmd = "copy" then do; if cmd_list.number_tokens_found ^= 2 then do; /* we must have 2 args which includes the N part */ bad_copy_arg: call iodd_msg_ (normal, source, zero_code, "", "Invalid or missing argument. Use copy N to set current copy number."); go to ask; end; value = convert (value, cmd_list.arg (1)); /* convert char to fixed bin */ if value < 1 | value > ordata.copies then go to bad_copy_arg; ordata.copy_no = value; /* passed checks, so set the new current copy number */ go to ask; /* see what is next */ end; if cmd_list.cmd = "req_status" | cmd_list.cmd = "reqstatus" then do; call iodd_msg_ (normal, source, zero_code, "", "Request ^d: ^a^/^3xCurrent copy no: ^d of ^d Punch format: ^a", ordata.request_no, ordata.full_path, ordata.copy_no, ordata.copies, arg_string); go to ask; end; if cmd_list.cmd = "debug" & iodd_static.test_entry & source = master then do; call iodd_msg_ (normal, master, zero_code, "", "Calling debug"); call debug (); go to ask; end; if (cmd_list.cmd = "probe" | cmd_list.cmd = "pb") & iodd_static.test_entry & source = master then do; call iodd_msg_ (normal, master, zero_code, "", "Calling probe"); call probe (); go to ask; end; if cmd_list.cmd ^= "punch" then do; /* all but the punch command go to std cp */ call iodd_command_processor_ (source, request_command_level_state, substr (input_line, 1, len), code); if code = 1 | code = 2 then do; /* wants to go or start */ if code = 2 & cmd_list.cmd = "save" then go to save_request_label; call iodd_msg_ (normal, source, zero_code, "", "Invalid command. Try again. - ^a", cmd_list.cmd); end; go to ask; end; end; call iox_$control (iocbp, "reset", null, code); /* clear modes and counts for all requests */ if code ^= 0 then go to banner_ret; if dprint_msg.output_module = punch_raw_mode then do; /* binary punch request */ call iox_$control (iocbp, "binary_punch", null, code); /* set binary mode */ if code ^= 0 then do; /* OOPS, drop this request */ call iodd_msg_ (normal, slave, zero_code, myname, "Unable to set binary punch mode"); end; go to banner_ret; end; else if pun_ctl.sep_cards = standard then do;/* separator cards are for character punching only */ req_string = ltrim (char (ordata.request_no)); /* get number as characters */ header_card2 = ""; /* clear the second header card */ pos = 1; /* where the next output char position is */ do idx = 1 to length (rtrim (req_string)); /* once for each digit */ digit = substr (req_string, idx, 1); /* pick it up */ substr (header_card2, pos, 5) = copy (digit, 5); /* repeat it 5 times */ pos = pos + 7; /* bump the counter, leaving 2 spaces */ end; substr (header_card2, pos + 5) = ordata.requestor; /* add on the requestor name */ call iox_$put_chars (iocbp, addr (separator), length (separator), code); if code ^= 0 then go to banner_ret; call iox_$put_chars (iocbp, addr (header_card2), length (header_card2), code); if code ^= 0 then go to banner_ret; call iox_$put_chars (iocbp, addr (separator), length (separator), code); if code ^= 0 then go to banner_ret; call iox_$control (iocbp, "runout", null, code); if code ^= 0 then go to banner_ret; call iox_$control (iocbp, "reset", null, code); end; end; else if banner_type = tail_banner then do; /* time for the tail banner */ if pun_ctl.sep_cards = standard & dprint_msg.output_module ^= punch_raw_mode then do; do i = 1 to 2; call iox_$put_chars (iocbp, addr (separator), length (separator), code); if code ^= 0 then go to banner_ret; end; end; if ctl_wait_list.number = 1 then call wait_for_ctl_finish; end; else if banner_type = error_message then do; /* this is for an error message */ /* when we can punch in binary, we can write flip cards here */ end; /* all other banners are undefined. */ else code = error_table_$action_not_performed; banner_ret: a_code = code; if code ^= 0 then p2 -> request_descriptor.keep_in_queue = TRUE; /* defer the request */ return; %page; /* This is the command processor for special commands recognized by the remote driver. Any unrecognized commands will be passed back to the general I/O daemon command processor for execution. */ 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; terminal (2) = iodd_static.slave_output; /* in case it has changed */ on conversion begin; /* handler for conversion errors */ call iodd_msg_ (normal, source, zero_code, "", "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, zero_code, "", "^/** Commands for the remote driver **^/"); call iodd_msg_ (normal, source, zero_code, "", "banner_bars [] [single | double | none]"); call iodd_msg_ (normal, source, zero_code, "", "banner_type [] [standard | brief | none]"); call iodd_msg_ (normal, source, zero_code, "", "clean_pool "); call iodd_msg_ (normal, source, zero_code, "", "paper_info [] [-ll ] [-pl ] [-lpi <6 or 8>]"); call iodd_msg_ (normal, source, zero_code, "", "pause_time []"); call iodd_msg_ (normal, source, zero_code, "", "prt_control [] [^]KEY ... (KEYs: force_nep, force_esc, force_ctl_char, force_nsep, autoprint)" ); call iodd_msg_ (normal, source, zero_code, "", "pun_control [] [^]autopunch)"); call iodd_msg_ (normal, source, zero_code, "", "read_cards"); call iodd_msg_ (normal, source, zero_code, "", "runout_spacing "); call iodd_msg_ (normal, source, zero_code, "", "sample_hs []"); call iodd_msg_ (normal, source, zero_code, "", "sample_form"); call iodd_msg_ (normal, source, zero_code, "", "sep_cards [] [standard | none]"); call iodd_msg_ (normal, source, zero_code, "", "single"); go to end_cmd; end; if command = "ctl_term" | command = "ctlterm" then do; /* this was passed on by iodd_command_processor_ */ /* to have us set the default form type */ iodd_static.form_type = "std_ctl_msg"; /* this is our default */ do i = 1 to iodd_static.assigned_devices; p = driver_ptr_list.stat_segp (i); /* get ptr to driver status seg */ p -> driver_status.form_wait_time = default_form_wait_time; /* set the default wait time */ end; go to end_cmd; end; if command = "banner_bars" | command = "bannerbars" then do; if arg_list.n_tokens > 2 then do; p = find_driver_status_seg_ptr (arg_list.arg (1)); /* get driver status ptr for minor device given */ i = 2; /* arg 2 is the value argument */ end; else do; /* one arg - could be value for default or ... */ /* could be minor device name with no value */ p = default_printer; /* try for the default printer */ i = 1; /* assume first arg is the value */ end; value = -1; /* no value defined yet */ if arg_list.n_tokens > 1 then do; /* allow for no args at all */ if arg_list.arg (i) = "-print" then value = -1; else if arg_list.arg (i) = "double" then value = NORMAL_BANNER_BARS; else if arg_list.arg (i) = "single" then value = SINGLE_BANNER_BARS; else if arg_list.arg (i) = "none" then value = NO_BANNER_BARS; else p = find_driver_status_seg_ptr (arg_list.arg (i)); end; if p = null () then do; no_printer: if arg_list.n_tokens = 1 then opr_msg = "not specified."; else opr_msg = "not found: " || arg_list.arg (i); call iodd_msg_ (normal, source, zero_code, "", "Printer minor device ^a", opr_msg); go to cmd_error; end; if p -> driver_status.generic_type ^= "printer" then do; /* printer functions are only for printers */ not_a_printer: call iodd_msg_ (normal, source, zero_code, "", "Minor device ""^a"" is not a printer.", p -> driver_status.device_id); go to cmd_error; end; prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control structure pointer */ if value = -1 then do; if prt_ctl.banner_bars = NORMAL_BANNER_BARS then opr_msg = "double"; else if prt_ctl.banner_bars = SINGLE_BANNER_BARS then opr_msg = "single"; else if prt_ctl.banner_bars = NO_BANNER_BARS then opr_msg = "none"; else opr_msg = "Undefined value"; call iodd_msg_ (normal, source, zero_code, "", "Current value is: ^a", opr_msg); end; else prt_ctl.banner_bars = value; go to end_cmd; end; if command = "pause_time" | command = "pausetime" then do; if arg_list.n_tokens > 1 then do; value = convert (value, arg_list.arg (1)); if value < zero | value > pause_time_max then do; call iodd_msg_ (normal, source, zero_code, "", "pause_time range: ^d to ^d seconds ", zero, pause_time_max); go to cmd_error; end; time = value; go to end_cmd; end; else do; time = pause_time_default; /* return to the default */ go to end_cmd; end; end; if command = "runout_spacing" | command = "runoutspacing" then do; if arg_list.n_tokens > 1 then do; value = convert (value, arg_list.arg (1)); if value < zero | value > runout_spacing_max then do; /* legal range? */ call iodd_msg_ (normal, source, zero_code, "", "runout_spacing range is ^d to ^d lines.", zero, runout_spacing_max); go to cmd_error; end; call iox_$control (teleprinter_iocbp, "runout_spacing", addr (value), code); if code ^= 0 then do; call iodd_msg_ (normal, source, zero_code, "", "Unable to set runout spacing for remote device."); go to cmd_error; end; go to end_cmd; end; else do; call iodd_msg_ (normal, source, zero_code, "", "The runout_spacing command must have an argument"); go to cmd_error; end; end; if command = "paper_info" | command = "paperinfo" then do; if arg_list.n_tokens > 1 then p = find_driver_status_seg_ptr (arg_list.arg (1)); /* see if first arg matches a minor device */ else p = null; if mod (arg_list.n_tokens, 2) = 0 then /* odd number of args to cmd, first must be minor device */ i = 2; /* control args start with arg 2 */ else do; /* even number of args, wants default or made typing error */ if p ^= null then do; /* valid minor device name. operator typing error? */ if arg_list.arg (2) ^= "-print" then do; /* allow this exception */ call iodd_msg_ (normal, source, zero_code, myname, "Incorrect number of arguments. Pairs of arguments follow minor device."); go to cmd_error; end; i = 2; /* for the next arg test */ end; else do; p = default_printer; i = 1; end; end; if p = null () then go to no_printer; if p -> driver_status.generic_type ^= "printer" then go to not_a_printer; /* only allow printers */ prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control pointer for this driver */ /* not enough args to change data, so print it */ if i >= arg_list.n_tokens | arg_list.arg (i) = "-print" then do; call iodd_msg_ (normal, source, zero_code, "", "Physical paper width: ^d characters.^/Physical paper length: ^d lines at ^d lines per inch.", prt_ctl.phys_line_length, prt_ctl.phys_page_length, prt_ctl.lines_per_inch); go to end_cmd; end; new_ll = prt_ctl.phys_line_length; new_pl = prt_ctl.phys_page_length; new_lpi = prt_ctl.lines_per_inch; do i = i to n_tokens - 1 by 2; /* check the arg pairs */ if arg_list.arg (i) = "-ll" then new_ll = convert (new_ll, arg_list.arg (i + 1)); else if arg_list.arg (i) = "-pl" then new_pl = convert (new_pl, arg_list.arg (i + 1)); else if arg_list.arg (i) = "-lpi" then new_lpi = convert (new_lpi, arg_list.arg (i + 1)); else do; /* bad control arg */ call iodd_msg_ (normal, source, zero_code, "", "Invalid control argument: ^a", arg_list.arg (i)); go to cmd_error; end; end; if new_ll < line_length_min | new_ll > line_length_max then do; /* check the range */ call iodd_msg_ (normal, source, zero_code, "", "Line length range is ^d to ^d.", line_length_min, line_length_max); go to cmd_error; end; if ^(new_lpi = lpi_min | new_lpi = lpi_max) then do; call iodd_msg_ (normal, source, zero_code, "", "Lines per inch must be ^d or ^d.", lpi_min, lpi_max); go to cmd_error; end; if new_pl < page_length_min then do; call iodd_msg_ (normal, source, zero_code, "", "Minimum paper length is ^d lines.", page_length_min); go to cmd_error; end; if new_pl > page_length_max then do; call iodd_msg_ (normal, source, zero_code, "", "Maximum paper length is ^d lines.", page_length_max); go to cmd_error; end; prt_ctl.phys_line_length = new_ll; prt_ctl.phys_page_length = new_pl; prt_ctl.lines_per_inch = new_lpi; call iodd_msg_ (normal, source, zero_code, "", "Changing to: ll ^d, pl ^d at ^d lines per inch.", prt_ctl.phys_line_length, prt_ctl.phys_page_length, prt_ctl.lines_per_inch); call set_paper_info (source, code); if code ^= 0 then go to cmd_error; go to end_cmd; end; if command = "prt_control" | command = "prtcontrol" then do; if arg_list.n_tokens > 1 then p = find_driver_status_seg_ptr (arg_list.arg (1)); /* see if first arg matches a minor device */ else p = null; if p ^= null then /* first arg was a valid minor device name */ i = 2; /* value args start with arg 2 */ else do; /* wants default or made typing error */ p = default_printer; /* try for the default printer device */ i = 1; /* arg one starts the value */ end; if p = null () then go to no_printer; if p -> driver_status.generic_type ^= "printer" then go to not_a_printer; /* only allow printers */ prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control pointer for this driver */ if arg_list.n_tokens <= i | arg_list.arg (i) = "-print" then do; call iodd_msg_ (normal, source, zero_code, "", "Current values are: ^[^^^]force_nep, ^[^^^]force_esc, ^[^^^]force_ctl_char, ^[^^^]force_nsep, ^[^^^]auto_print", ^prt_ctl.force_nep, ^prt_ctl.force_esc, ^prt_ctl.force_ctl_char, ^prt_ctl.force_nsep, prt_ctl.no_auto_print); go to end_cmd; end; do i = i to n_tokens - 1; /* look at each argument */ not = (substr (arg_list.arg (i), 1, 1) = "^"); /* was first char a "^" */ if not then arg_string = substr (arg_list.arg (i), 2); else arg_string = arg_list.arg (i); if arg_string = "force_nep" | arg_string = "forcenep" then prt_ctl.force_nep = ^not; else if arg_string = "force_esc" | arg_string = "forceesc" then prt_ctl.force_esc = ^not; else if arg_string = "force_ctl_char" | arg_string = "forcectlchar" then prt_ctl.force_ctl_char = ^not; else if arg_string = "auto_print" | arg_string = "autoprint" then prt_ctl.no_auto_print = not; else if arg_string = "force_nsep" | arg_string = "forcensep" then prt_ctl.force_nsep = ^not; else call iodd_msg_ (normal, source, zero_code, "", "Undefined argument: ^a", arg_list.arg (i)); end; go to end_cmd; end; if command = "banner_type" | command = "bannertype" then do; if arg_list.n_tokens > 2 then do; p = find_driver_status_seg_ptr (arg_list.arg (1)); /* get driver status ptr for minor device given */ i = 2; /* arg 2 is the value argument */ end; else do; /* one arg - could be value for default or ... */ /* could be minor device name with no value */ p = default_printer; /* try for the default printer */ i = 1; /* assume first arg is the value */ end; value = -1; /* no value defined yet */ if arg_list.n_tokens > 1 then do; /* allow for no args at all */ if arg_list.arg (i) = "-print" then value = -1; else if arg_list.arg (i) = "none" then value = NO_BANNERS; else if arg_list.arg (i) = "standard" then value = NORMAL_BANNERS; else if arg_list.arg (i) = "brief" then value = BRIEF_BANNERS; else p = find_driver_status_seg_ptr (arg_list.arg (i)); end; if p = null () then go to no_printer; if p -> driver_status.generic_type ^= "printer" then go to not_a_printer; /* only allow printers */ prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control structure pointer */ if value = -1 then do; /* print the current value */ if prt_ctl.banner_type = NO_BANNERS then opr_msg = "none"; else if prt_ctl.banner_type = NORMAL_BANNERS then opr_msg = "standard"; else if prt_ctl.banner_type = BRIEF_BANNERS then opr_msg = "brief"; else opr_msg = "Undefined value"; call iodd_msg_ (normal, source, zero_code, "", "Current value is: ^a", opr_msg); end; else prt_ctl.banner_type = value; go to end_cmd; end; if command = "sample_hs" | command = "samplehs" then do; i = arg_list.n_tokens - 1; /* define this in case of error */ if arg_list.n_tokens = 1 then p = default_printer; else p = find_driver_status_seg_ptr (arg_list.arg (1)); if p = null () then go to no_printer; if p -> driver_status.generic_type ^= "printer" then go to not_a_printer; /* only allow printers */ prt_ctl_ptr = p -> driver_status.dev_ctl_ptr; call iox_$control (p -> driver_status.dev_out_iocbp, "reset", null, ignore_code); /* clear everything */ call iox_$control (p -> driver_status.dev_out_iocbp, "inside_page", null, ignore_code); call write_sample_prt_banner_ ("head_sheet", p -> driver_status.dev_out_iocbp, prt_ctl_ptr, ignore_code); call iox_$control (p -> driver_status.dev_out_iocbp, "end_of_page", null, ignore_code); call iox_$control (p -> driver_status.dev_out_iocbp, "runout", null, ignore_code); /* be sure it prints */ call iox_$control (p -> driver_status.dev_out_iocbp, "end_write_mode", null, ignore_code); call timer_manager_$sleep (time, RELATIVE_SECONDS); go to end_cmd; end; if command = "single" then do; /* single space FF and VT for current request */ if iodd_static.request_in_progress then do; p = iodd_static.driver_ptr -> driver_status.dev_out_iocbp; call iox_$modes (p, "single", omode, ignore_code); /* set single mode */ dmp = addr (iodd_static.driver_ptr -> driver_status.message); if dprint_msg.message_type = printer_request then call do_prt_request_$single_copy (); /* avoid same problem if another copy requested */ else call output_request_$set_single_copy (); end; else call iodd_msg_ (normal, source, zero_code, "", "No current request."); go to end_cmd; end; if command = "pun_control" | command = "puncontrol" then do; if arg_list.n_tokens > 1 then p = find_driver_status_seg_ptr (arg_list.arg (1)); /* see if first arg matches a minor device */ else p = null; if p ^= null then /* first arg was a valid minor device name */ i = 2; /* value args start with arg 2 */ else do; /* wants default or made typing error */ p = default_punch; /* try for the default punch device */ i = 1; /* arg one starts the value */ end; if p = null () then do; no_punch: if arg_list.n_tokens = 1 then opr_msg = "not specified."; else opr_msg = "not found: " || arg_list.arg (i); call iodd_msg_ (normal, source, zero_code, "", "Punch minor device ^a", opr_msg); go to cmd_error; end; if p -> driver_status.generic_type ^= "punch" then do; /* punch functions are only for punches */ not_a_punch: call iodd_msg_ (normal, source, zero_code, "", "Minor device ""^a"" is not a punch.", p -> driver_status.device_id); go to cmd_error; end; pun_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control pointer for this driver */ if arg_list.n_tokens <= i | arg_list.arg (i) = "-print" then do; call iodd_msg_ (normal, source, zero_code, "", "Current value is: ^[^^^]auto_punch", ^pun_ctl.auto_punch); go to end_cmd; end; do i = i to n_tokens - 1; /* look at each argument */ not = (substr (arg_list.arg (i), 1, 1) = "^"); /* was first char a "^" */ if not then arg_string = substr (arg_list.arg (i), 2); else arg_string = arg_list.arg (i); if arg_string = "auto_punch" | arg_string = "autopunch" then pun_ctl.auto_punch = ^not; else call iodd_msg_ (normal, source, zero_code, "", "Undefined argument: ^a", arg_list.arg (i)); end; go to end_cmd; end; if command = "sep_cards" | command = "sepcards" then do; if arg_list.n_tokens > 2 then do; p = find_driver_status_seg_ptr (arg_list.arg (1)); /* get driver status ptr for minor device given */ i = 2; /* arg 2 is the value argument */ end; else do; /* one arg - could be value for default or ... */ /* could be minor device name with no value */ p = default_punch; /* try for the default punch */ i = 1; /* assume first arg is the value */ end; value = -1; /* no value defined yet */ if arg_list.n_tokens > 1 then do; /* allow for no args at all */ if arg_list.arg (i) = "-print" then value = -1; else if arg_list.arg (i) = "none" then value = none; else if arg_list.arg (i) = "standard" then value = standard; else p = find_driver_status_seg_ptr (arg_list.arg (i)); end; if p = null () then go to no_punch; if p -> driver_status.generic_type ^= "punch" then go to not_a_punch; /* only allow punches */ pun_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control structure pointer */ if value = -1 then do; /* print the current value */ if pun_ctl.sep_cards = none then opr_msg = "none"; else if pun_ctl.sep_cards = standard then opr_msg = "standard"; else opr_msg = "Undefined value"; call iodd_msg_ (normal, source, zero_code, "", "Current value is: ^a", opr_msg); end; else pun_ctl.sep_cards = value; go to end_cmd; end; if command = "read_cards" | command = "readcards" then do; if reader_attached then do; 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, minimum_quota, "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, source, code, myname, "Unable to initialize card pool."); go to cmd_error; end; call iodd_msg_ (normal, source, zero_code, "", "Card input started."); if source = slave then call iox_$control (iodd_static.slave_out, "runout", null, ignore_code); on card_command_level go to abort_read; /* grab control after record quota overflow */ call read_cards_ (pool_dir, addr (card_info), terminal (source), (iodd_static.test_entry), code); if code ^= 0 then do; call iodd_msg_ (normal, source, code, myname, "Check card deck format."); go to cmd_error; end; go to end_cmd; abort_read: call iodd_msg_ (normal, source, zero_code, "", "Use the ""clean_pool"" command and retry card input."); go to cmd_error; end; else do; call iodd_msg_ (normal, source, zero_code, "", "The card reader is not attached."); go to end_cmd; end; end; if command = "sample_form" | command = "sampleform" then do; if iodd_static.ctl_term.attached then do; /* be sure there is a place to write */ if iodd_static.forms then do; /* are we simulating FF? */ call iox_$control (iodd_static.slave_out, "form_status", addr (form_info), code); if code ^= 0 then do; /* OOPS.... */ iodd_static.forms = FALSE; iodd_static.slave_hold = TRUE;/* this is a problem for master terminal */ call iodd_msg_ (error, both, code, myname, "Bad form_status order call. Form feed simulation terminated."); go to cmd_error; end; if ^form_info.aligned then call iox_$control (iodd_static.slave_out, "form_aligned", null, ignore_code); /* this will work */ end; call write_sample_form_ (iodd_static.form_type, (iodd_static.ctl_output), code); if code ^= 0 then if code ^= error_table_$action_not_performed then call iodd_msg_ (normal, source, code, myname, "Error writing form."); else call iodd_msg_ (normal, source, zero_code, "", "No form type has been set."); go to end_cmd; end; call iodd_msg_ (normal, source, zero_code, "", "Control terminal is not attached."); go to end_cmd; end; if command = "clean_pool" | command = "cleanpool" then do; /* garbage collect the card pool */ if source = slave then do; call iodd_msg_ (normal, source, zero_code, "", "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, zero_code, "", "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, zero_code, "", "Invalid argument: ^a", arg_list.arg (1)); go to cmd_error; end; if iodd_static.test_entry then /* use a dummy pool root under sys_dir for test */ pool_dir = rtrim (iodd_static.sys_dir_ptr -> sys_dir) || ">card_pool"; /* this is the test pool root */ else pool_dir = "System_Card_Pool"; /* otherwise use the one coded in */ call pool_manager_$clean_pool (pool_dir, age, minimum_quota, code); /* let pool_manager_ do the work */ if code ^= 0 then call iodd_msg_ (normal, source, code, myname, "Unable to clean the card pool."); go to end_cmd; end; /* When control passes here, the command is unknown. So 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; %page; /* default error handler for the remote driver */ 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 do; dmp = addr (iodd_static.driver_ptr -> driver_status.message); if dprint_msg.message_type = printer_request then /* had to know who to call */ call do_prt_request_$error_during_request (condition); else call output_request_$error_during_request (condition); /* take it away */ end; return; /* output_request_ should not return, but.... */ %page; problem_notification: entry (msg_to_send); /* this entry sends an express message to the user (if allowed) explaining the problem with the device. If the user didn't get the message, try to send to an admin mailbox so someone can see there is a problem. We don't care if either of the recipients don't get the message. We tried. */ dcl msg_to_send char (*); dcl (user, project) char (32); dcl mbx_dirname char (168); dcl mbx_entname char (32); dcl mbx_access_class bit (72) aligned; /* locate info on current request */ driver_status_ptr = iodd_static.driver_ptr; mseg_message_info_ptr = addr (driver_status.descriptor); /* if we are allowed to notify the user of the problem, then isolate the user name and project from the ID in the request and build the path to the user's mailbox */ user = iodd_parse_$args ("notify_owner=", major_args); if user = "yes" then do; user = before (mseg_message_info.sender_id, "."); project = after (mseg_message_info.sender_id, "."); project = before (project, "."); mbx_dirname = ">udd>" || rtrim (project) || ">" || user; mbx_entname = rtrim (user) || ".mbx"; mbx_access_class = mseg_message_info.sender_authorization; call send_the_message; if code = 0 then return; /* got through OK */ end; /* if we got here, either the user isn't supposed to received the problem message or we tried to send it and the user would't receive the message. In either case, we will see if there is an admin mailbox defined. If there is, we will send the message there. */ mbx_dirname = iodd_parse_$args ("admin_mbx=", major_args); if mbx_dirname = "" then return; /* no admin address defined, forget it */ call expand_pathname_$add_suffix (mbx_dirname, "mbx", mbx_dirname, mbx_entname, code); if code ^= 0 then return; mbx_access_class = mseg_message_info.sender_authorization; call send_the_message; return; /* end problem_notification; */ send_the_message: proc; /* internal entry used to send out the problem notification message */ dcl (ipc_ind, r1_ind) fixed bin (35); if smi.version = -1 then do; /* 1st call, must init */ smi.version = send_mail_info_version_2; smi.wakeup = TRUE; smi.mbz1 = ""b; smi.always_add = FALSE; smi.never_add = FALSE; smi.notify = FALSE; smi.acknowledge = FALSE; smi.mbz = ""b; end; smi.sent_from = driver_status.dev_name_label; ipc_ind, r1_ind = -1; /* set to non-zero to test call */ if ^sys_priv then /* tried once & failed */ go to send_it; /* so don't bother to try again */ /* see if we can get our privileges turned on */ on linkage_error begin; sys_priv = "0"b; /* stop trying if fail */ go to revert_handler; /* send the message if possible */ end; on any_other begin; if r1_ind = 0 then call system_privilege_$ring1_priv_off (r1_ind); if ipc_ind = 0 then call system_privilege_$ipc_priv_off (ipc_ind); r1_ind, ipc_ind = -1; call continue_to_signal_ (ignore_code); end; call system_privilege_$ring1_priv_on (r1_ind); call system_privilege_$ipc_priv_on (ipc_ind); revert_handler: revert linkage_error; send_it: call message_facility_$send_message_access_class (mbx_dirname, mbx_entname, msg_to_send, addr (smi), mbx_access_class, code); if r1_ind = 0 then call system_privilege_$ring1_priv_off (r1_ind); if ipc_ind = 0 then call system_privilege_$ipc_priv_off (ipc_ind); end send_the_message; %page; set_wait_timer: procedure (); call ipc_$drain_chn (ctl_wait_list.channel, code); if code ^= 0 then do; /* avoid futher trouble, but not fatal */ ctl_wait_list.channel = 0; /* stop trying */ ctl_wait_list.number = 0; iodd_static.slave_hold = TRUE; /* go back to command level for guidance */ ctl_msg_sent = FALSE; /* and don't block */ call iodd_msg_ (error, master, zero_code, myname, "Bad call to ipc_$drain_chn. Form synchronization terminated."); end; if ctl_msg_sent then call timer_manager_$alarm_wakeup (p -> driver_status.form_wait_time, RELATIVE_SECONDS, alarm_channel); return; end set_wait_timer; wait_for_ctl_finish: procedure (); if iodd_static.quit_during_request then do; /* wakeup was lost */ ctl_msg_sent = FALSE; /* cancel the flag */ return; end; if ctl_msg_sent then do; /* avoid premature block on non-event */ ctl_msg_sent = FALSE; /* ready for the next one */ call ipc_$block (addr (ctl_wait_list), addr (event_info), ignore_code); /* wait for form to finish */ end; return; end wait_for_ctl_finish; close_and_detach: procedure (a_iocbp, send_hangup); dcl a_iocbp ptr; dcl send_hangup bit (1); if a_iocbp = null then return; if send_hangup then call iox_$control (a_iocbp, "hangup", null, ignore_code); call iox_$close (a_iocbp, ignore_code); call iox_$detach_iocb (a_iocbp, ignore_code); a_iocbp = null; return; end close_and_detach; %page; minor_attach: procedure (Device); declare Device char (*) parameter; declare desc char (256) varying; declare mode fixed bin; declare device_io_module char (32) var; desc = major_desc || space || iodd_parse_$args ("desc=", minor_args); if Device = "printer" then device_io_module = "remote_printer_"; else if Device = "punch" then device_io_module = "remote_punch_"; else if Device = "reader" then device_io_module = "remote_input_"; attach_desc = device_io_module || " " || desc; 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, (attach_desc), code); if code ^= 0 & code ^= error_table_$not_detached & code ^= error_table_$ionmat then go to attach_error; if Device = "reader" then mode = Stream_input; else mode = Stream_output; 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, attach_desc); go to clean_out; end; iodd_static.current_devices = iodd_static.current_devices + 1; if ^hangup_proc_defined then 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; %page; find_driver_status_seg_ptr: procedure (minor_device_name) returns (pointer); dcl minor_device_name varying character (*) aligned parameter; dcl i fixed bin; dcl stat_segp ptr; list_ptr = iodd_static.driver_list_ptr; /* make reference easier to read */ do i = 1 to driver_ptr_list.number; stat_segp = driver_ptr_list.stat_segp (i); /* get next driver status seg ptr */ if minor_device_name = stat_segp -> driver_status.device_id then /* look for minor name match */ return (stat_segp); end; return (null ()); /* no minor device found with the requested name */ end find_driver_status_seg_ptr; set_hangup_proc: procedure (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 call iodd_msg_ (error, master, code, myname, "Warning: Could not establish handler for hangups from the device."); hangup_proc_defined = TRUE; /* once is enuf */ return; end set_hangup_proc; %page; set_paper_info: procedure (source, code); dcl code fixed bin (35); dcl source fixed bin; code = 0; call iox_$control (p -> driver_status.dev_out_iocbp, "paper_info", addr (prt_ctl.paper_info), code); if code ^= 0 then if code = error_table_$no_operation then do; /* if dim couldn't, tell the operator */ call iodd_msg_ (normal, source, zero_code, "", "^/Mount VFU tape for ^d lines per page.^/Set printer for ^d lines/inch.", prt_ctl.phys_page_length, prt_ctl.lines_per_inch); code = 0; /* this is really ok */ end; else do; call iodd_msg_ (normal, both, code, myname, "Unable to perform paper_info order."); /* a real error */ end; return; end set_paper_info; %page; get_prt_rqti_data: procedure (p); dcl p pointer; /* internal procedure to get paper info and channel stops data from the rqt info segment or to establish some defaults if one is not being used */ prt_ctl_ptr = p -> driver_status.dev_ctl_ptr; string (prt_ctl.flags) = ""b; if p -> driver_status.rqti_ptr ^= null then do; /* if there is an rqti seg, use it */ prt_rqtip = p -> driver_status.rqti_ptr; /* make the based references cleaner */ if prt_rqti.header.header_version ^= rqti_header_version_1 then do; call iodd_msg_ (error, both, error_table_$fatal_error, myname, "prt rqt info header version ^d found (expected ^d)", prt_rqti.header.header_version, rqti_header_version_1); go to clean_out; end; prt_ctl.meter = prt_rqti.header.meter; /* do we take meter data? */ ready_device = ready_device | prt_rqti.header.auto_go; p -> driver_status.ready = prt_rqti.header.auto_go; /* set the initial hold state as requested */ iodd_static.wakeup_time = max (wakeup_time_default, prt_rqti.header.driver_wait_time); /* seconds to wait for a request */ if prt_rqti.header.type_code = 0 then go to set_defaults; /* this is only a header */ else if prt_rqti.header.type_code ^= 1 then do; call iodd_msg_ (error, both, error_table_$fatal_error, myname, "Wrong rqt info seg type for printer.") ; go to clean_out; end; if prt_rqti.version ^= prt_rqti_version_1 then do; /* see if it is the right version */ call iodd_msg_ (error, both, error_table_$fatal_error, myname, "Wrong version of prt_rqti. Found ^d (expected ^d)", prt_rqti.version, prt_rqti_version_1); go to clean_out; end; if prt_rqti.opr_msg ^= "" then call iodd_msg_ (normal, both, zero_code, "", "^/^a", prt_rqti.opr_msg); /* give operator instructions */ prt_ctl.phys_page_length = prt_rqti.paper_length; /* get paper data for prtdim */ prt_ctl.phys_line_length = prt_rqti.paper_width; prt_ctl.lines_per_inch = prt_rqti.lines_per_inch; prt_ctl.channel_stops = prt_rqti.channel_stops; /* get VFU stops for printer */ prt_ctl.banner_type = prt_rqti.banner_type; /* copy control info to writable storage */ prt_ctl.force_nep = prt_rqti.force_nep; prt_ctl.force_esc = prt_rqti.force_esc; prt_ctl.force_ctl_char = prt_rqti.force_ctl_char; prt_ctl.no_auto_print = prt_rqti.no_auto_print; prt_ctl.force_nsep = prt_rqti.force_nsep; prt_ctl.banner_bars = prt_rqti.banner_bars; prt_ctl.banner_indent = prt_rqti.banner_indent; prt_ctl.banner_line = prt_rqti.banner_line; end; else do; /* no rqti seg, so set some defaults */ prt_ctl.meter = FALSE; /* no meters */ iodd_static.slave_hold = TRUE; /* be sure to ask for a start command */ iodd_static.wakeup_time = wakeup_time_default; /* check every 30 seconds */ set_defaults: /* set up the default paper data */ prt_ctl.phys_page_length = page_length_default; /* 11 inch paper at 6 lpi is 66 lines */ prt_ctl.phys_line_length = line_length_default; /* standard remote platten is 132 chars */ prt_ctl.lines_per_inch = lpi_default; /* normal for good readibility */ string (prt_ctl.channel_stops) = FALSE; /* no slew stops are defined */ prt_ctl.force_nep = FALSE; /* let user have his way */ prt_ctl.force_esc = FALSE; prt_ctl.force_ctl_char = FALSE; prt_ctl.no_auto_print = FALSE; /* print without requesting operator attn */ prt_ctl.force_nsep = FALSE; /* print inner head and tail sheets for multiple copies */ prt_ctl.banner_type = NORMAL_BANNERS; /* use normal head/tail sheets */ prt_ctl.banner_bars = NORMAL_BANNER_BARS; /* means nothing for now */ prt_ctl.banner_indent = 0; /* again */ prt_ctl.banner_line = 1; /* again */ end; return; end get_prt_rqti_data; %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; return_string: proc (target) returns (char (*)); /* routine to return a string from the i/o daemon tables text strings area */ dcl 1 target unaligned like text_offset; if target.total_chars = 0 then return (""); else return (substr (text_strings.chars, target.first_char, target.total_chars)); end return_string; %page; evaluate_forms_options: proc (error_code); /* this subroutine will evaluate the forms option supplied by the user and the defaults defined for the request type and/or device. */ dcl error_code fixed bin (35); /* set to global ptrs to main groups in io daemon tables we will need */ idtp = iodd_static.idtp; /* device tables */ mdtp = iodd_static.mdtp; /* minor device tables */ qgtp = iodd_static.qgtp; /* request_type tables */ dctp = iodd_static.dev_class_ptr; /* device_class tables */ text_strings_ptr = iodd_static.text_strings_ptr; /* common text strings */ /* now set up ptrs to specific request type and device entries for this request */ idtep = addr (iod_device_tab.entries (p -> driver_status.maj_index)); /* major device entry */ mdtep = addr (minor_device_tab.entries (p -> driver_status.dev_index)); /* minor device entry */ dctep = addr (dev_class_tab.entries (p -> driver_status.dev_class_index)); /* device_class entry */ qgtep = addr (q_group_tab.entries (dcte.qgte_index)); /* request_type */ if my_area_ptr = null then my_area_ptr = get_system_free_area_ (); /* set up the structure to pass in */ if dprint_msg.version < dprint_msg_version_5 then system_input_forms_string_length = length (rtrim (dprint_msg.forms)); else system_input_forms_string_length = dprint_msg.forms_name_lth; evaluate_forms_info_input_ptr, evaluate_forms_info_output_ptr = null; on cleanup begin; if evaluate_forms_info_input_ptr ^= null then free evaluate_forms_info_input; if evaluate_forms_info_output_ptr ^= null then free evaluate_forms_info_output; end; allocate evaluate_forms_info_input in (my_area); evaluate_forms_info_input.version = EVALUATE_FORMS_INFO_INPUT_VERSION_1; evaluate_forms_info_input.ithp = iodd_static.ithp; evaluate_forms_info_input.qgtep = qgtep; evaluate_forms_info_input.idtep = idtep; evaluate_forms_info_input.mdtep = mdtep; if dprint_msg.version < dprint_msg_version_5 then evaluate_forms_info_input.forms_string = rtrim (dprint_msg.forms); else evaluate_forms_info_input.forms_string = dprint_msg.forms_name; evaluate_forms_info_input.area_ptr = my_area_ptr; /* call common routine which does all forms validation */ call iod_info_$evaluate_forms_info (p -> driver_status.rqti_ptr, evaluate_forms_info_input_ptr, evaluate_forms_info_output_ptr, error_code); if error_code = 0 | error_code = error_table_$no_forms_table_defined then do; prt_ctl.phys_line_length = evaluate_forms_info_output.chars_per_line; prt_ctl.phys_page_length = evaluate_forms_info_output.lines_per_page; prt_ctl.lines_per_inch = evaluate_forms_info_output.lines_per_inch; p -> driver_status.forms_validation_ptr = evaluate_forms_info_output_ptr; error_code = 0; end; free evaluate_forms_info_input; end evaluate_forms_options; %page; %include access_mode_values; %page; %include card_stream_info; %page; %include condition_info; %page; %include device_class; %page; %include dprint_msg; %page; %include driver_ptr_list; %page; %include driver_status; %page; %include iod_constants; %page; %include iod_device_tab; %page; %include iod_tables_hdr; %page; %include iod_line_tab; %page; %include iodd_static; %page; %include iox_modes; %page; %include mseg_message_info; %page; %include output_request_data; %page; %include prt_ctl; %page; %include prt_order_info; %page; %include prt_rqti; %page; %include q_group_tab; %page; %include queue_msg_hdr; %page; %include request_descriptor; %page; %include send_mail_info; %page; %include terminal_info; %page; %include system_constants; %page; %include system_forms_info; %page; %include timer_manager_constants; end remote_driver_;  remote_input_.pl1 11/15/82 1900.8rew 11/15/82 1523.6 201051 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ remote_input_: proc; /* remote_input_: An I/O module for receiving character records from a remote host. */ /* Coded March 1980 by J. C. Whitmore, modeled after the remote_reader_ IO Module */ /* Parameters */ dcl a_iocbp ptr parameter; dcl a_option (*) char (*) var parameter; /* Options for attach */ dcl a_sw bit (1) parameter; /* com_err_ switch for attach */ dcl a_code fixed bin (35) parameter; dcl a_mode fixed bin parameter; /* The open mode */ dcl a_buf_ptr ptr parameter; dcl a_buf_chars fixed bin (21) parameter; dcl a_data_chars fixed bin (21) parameter; dcl a_pos_type fixed bin parameter; dcl a_pos_value fixed bin (21) parameter; dcl a_order char (*) parameter; dcl a_infop ptr parameter; dcl a_old_modes char (*) parameter; dcl a_new_modes char (*) parameter; /* AUTOMATIC VARIABLES */ dcl com_err_sw bit (1); /* Set if com_err_ sould be called on attach error */ dcl dummy char (32) var; dcl total_chars fixed bin (21); /* number of chars in a record */ dcl code fixed bin (35); dcl iocbp ptr; dcl temp_iocbp ptr; dcl slew_string char (128) var; dcl mask bit (36) aligned; /* For setting ips mask */ dcl device_opt char (32) var; dcl idx fixed bin; dcl record_len fixed bin; dcl max_record_size fixed bin; dcl open_mode fixed bin; dcl order char (32); dcl infop ptr; dcl terminal_switch_name char (32) var; dcl terminal_attach_options char (256) var; dcl my_options char (64) var; dcl terminal_attach_desc char (256) var; /* Constants */ dcl remote_device_name char (13) int static options (constant) init ("remote_input_"); dcl space char (1) int static options (constant) init (" "); dcl ESC_c char (2) int static options (constant) init ("c"); dcl ETX char (1) int static options (constant) init (""); dcl CR 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 (" "); /* Internal Static and Based variables */ dcl areap ptr int static init (null); dcl attach_count int static init (0) fixed bin; dcl static_comerr_sw bit (1) int static init ("0"b); dcl my_area area (262144) based (areap); dcl char_string char (1024) based; /* External stuff */ dcl ioa_ entry options (variable); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl iox_$propagate entry (ptr); dcl com_err_ entry options (variable); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35)); dcl iox_$get_chars entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$err_no_operation entry; dcl (addr, bin, hbound, min, null, length, substr, rtrim, ltrim, char, size, unspec, copy, empty) builtin; dcl error_table_$bad_mode fixed bin (35) ext; dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$eof_record ext fixed bin (35); dcl error_table_$not_detached ext fixed bin (35); dcl error_table_$not_attached ext fixed bin (35); dcl error_table_$not_open ext fixed bin (35); dcl error_table_$not_closed ext fixed bin (35); dcl error_table_$wrong_no_of_args ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); dcl error_table_$bad_conversion ext fixed bin (35); dcl error_table_$unimplemented_version ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); dcl error_table_$data_loss ext fixed bin (35); dcl (any_other, cleanup, conversion) condition; dcl adp ptr; /* pointer to the attach data structure */ dcl 1 ad aligned based (adp), 2 fixed, 3 device_type fixed bin, /* type code for terminal_io_record */ 3 rec_length fixed bin, /* max data length of input record */ 3 record_count fixed bin (35), /* total records read since last reset control order */ 3 fixed_pad fixed bin, 2 ptrs, 3 terminal_iocbp ptr, /* pointer to the iocbp of the next dim level */ 2 bits, 3 record_io bit (1) unal, /* TRUE - if terminal io module uses record interface */ 3 bit_pad bit (35) unal, 2 chars, 3 terminal char (32) var, /* name of the terminal io module */ 3 attach_desc char (256) var, /* our attach description */ 3 open_description char (24) var; /* our open description */ dcl 1 count_structure aligned based, /* 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; %include iocb; %include iox_modes; %include terminal_io_record; remote_reader_attach: /* compatibility */ remote_input_attach: entry (a_iocbp, a_option, a_sw, a_code); iocbp = a_iocbp; com_err_sw = a_sw | static_comerr_sw; /* if either one is set ... */ code, a_code = 0; adp = null; if iocbp -> iocb.attach_descrip_ptr ^= null then do; code = error_table_$not_detached; call abort_attach (code, "Switch name: ^a", iocbp -> iocb.name); end; if hbound (a_option, 1) < 1 then do; /* Must be at least one */ code = error_table_$wrong_no_of_args; call abort_attach (code, "Bad attach description.", ""); end; if areap = null then do; call get_temp_segment_ (remote_device_name, areap, code); /* Temp segment for attach data */ if code ^= 0 then call abort_attach (code, "Unable to allocate temp segment.", ""); areap -> my_area = empty (); /* initialize our private area */ end; on cleanup call clean_up; allocate ad in (my_area) set (adp); /* Initialize Attach Data Structure variables */ ad.bits = "0"b; ad.ptrs = null; ad.chars = ""; ad.rec_length = -1; /* mark this as not specified */ ad.record_count = 0; /* Process options */ terminal_attach_options = ""; my_options = ""; terminal_attach_desc = ""; device_opt = "reader"; /* default to reader if no -device is given */ do idx = 1 to hbound (a_option, 1); if a_option (idx) = "-terminal" then do; ad.terminal = get_arg (idx); my_options = my_options || " -terminal " || ad.terminal; end; else if a_option (idx) = "-device" then device_opt = get_arg (idx); /* we specify this one */ else if a_option (idx) = "-runout_spacing" | a_option (idx) = "-runsp" then do; /* skip this and next arg */ dummy = get_arg (idx); my_options = my_options || " -runsp " || dummy; end; else if a_option (idx) = "-physical_page_length" | a_option (idx) = "-ppl" then do; /* skip this too */ dummy = get_arg (idx); my_options = my_options || " -ppl " || dummy; end; else if a_option (idx) = "-record_len" then do; /* redefine the max record length */ ad.rec_length = cv_dec_arg (idx); my_options = my_options || " -record_len " || a_option (idx); end; else terminal_attach_options = terminal_attach_options || space || a_option (idx); end; if ad.terminal = "" then do; code = error_table_$noarg; call abort_attach (code, "No terminal IO module specified.", ""); end; if device_opt = "" then do; /* caller didn't specify */ code = error_table_$noarg; call abort_attach (code, "Missing argument to -device option.", ""); end; else if device_opt = "printer_in" then do; ad.device_type = PRINTER_DEVICE; device_opt = "printer"; /* this is for the attachment to the terminal */ end; else if device_opt = "punch_in" then do; ad.device_type = PUNCH_DEVICE; device_opt = "punch"; /* again for the attach description to the terminal */ end; else if device_opt = "reader" then do; ad.device_type = READER_DEVICE; end; else do; /* not recognized */ code = error_table_$badopt; call abort_attach (code, "Invalid -device option: ^a", (device_opt)); end; if ad.rec_length = -1 then do; /* not specified - set default max record size */ if ad.device_type = READER_DEVICE then ad.rec_length = 160; else ad.rec_length = 1024; /* lots of room for print lines/files */ end; if ad.device_type = READER_DEVICE then do; /* range check the record length */ if ad.rec_length < 80 | ad.rec_length > 160 then do; /* OOPS - not reasonable */ code = error_table_$bad_arg; call abort_attach (code, "Value for -record_len option out of range.", ""); end; end; else do; if ad.rec_length < 10 | ad.rec_length > 1024 then do; code = error_table_$bad_arg; call abort_attach (code, "Value for -record_len option out of range.", ""); end; end; /* Attach through terminal dim */ attach_count = attach_count + 1; /* new attach name tag number each time */ if attach_count > 999 then attach_count = 1; terminal_switch_name = remote_device_name || ltrim (char (attach_count)); /* make the switch name */ terminal_attach_options = ltrim (terminal_attach_options) || " -device " || device_opt; terminal_attach_desc = ad.terminal || space || terminal_attach_options; ad.attach_desc = remote_device_name || my_options || space || terminal_attach_options; call iox_$attach_ioname ((terminal_switch_name), temp_iocbp, (terminal_attach_desc), code); if code ^= 0 then call abort_attach (code, "Unable to attach to terminal: ^a", (ad.terminal)); ad.terminal_iocbp = temp_iocbp; /* Now mask and complete the iocb */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc); iocbp -> iocb.attach_data_ptr = adp; iocbp -> iocb.open = remote_input_open; iocbp -> iocb.detach_iocb = remote_input_detach; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; attach_return: return; remote_input_detach: entry (a_iocbp, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; a_code = error_table_$not_closed; return; end; call clean_up; mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = null; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; remote_input_open: entry (a_iocbp, a_mode, a_sw, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; a_code = error_table_$not_closed; return; end; open_mode = a_mode; if ^(open_mode = Stream_input | open_mode = Stream_input_output) then do; a_code = error_table_$bad_mode; return; end; ad.open_description = rtrim (iox_modes (open_mode)); call iox_$open (ad.terminal_iocbp, Sequential_input, "0"b, a_code); /* try for the record interface */ if a_code = 0 then do; /* well we made it, records approved */ ad.record_io = "1"b; /* record the fact */ end; else do; /* Ok, so we try for the stream interface */ ad.record_io = "0"b; call iox_$open (ad.terminal_iocbp, Stream_input, "0"b, a_code); if a_code ^= 0 then return; /* Oh, well */ end; mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.get_chars = remote_input_get_chars; iocbp -> iocb.get_line = remote_input_get_chars; iocbp -> iocb.position = remote_input_position; iocbp -> iocb.control = remote_input_control; iocbp -> iocb.modes = remote_input_modes; iocbp -> iocb.close = remote_input_close; iocbp -> iocb.open_descrip_ptr = addr (ad.open_description); call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; remote_input_close: entry (a_iocbp, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; call iox_$close (ad.terminal_iocbp, a_code); /* try to close the terminal switch too */ if a_code = error_table_$not_open | a_code = error_table_$not_attached then code = 0; /* make it easy to re-synch attachments */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.open_descrip_ptr = null; iocbp -> iocb.open = remote_input_open; iocbp -> iocb.detach_iocb = remote_input_detach; iocbp -> iocb.control = iox_$err_no_operation; iocbp -> iocb.modes = iox_$err_no_operation; iocbp -> iocb.position = iox_$err_no_operation; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; remote_input_get_chars: entry (a_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; a_data_chars, a_code, code = 0; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; max_record_size = ad.rec_length; /* put into automatic for this call */ terminal_io_record_ptr = null; /* for the cleanup handler */ terminal_io_record_element_size = 9; /* always character data */ terminal_io_record_n_elements = max_record_size; /* set the max record size allowed */ on cleanup begin; if terminal_io_record_ptr ^= null then free terminal_io_record_ptr -> terminal_io_record in (my_area); end; call alloc_tio_rec; /* allocate and initialize terminal_io_record */ terminal_io_record.n_elements = max_record_size; /* set to the max size for the read call */ /* Read the next record from the terminal IO Module */ if ad.record_io then do; call iox_$read_record (ad.terminal_iocbp, terminal_io_record_ptr, 4 * size (terminal_io_record), record_len, code); if code ^= 0 then go to get_chars_ret; /* accept EOF from the terminal as well */ if terminal_io_record.version ^= terminal_io_record_version_1 then do; code = error_table_$unimplemented_version; go to get_chars_ret; end; if ad.device_type ^= READER_DEVICE then do; /* no slews for the reader */ if terminal_io_record.slew_type = SLEW_BY_COUNT then do; if terminal_io_record.slew_count = 0 then slew_string = CR; /* this is the overprint case */ else slew_string = copy (NL, terminal_io_record.slew_count); end; else if terminal_io_record.slew_type = SLEW_TO_CHANNEL then do; slew_string = ESC_c || ltrim (char (terminal_io_record.slew_count)) || ETX; end; else do; /* TOIP = TOOP = TOP for seg text */ slew_string = FF; /* so just add one FF char */ end; end; else do; /* for the reader, check for ++EOF cards */ if terminal_io_record_data_chars = "++EOF" | terminal_io_record_data_chars = "++eof" then do; code = error_table_$eof_record; go to get_chars_ret; end; slew_string = ""; /* no additional slew chars will be added */ end; end; else do; call iox_$get_chars (ad.terminal_iocbp, addr (terminal_io_record.data), max_record_size, record_len, code); if code ^= 0 then go to get_chars_ret; /* accept EOF from the terminal as well */ terminal_io_record.n_elements = record_len; /* make a legal varying string */ /* For stream input, all slew chars must be in the stream already */ if ad.device_type = READER_DEVICE then do; /* look for EOF cards from reader */ if terminal_io_record_data_chars = "++EOF" | terminal_io_record_data_chars = "++eof" then do; code = error_table_$eof_record; go to get_chars_ret; end; end; slew_string = ""; /* all slews must be in the stream */ end; /* at this point, we must have a record of the form: */ total_chars = terminal_io_record.n_elements + length (slew_string); /* get the updated count */ if total_chars > a_buf_chars then code = error_table_$data_loss; /* tell caller we truncated the record */ a_data_chars = min (a_buf_chars, total_chars); if terminal_io_record.preslew then substr (a_buf_ptr -> char_string, 1, a_data_chars) = slew_string || terminal_io_record_data_chars; else substr (a_buf_ptr -> char_string, 1, a_data_chars) = terminal_io_record_data_chars || slew_string; ad.record_count = ad.record_count + 1; /* increment the total read */ get_chars_ret: free terminal_io_record_ptr -> terminal_io_record in (my_area); revert cleanup; a_code = code; return; remote_input_control: entry (a_iocbp, a_order, a_infop, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; infop = a_infop; order = a_order; a_code = 0; if order = "reset" then do; /* go to a known clean state */ ad.record_count = 0; /* we just clear the count of records read */ go to pass_on; /* and then give it to the terminal IO Module */ end; else if order = "get_count" then do; /* this is for us alone */ if infop ^= null then infop -> count_structure.records = ad.record_count; /* give back the count */ else a_code = error_table_$bad_arg; end; else do; pass_on: call iox_$control (ad.terminal_iocbp, order, infop, a_code); end; return; remote_input_modes: entry (a_iocbp, a_new_modes, a_old_modes, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; a_code = 0; call iox_$modes (ad.terminal_iocbp, a_new_modes, a_old_modes, a_code); return; remote_input_position: entry (a_iocbp, a_pos_type, a_pos_value, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; a_code = 0; call iox_$position (ad.terminal_iocbp, a_pos_type, a_pos_value, a_code); return; flip_com_err_sw: entry; static_comerr_sw = ^static_comerr_sw; /* flip the bit */ call ioa_ ("The INPUT com err sw is now: ^[on^;off^]", static_comerr_sw); return; get_arg: proc (idx) returns (char (*)); dcl idx fixed bin; idx = idx + 1; if idx > hbound (a_option, 1) then do; code = error_table_$noarg; call abort_attach (code, "No argument after ^a.", (a_option (idx - 1))); end; return (a_option (idx)); end get_arg; cv_dec_arg: proc (idx) returns (fixed bin); dcl idx fixed bin; idx = idx + 1; /* advance the index of the major loop */ if idx > hbound (a_option, 1) then do; code = error_table_$noarg; call abort_attach (code, "No argument after ^a.", (a_option (idx - 1))); end; on conversion go to bad_dec_arg; return (bin (a_option (idx))); bad_dec_arg: code = error_table_$bad_conversion; call abort_attach (code, "Invalid decimal number. ^a", (a_option (idx))); end cv_dec_arg; abort_attach: proc (code, str1, str2); dcl code fixed bin (35); dcl (str1, str2) char (*) aligned; /* This proc handles attach errors */ if com_err_sw then call com_err_ (code, remote_device_name, str1, str2); a_code = code; /* copy back the error, MUST be non-zero */ call clean_up; go to attach_return; /* finish the abort by non-local return */ end abort_attach; alloc_tio_rec: proc; allocate terminal_io_record in (my_area) set (terminal_io_record_ptr); unspec (terminal_io_record) = "0"b; /* clear everything */ terminal_io_record.version = terminal_io_record_version_1; /* our view of the record structure */ terminal_io_record.device_type = ad.device_type; terminal_io_record.element_size = terminal_io_record_element_size; /* set by our caller */ return; end alloc_tio_rec; clean_up: proc; dcl ignore fixed bin (35); if adp ^= null then do; if ad.terminal_iocbp ^= null then call iox_$detach_iocb (ad.terminal_iocbp, ignore); free adp -> ad in (my_area); adp = null; end; iocbp -> iocb.attach_descrip_ptr = null; /* be sure iox_ knows */ iocbp -> iocb.attach_data_ptr = null; iocbp -> iocb.open = iox_$err_no_operation; return; end clean_up; handler: proc; dcl ignore fixed bin (35); /* This proc handles faults that occur while masked */ if mask then call hcs_$reset_ips_mask (mask, mask); mask = ""b; call continue_to_signal_ (ignore); return; end handler; end remote_input_;  remote_printer_.pl1 11/09/88 1302.9rew 11/09/88 1302.1 226521 /****^ *********************************************************** * * * 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. * * * *********************************************************** */ /* format: style4 */ /* format: off */ /* remote_printer_: An I/O module for communicating with a remote printer or its equivilent */ /* Created: March 1977 by David Vinograd */ /* Modified: May 1978 by David Vinograd to clean up and interface to user TTFs */ /* Modified: November 1978 by J. C. Whitmore to make all attach options for remote_xxx_ dims consistent */ /* Modified: March 1980 by J. C. Whitmore to use the terminal_io_record interface to the terminal IO module */ /* Modified: 13 December 1981 by G. Palter to not use illegal PL/I and provide sufficient extra space for prt_conv_ to output control sequences */ /****^ HISTORY COMMENTS: 1) change(88-06-07,Brunelle), approve(88-06-07,MCR7911), audit(88-10-24,Farley), install(88-11-08,MR12.2-1205): Add support for model name argument on attach. This includes calling a module based on the model name to setup for any special processing required. Also add support to disable prt_conv_ processing and recognize rawo modes and pass them to tty_ module. END HISTORY COMMENTS */ /* format: on */ remote_printer_: procedure (); /* Parameters */ dcl a_code fixed bin (35) parameter; /* error code */ dcl a_data_chars fixed bin (21) parameter; /* number of chars to be input/output */ dcl a_data_ptr ptr parameter; /* ptr to chars to be input/output */ dcl a_infop ptr parameter; /* info ptr to control order */ dcl a_iocbp ptr parameter; /* iocb ptr */ dcl a_mode fixed bin parameter; /* The open mode */ dcl a_new_modes char (*) parameter; /* new modes to assign */ dcl a_old_modes char (*) parameter; /* current modes */ dcl a_option (*) char (*) var parameter; /* options for attach */ dcl a_order char (*) parameter; /* order to be executed */ dcl a_pos_type fixed bin parameter; /* iox_$position positioning type */ dcl a_pos_value fixed bin (21) parameter; /* iox_$position positioning count */ dcl a_sw bit (1) parameter; /* com_err_ switch for attach */ /* Automatic */ dcl attach_entry entry (ptr, fixed bin (35)) variable; /* special model entry to call to complete attachment */ dcl attach_entry_name char (64); /* module name for special model attachment */ dcl charp ptr; /* ptr to next char for output in put_chars entrypoint */ dcl code fixed bin (35); /* general error code */ dcl com_err_sw bit (1); /* Set if com_err_ should be called on attach error */ dcl cur_page fixed bin (24); /* current page number being output as returned by prt_conv_ */ dcl device_opt char (32) var; dcl dummy char (32) var; /* type of device for attachment */ dcl ec fixed bin (35); /* secondary error code */ dcl i fixed bin (21); /* misc counter */ dcl idx fixed bin; /* attachment argument index */ dcl ignore fixed bin (35); /* dummy error code */ dcl infop ptr; /* internal copy of control order info pointer */ dcl iocbp ptr; /* internal copy of iocb ptr */ dcl mask bit (36) aligned; /* for setting ips mask */ dcl my_options char (256) var; /* some of the attachment options */ dcl open_mode fixed bin; /* copy of user supplied input mode */ dcl order char (32); /* copy of user supplied order */ dcl prt_conv_outp ptr; /* where prt_conv_ is to put processed data */ dcl record_len fixed bin (21); /* length of prt_conv_ processed record */ dcl remaining_chars fixed bin (21); /* number of chars left for prt_conv_ to process */ dcl temp_iocbp ptr; /* temporary IOCB prt */ dcl terminal_attach_desc char (256) var; dcl terminal_attach_options char (256) var; dcl terminal_switch_name char (32) var; dcl total_chars fixed bin (24); /* number of chars requested for put_chars */ /* Internal Static */ dcl attach_count fixed bin int static init (0); dcl my_area_ptr ptr int static init (null); dcl my_area area based (my_area_ptr); dcl prt_conv_on bit (1) internal static init ("1"b); dcl static_comerr_sw bit (1) int static init ("0"b); /* Constants */ dcl printer_device char (32) int static options (constant) init ("printer"); dcl remote_device_name char (15) int static options (constant) init ("remote_printer_"); dcl space char (1) static init (" ") int options (constant); /* External Procedures & Variables */ dcl com_err_ entry options (variable); dcl continue_to_signal_ entry (fixed bin (35)); dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$bad_conversion fixed bin (35) ext; dcl error_table_$bad_mode ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); dcl error_table_$not_attached ext fixed bin (35); dcl error_table_$not_closed ext fixed bin (35); dcl error_table_$not_detached ext fixed bin (35); dcl error_table_$not_open ext fixed bin (35); dcl error_table_$request_pending ext fixed bin (35); dcl error_table_$wrong_no_of_args ext fixed bin (35); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl ioa_ entry options (variable); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$err_no_operation entry; dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$propagate entry (ptr); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin, fixed bin (35)); dcl prt_conv_ entry (ptr, fixed bin (21), ptr, fixed bin (21), ptr); dcl remote_printer_control_ entry (ptr, char (*), ptr, fixed bin (35)); dcl remote_printer_modes_ entry (ptr, char (*), char (*), fixed bin (35)); dcl sys_info$max_seg_size fixed bin ext; /* Conditions and Builtins */ dcl (conversion, cleanup, any_other) condition; dcl (addr, bin, char, currentsize, hbound, index, ltrim, null, rtrim, substr, unspec) builtin; %page; remote_printer_attach: entry (a_iocbp, a_option, a_sw, a_code); iocbp = a_iocbp; com_err_sw = a_sw | static_comerr_sw; /* report errors if either is on */ code, a_code = 0; if my_area_ptr = null then my_area_ptr = get_system_free_area_ (); adp = null; if iocbp -> iocb.attach_descrip_ptr ^= null then do; code = error_table_$not_detached; call abort_attach (code, "Switch name: ^a", iocbp -> iocb.name); end; if hbound (a_option, 1) < 1 then do; /* Must be at least one */ code = error_table_$wrong_no_of_args; call abort_attach (code, "Bad attach description.", ""); end; on cleanup call clean_up; allocate ad in (my_area) set (adp); /* make space for the attach data structure */ /* Initialize the Attach Data Structure variables */ ad.bits = "0"b; ad.fixed = 0; ad.ptrs = null; ad.chars = ""; unspec (ad.remote_pci) = "0"b; unspec (ad.info) = "0"b; ad.device_type = PRINTER_DEVICE; /* default for terminal_io_record structure */ ad.sheets_per_page = 1; ad.phys_line_length = 132; /* this will normally get reset by a paper_info control order */ ad.phys_page_length = 66; ad.lpi = 6; ad.line = 1; ad.cv_proc = null; /* not defined until the open operation */ /* Process options */ terminal_attach_options = ""; my_options = ""; terminal_attach_desc = ""; device_opt = "printer"; /* our default device option */ do idx = 1 to hbound (a_option, 1); if a_option (idx) = "-physical_line_length" | a_option (idx) = "-pll" then do; ad.phys_line_length = cv_dec_arg (idx); terminal_attach_options = terminal_attach_options || " -pll " || a_option (idx); end; else if a_option (idx) = "-physical_page_length" | a_option (idx) = "-ppl" then do; ad.phys_page_length = cv_dec_arg (idx); my_options = my_options || " -ppl " || a_option (idx); end; else if a_option (idx) = "-horizontal_tab" | a_option (idx) = "-htab" then do; ad.ht = "1"b; terminal_attach_options = terminal_attach_options || space || a_option (idx); end; else if a_option (idx) = "-runout_spacing" | a_option (idx) = "-runsp" then do; /* grab this and next arg */ dummy = get_arg (idx); /* don't pass on but say we got it */ my_options = my_options || " -runsp " || dummy; end; else if a_option (idx) = "-terminal" then do; ad.terminal = get_arg (idx); my_options = my_options || " -terminal " || ad.terminal; end; else if a_option (idx) = "-device" then device_opt = get_arg (idx); /* check out this option */ else if a_option (idx) = "-model" then do; ad.chars.model = get_arg (idx); end; else terminal_attach_options = terminal_attach_options || space || a_option (idx); end; if ad.terminal = "" then do; code = error_table_$noarg; call abort_attach (code, "No terminal IO Module specified.", ""); end; if ad.phys_line_length < 1 | ad.phys_line_length > 512 then do; code = error_table_$bad_arg; call abort_attach (code, "Invalid line length specified.", ""); end; if ad.phys_page_length < 10 | ad.phys_page_length > 128 then do; code = error_table_$bad_arg; call abort_attach (code, "Invalid page length specified.", ""); end; if device_opt ^= "printer" then do; /* was it changed? */ code = error_table_$bad_arg; call abort_attach (code, "Invalid -device option: ", (device_opt)); end; /* Attach through terminal dim */ attach_count = attach_count + 1; /* new attach name tag number each time */ if attach_count > 999 then attach_count = 1; terminal_switch_name = remote_device_name || ltrim (char (attach_count)); /* make the switch name */ terminal_attach_options = ltrim (terminal_attach_options) || " -device " || device_opt; terminal_attach_desc = ad.terminal || space || terminal_attach_options; ad.attach_desc = remote_device_name || my_options || space || terminal_attach_options; call iox_$attach_ioname ((terminal_switch_name), temp_iocbp, (terminal_attach_desc), code); if code ^= 0 then call abort_attach (code, "Unable to attach to terminal ", ""); ad.terminal_iocbp = temp_iocbp; /* Now mask and complete the iocb */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc); iocbp -> iocb.attach_data_ptr = adp; iocbp -> iocb.open = remote_printer_open; iocbp -> iocb.detach_iocb = remote_printer_detach; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; /* if a model is defined, special processing might be required for some of them. See if there is a special processing module to complete the attachment. If there is, call it and let it fiddle with the iocb */ if ad.chars.model ^= "" then do; attach_entry_name = "iodd_" || rtrim (ad.chars.model) || "_support_$complete_attach"; attach_entry = cv_entry_ (attach_entry_name, null, code); if code ^= 0 then call abort_attach (code, "Unable to locate ^a.", (attach_entry_name)); call attach_entry (iocbp, code); if code ^= 0 then call abort_attach (code, "Calling ^a.", (attach_entry_name)); end; call remote_printer_control_ (iocbp, "reset", null, code); if code ^= 0 then call abort_attach (code, "Unable to reset printer data", ""); attach_return: return; %page; remote_printer_detach: entry (a_iocbp, a_code); iocbp = a_iocbp; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; a_code = error_table_$not_closed; return; end; call clean_up; mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = null; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; %page; remote_printer_open: entry (a_iocbp, a_mode, a_sw, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; a_code = error_table_$not_closed; return; end; open_mode = a_mode; if ^((open_mode = Stream_output) | (open_mode = Stream_input_output)) then do; a_code = error_table_$bad_mode; return; end; call iox_$open (ad.terminal_iocbp, Sequential_output, "0"b, a_code); /* try for record output */ if a_code = 0 then do; ad.record_io = "1"b; /* we have record interface approval */ call hcs_$make_ptr (null, "remote_conv_", "printer", ad.cv_proc, a_code); if a_code ^= 0 then return; end; else do; ad.record_io = "0"b; /* try for stream interface */ call iox_$open (ad.terminal_iocbp, Stream_output, "0"b, a_code); if a_code ^= 0 then return; call hcs_$make_ptr (null, ad.terminal || "conv_", "printer", ad.cv_proc, a_code); if a_code ^= 0 then return; end; ad.open_description = rtrim (iox_modes (open_mode)); mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.put_chars = remote_printer_put_chars; iocbp -> iocb.control = remote_printer_control; iocbp -> iocb.modes = remote_printer_modes; iocbp -> iocb.position = remote_printer_position; iocbp -> iocb.close = remote_printer_close; iocbp -> iocb.open_descrip_ptr = addr (ad.open_description); call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; %page; remote_printer_close: entry (a_iocbp, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; call iox_$close (ad.terminal_iocbp, a_code); if a_code = error_table_$not_open | a_code = error_table_$not_attached then a_code = 0; mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.open_descrip_ptr = null; iocbp -> iocb.open = remote_printer_open; iocbp -> iocb.detach_iocb = remote_printer_detach; iocbp -> iocb.control = iox_$err_no_operation; iocbp -> iocb.position = iox_$err_no_operation; iocbp -> iocb.modes = iox_$err_no_operation; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; %page; remote_printer_put_chars: entry (a_iocbp, a_data_ptr, a_data_chars, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; if a_data_chars < 0 | a_data_chars > sys_info$max_seg_size * 4 then do; a_code = error_table_$bad_arg; return; end; total_chars, remaining_chars = a_data_chars; /* remaining_chars is decremented as data is sent */ charp = a_data_ptr; /* charp is bumped by prt_conv_ as data is sent */ terminal_io_record_ptr = null (); /* for the cleanup handler */ call iox_$control (ad.terminal_iocbp, "select_device", addr (printer_device), code); /* HACK FOR THE ibm2780_ TERMINAL DIM */ if code ^= 0 then go to put_chars_ret; pcip = addr (ad.remote_pci); /* ready for the prt_conv_ hack. We must force a write of all trailing NL chars, even though they have already been accounted for in the remaining chars. */ terminal_io_record_element_size = 9; /* always character data */ terminal_io_record_n_elements = 3 * ad.phys_line_length; /* enough room for 1 printing character and 2 non-printing characters per column (eg: DC1-u X) */ on cleanup begin; if terminal_io_record_ptr ^= null () then free terminal_io_record_ptr -> terminal_io_record in (my_area); end; call alloc_tio_rec; /* allocate and initialize the terminal_io_record */ if ad.record_io then prt_conv_outp = terminal_io_record_ptr; /* full record for record interface */ else prt_conv_outp = addr (terminal_io_record.data); /* use the string for stream interface */ do while (remaining_chars > 0 | pci.slew_residue > 0); /* so keep trying while there is anything to slew */ cur_page = pci.page_count; /* save the page number */ /* ******************************************************************** * Call prt_conv_ or not, depending on the value of the static * * switch prt_conv_on. * ******************************************************************** */ if prt_conv_on then call prt_conv_ (charp, remaining_chars, prt_conv_outp, record_len, pcip); else do; prt_conv_outp = charp; record_len = remaining_chars; remaining_chars = 0; end; if ^ad.noprint then do; /* if actually printing, send to the terminal */ if ad.record_io & prt_conv_on then do; call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr, 4 * currentsize (terminal_io_record), code); end; else do; /* stream output */ call iox_$put_chars (ad.terminal_iocbp, prt_conv_outp, record_len, code); end; if code ^= 0 then go to put_chars_ret; /* trouble */ end; if cur_page ^= ad.page_count then do; /* did we turn another page? */ ad.stop_counter = ad.stop_counter + 1; /* bump the page stop counter */ if ad.single_page | (ad.stop_every ^= 0 & ad.stop_counter >= ad.stop_every) then do; ad.stop_counter = 0; code = error_table_$request_pending; /* say we were not done yet */ go to put_chars_ret; /* exit the loop and return to caller */ end; end; end; put_chars_ret: if terminal_io_record_ptr ^= null () then free terminal_io_record_ptr -> terminal_io_record in (my_area); ad.chars_printed = ad.chars_printed + total_chars - remaining_chars; /* record our progress */ a_code = code; return; %page; remote_printer_control: entry (a_iocbp, a_order, a_infop, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; infop = a_infop; order = a_order; code, a_code = 0; if order = "io_call" then do; if a_infop = null then do; a_code = error_table_$bad_arg; return; end; order = infop -> io_call_info.order_name; infop = null; end; /* check for prt_conv_on/prt_conv_off orders and handle them directly without calling remote_printer_control_. */ if order = "prt_conv_on" | order = "prt_conv_off" then do; prt_conv_on = order = "prt_conv_on"; return; end; call remote_printer_control_ (iocbp, order, infop, code); if code ^= 0 then do; /* if not done or partially completed, pass it on */ call iox_$control (ad.terminal_iocbp, order, infop, ec); if ec = 0 then code = 0; /* let the code from remote_printer_control preveil */ end; if order = "reset" then do; call iox_$control (ad.terminal_iocbp, order, infop, ignore); prt_conv_on = "1"b; end; a_code = code; return; %page; remote_printer_modes: entry (a_iocbp, a_new_modes, a_old_modes, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; code, a_code = 0; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; call remote_printer_modes_ (iocbp, a_new_modes, a_old_modes, a_code); if a_new_modes = "default" then do; call iox_$modes (ad.terminal_iocbp, a_new_modes, "", ignore); end; else if index (a_new_modes, "non_edited") ^= 0 then do; i = index (a_new_modes, "non_edited"); if i = 1 then call iox_$modes (ad.terminal_iocbp, "non_edited", "", ignore); else if substr (a_new_modes, i - 1, 1) = "^" then call iox_$modes (ad.terminal_iocbp, "default", "", ignore); else call iox_$modes (ad.terminal_iocbp, "non_edited", "", ignore); end; else if index (a_new_modes, "rawo") ^= 0 then do; i = index (a_new_modes, "rawo"); if i = 1 then call iox_$modes (ad.terminal_iocbp, "rawo", "", ignore); else if substr (a_new_modes, i - 1, 1) = "^" then call iox_$modes (ad.terminal_iocbp, "^rawo", "", ignore); else call iox_$modes (ad.terminal_iocbp, "rawo", "", ignore); end; return; %page; remote_printer_position: entry (a_iocbp, a_pos_type, a_pos_value, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; code, a_code = 0; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; call iox_$position (ad.terminal_iocbp, a_pos_type, a_pos_value, a_code); return; flip_com_err_sw: entry; static_comerr_sw = ^static_comerr_sw; /* flip the bit */ call ioa_ ("The printer com err sw is now: ^[on^;off^]", static_comerr_sw); return; %page; get_arg: procedure (idx) returns (character (*)); dcl idx fixed bin; idx = idx + 1; /* advance the arg index of the main loop */ if idx > hbound (a_option, 1) then do; code = error_table_$noarg; call abort_attach (code, "No argument after ^a.", (a_option (idx - 1))); end; return (a_option (idx)); end get_arg; cv_dec_arg: procedure (idx) returns (fixed binary); dcl idx fixed bin; idx = idx + 1; /* advance the arg index of the main loop */ if idx > hbound (a_option, 1) then do; code = error_table_$noarg; call abort_attach (code, "No argument after ^a.", (a_option (idx - 1))); end; on conversion go to bad_dec_arg; return (bin (a_option (idx))); bad_dec_arg: code = error_table_$bad_conversion; call abort_attach (code, "Invalid decimal number. ^a", (a_option (idx))); end cv_dec_arg; abort_attach: procedure (code, str1, str2); dcl code fixed bin (35); dcl (str1, str2) char (*) aligned; /* This proc handles attach errors */ if com_err_sw then call com_err_ (code, remote_device_name, str1, str2); a_code = code; call clean_up; go to attach_return; /* abort the attach by non-local go to */ end abort_attach; %page; alloc_tio_rec: procedure (); allocate terminal_io_record in (my_area) set (terminal_io_record_ptr); unspec (terminal_io_record) = "0"b; /* clear everything */ terminal_io_record.version = terminal_io_record_version_1; /* our view of the record structure */ terminal_io_record.device_type = ad.device_type; terminal_io_record.element_size = terminal_io_record_element_size; /* set by our caller */ return; end alloc_tio_rec; clean_up: procedure (); /* this is for any form of abort during attachment */ if adp ^= null then do; if ad.terminal_iocbp ^= null then call iox_$detach_iocb (ad.terminal_iocbp, ignore); free adp -> ad in (my_area); adp = null; end; iocbp -> iocb.attach_descrip_ptr = null; /* be sure iox_ knows */ iocbp -> iocb.attach_data_ptr = null; iocbp -> iocb.open = iox_$err_no_operation; return; end clean_up; handler: procedure (); dcl ignore fixed bin (35); /* This proc handles faults that occur while masked */ if mask then call hcs_$reset_ips_mask (mask, mask); mask = ""b; call continue_to_signal_ (ignore); return; end handler; %page; %include io_call_info; %page; %include iocb; %page; %include iox_modes; %page; %include prt_conv_info; %page; %include prt_info; %page; %include remote_attach_data; %page; %include terminal_io_record; end remote_printer_;  remote_punch_.pl1 01/19/88 1428.9rew 01/19/88 1330.0 261630 /****^ *********************************************************** * * * 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. * * * *********************************************************** */ remote_punch_: proc; /* remote_punch_: An I/O module for communicating with a remote punch or its equivilent. */ /* Coded March 1977 by David Vinograd */ /* Modified for user TTFs and cleaned up May 1978 by D. Vinograd */ /* Modified by J. C. Whitmore, 11/78, to make the attach options consistent among all remote_xxx_ dims */ /* Modified by J. C. Whitmore, 10/79, to support binary_punch mode (control order) */ /* Modified by J. C. Whitmore, 2/80, to do full record IO to terminal dim */ /****^ HISTORY COMMENTS: 1) change(87-11-23,Beattie), approve(87-12-21,MCR7821), audit(88-01-13,Brunelle), install(88-01-19,MR12.2-1014): Prevent splitting of card images that span component boundaries of MSFs. (phx21014) END HISTORY COMMENTS */ /* format: style4 */ /* Parameters */ dcl a_iocbp ptr parameter; dcl a_option (*) char (*) var parameter; /* Options for attach */ dcl a_sw bit (1) parameter; /* com_err_ switch for attach */ dcl a_code fixed bin (35) parameter; dcl a_mode fixed bin parameter; /* The open mode */ dcl a_data_ptr ptr parameter; dcl a_data_count fixed bin (24) parameter; dcl a_pos_type fixed bin parameter; dcl a_pos_value fixed bin (24) parameter; dcl a_order char (*) parameter; dcl a_infop ptr parameter; dcl old_modes char (*) parameter; dcl new_modes char (*) parameter; /* Attach entry point */ remote_punch_attach: entry (a_iocbp, a_option, a_sw, a_code); iocbp = a_iocbp; com_err_sw = a_sw | static_com_err_sw; code, a_code = 0; adp = null; if iocbp -> iocb.attach_descrip_ptr ^= null then do; code = error_table_$not_detached; call abort_attach (code, "Switch name: ^a", iocbp -> iocb.name); end; if areap = null then do; /* first time called, make attach area */ call get_temp_segment_ (remote_device_name, areap, code); /* Temp segment for attach data area */ if code ^= 0 then call abort_attach (code, "Unable to allocate temp segment.", ""); areap -> my_area = empty (); /* initialize the area */ end; on cleanup call clean_up_handler; /* be sure to free attach data on abort */ allocate ad in (my_area) set (adp); /* create the attach data for this switch */ /* Initialize attach data variables */ ad.bits = "0"b; ad.fixed = 0; ad.ptrs = null; ad.chars = ""; ad.edited = "1"b; /* always default to the edited mode */ ad.stream_output = "1"b; /* use the stream interface until records are fully defined */ ad.card_ll = 80; /* default number of columns per card */ ad.device_type = PUNCH_DEVICE; /* default to output to a punch device */ /* Process attach options */ if hbound (a_option, 1) < 1 then do; /* Must be at least one */ code = error_table_$wrong_no_of_args; call abort_attach (code, "Bad attach description.", ""); end; terminal_attach_options = ""; my_options = ""; terminal_attach_desc = ""; terminal_attach_name = ""; device_type = ""; /* mark as no -device option given */ on conversion begin; code = error_table_$bad_arg; call abort_attach (code, "Attach option conversion error.", ""); end; do idx = 1 to hbound (a_option, 1); if a_option (idx) = "-runout_spacing" | a_option (idx) = "-runsp" then do; /* skip it and next option */ dummy = get_arg (idx); my_options = my_options || " -runsp " || dummy; end; else if a_option (idx) = "-htab" | a_option (idx) = "-horizontal_tab" then do; ad.htab = "1"b; /* allow tabs to be sent to remote */ my_options = my_options || " -htab"; end; else if a_option (idx) = "-non_edited" then do; ad.edited = "0"b; /* allow ctl chars to be sent to remote */ my_options = my_options || " -non_edited"; end; else if a_option (idx) = "-card_ll" then do; dummy = get_arg (idx); my_options = my_options || " -card_ll " || dummy; ad.card_ll = convert (ad.card_ll, dummy); /* get it into fixed bin form */ end; else if a_option (idx) = "-physical_page_length" | a_option (idx) = "-ppl" then do; /* absorb this too */ dummy = get_arg (idx); my_options = my_options || " -ppl " || dummy; end; else if a_option (idx) = "-device" then do; device_type = get_arg (idx); /* record this */ my_options = my_options || " -device " || rtrim (device_type); end; else if a_option (idx) = "-terminal" then ad.terminal = get_arg (idx); else terminal_attach_options = terminal_attach_options || space || a_option (idx); end; /* Attach through terminal dim */ if ad.terminal = "" then do; /* must specify the next level */ code = error_table_$badopt; call abort_attach (code, "Missing option -terminal.", ""); end; if device_type = "" then device_type = "punch"; /* choose the default if not specified */ else do; /* otherwise check it out more ... */ if device_type = "reader_simulator" then do; device_type = "reader"; /* we are to simulate the reader of a workstation */ ad.device_type = READER_DEVICE; end; else if device_type ^= "punch" then do; /* the only other one we will accept */ code = error_table_$bad_arg; call abort_attach (code, "Invalid -device option: ^a", (device_type)); end; end; if ad.card_ll < 1 | ad.card_ll > 160 then do; /* validate the line length */ code = error_table_$bad_arg; call abort_attach (code, "Invalid card line length", ""); end; attach_count = attach_count + 1; /* new attach name each time */ if attach_count > 999 then attach_count = 1; terminal_attach_name = remote_device_name || ltrim (character (attach_count)); ad.attach_desc = remote_device_name || " -terminal " || ad.terminal || terminal_attach_options || my_options; terminal_attach_desc = ad.terminal || terminal_attach_options || " -device " || rtrim (device_type); call iox_$attach_ioname ((terminal_attach_name), ad.terminal_iocbp, (terminal_attach_desc), code); if code ^= 0 then call abort_attach (code, "Unable to attach to terminal ", ""); /* Now mask and complete the iocb */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc); iocbp -> iocb.open_descrip_ptr = null; iocbp -> iocb.attach_data_ptr = adp; iocbp -> iocb.open = remote_punch_open; iocbp -> iocb.detach_iocb = remote_punch_detach; call iox_$propagate (iocbp); revert cleanup; /* we are now comitted; require a detach */ call hcs_$reset_ips_mask (mask, mask); revert any_other; attach_return: a_code = code; return; /* Detach entry point */ remote_punch_detach: entry (a_iocbp, a_code); iocbp = a_iocbp; a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; a_code = error_table_$not_closed; return; end; /* First, kill the switch defination known by iox_ */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = null; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; /* Now kill the terminal IO switch. If this fails, there isn't anything we can do about it. */ /* So, ignore any errors ... we tried at least. */ call iox_$detach_iocb (ad.terminal_iocbp, ignore); if ad.stat_term_rec_ptr ^= null then do; free ad.stat_term_rec_ptr -> terminal_io_record in (my_area); ad.stat_term_rec_ptr = null; end; free adp -> ad in (my_area); adp = null; return; /* Open entry point */ remote_punch_open: entry (a_iocbp, a_mode, a_sw, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; a_code = error_table_$not_closed; return; end; open_mode = a_mode; if ^((open_mode = Stream_output) | (open_mode = Stream_input_output)) then do; a_code = error_table_$bad_mode; return; end; call iox_$open (ad.terminal_iocbp, Sequential_output, "0"b, a_code); /* try for record interface first */ if a_code = 0 then ad.stream_output = "0"b; /* we have it, so use it */ else do; ad.stream_output = "1"b; /* this is all that's left if it works */ call iox_$open (ad.terminal_iocbp, Stream_output, "0"b, a_code); if a_code ^= 0 then return; /* too bad, abort the open */ end; ad.open_description = rtrim (iox_modes (open_mode)); mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.put_chars = write_elements; iocbp -> iocb.get_chars = iox_$err_no_operation; iocbp -> iocb.get_line = iox_$err_no_operation; iocbp -> iocb.control = remote_punch_control; iocbp -> iocb.modes = remote_punch_modes; iocbp -> iocb.position = remote_punch_position; iocbp -> iocb.close = remote_punch_close; iocbp -> iocb.open_descrip_ptr = addr (ad.open_description); call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); return; /* Close entry point */ remote_punch_close: entry (a_iocbp, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; /* Try to close the terminal IO switch. If it fails, there isn't anything we can do about it. */ /* So just ignore the error code. Our switch will be closed successfully. */ call iox_$close (ad.terminal_iocbp, ignore); mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.open_descrip_ptr = null; iocbp -> iocb.open = remote_punch_open; iocbp -> iocb.detach_iocb = remote_punch_detach; iocbp -> iocb.control = iox_$err_no_operation; iocbp -> iocb.position = iox_$err_no_operation; iocbp -> iocb.modes = iox_$err_no_operation; iocbp -> iocb.put_chars = iox_$err_no_operation; iocbp -> iocb.get_chars = iox_$err_no_operation; iocbp -> iocb.get_line = iox_$err_no_operation; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); return; /* Put_chars entry point */ write_elements: entry (a_iocbp, a_data_ptr, a_data_count, a_code); /* This entry takes data defined by the data ptr and the data length count as stream input and breaks the data into card image records for the terminal IO module. Both character and binary card images are supported by remote_punch_. This module can be called for each component of an MSF and card images will not be broken. The "runout" control order flushes the last card if present in the output buffer. */ iocbp = a_iocbp -> iocb.actual_iocb_ptr; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if ad.binary then max_size = BITS_PER_SEGMENT; /* max bit count */ else max_size = CHARS_PER_SEGMENT; /* max char count */ if a_data_count < 0 | a_data_count > max_size then do; a_code = error_table_$bad_arg; return; end; call iox_$control (ad.terminal_iocbp, "select_device", addr (punch_device), code); if code ^= 0 then go to put_chars_ret; remaining_count = a_data_count; /* This is decremented as data is sent */ wp = a_data_ptr; /* set local pointer to callers workspace */ in_pos = 1; /* start with the first input element */ if ad.binary then do; /* for binary punch output */ if ad.stat_term_rec_ptr = null then do; /* if we haven't already done this */ terminal_io_record_element_size = 1; /* setup for allocation of output record */ terminal_io_record_n_elements = 960; /* max record length of 960 bits in binary mode */ call allocate_tio_rec; /* make an output record block */ terminal_io_record.binary = "1"b; /* mark this as a binary record */ end; else terminal_io_record_ptr = ad.stat_term_rec_ptr; do while (remaining_count > 0); if ad.rec_len > 0 then do; /* there is data here from last call */ data_len = min (960 - ad.rec_len, remaining_count); substr (terminal_io_record_data_bits, ad.rec_len + 1) = substr (wp -> bit_string, in_pos, data_len); ad.rec_len = ad.rec_len + data_len; if ad.rec_len < 960 then go to put_chars_ret; call send_binary; in_pos = in_pos + data_len; remaining_count = remaining_count - data_len; end; /* data here from last call */ else do; ad.rec_len = min (960, remaining_count); /* records are 1 to 960 bits long */ terminal_io_record_data_bits = substr (wp -> bit_string, in_pos, ad.rec_len); /* define the record and pad with zeros */ if ad.rec_len < 960 then go to put_chars_ret; /* there may be mor in a later call */ call send_binary; in_pos = in_pos + ad.rec_len; /* bump the workspace index */ remaining_count = remaining_count - ad.rec_len; /* and decrement the remainder count */ end; /* no data in buffer from previous call */ end; /* while data to send */ end; /* if binary to send */ else do; /* for character output */ if ad.stat_term_rec_ptr = null then do; /* done only once per file */ terminal_io_record_element_size = 9; /* 9 bits per character in the record */ terminal_io_record_n_elements = ad.card_ll; /* max record size */ call allocate_tio_rec; /* make an output record block */ residue = 0; /* space residue from HT processing */ ad.tab_idx = 1; /* virtual carriage position for tab calc */ end; else terminal_io_record_ptr = ad.stat_term_rec_ptr; if ad.out_pos > 1 then go to next_char; /* we already have some data in output record */ do while (remaining_count > 0); terminal_io_record.n_elements = ad.card_ll; /* reset to max length each time */ terminal_io_record_data_chars = ""; /* clear the card image, we need spaces for tab padding */ ad.out_pos = 1; /* build card image starting in col 1 */ if residue > 0 then do; ad.out_pos = ad.out_pos + residue; /* move over extra spaces */ residue = 0; /* reset the space residue */ end; next_char: if remaining_count <= 0 then go to put_chars_ret; /* if done with input due to editing, just stop */ /* may get more */ char = substr (wp -> char_string, in_pos, 1); /* pickup next character */ in_pos = in_pos + 1; /* bump the index */ remaining_count = remaining_count - 1; /* and decrement the remainder */ if rank (char) < rank (" ") then do; /* look for control chars */ if char = CR | char = NL | char = VT | char = FF then do; /* card terminators */ ad.tab_idx = 1; /* reset the virtual carriage */ go to send; /* send off the card */ end; if char = HT then do; /* for tabs, put out spaces, let terminal compress */ if ^ad.htab then do; /* if not sending the tab char, pad it out */ tab_stop = divide (ad.tab_idx + 9, 10, 0) * 10 + 1; /* 11, 21, 31, ... */ count = tab_stop - ad.tab_idx; /* spaces we are to move */ ad.tab_idx = tab_stop; /* move the virtual carriage to new stop */ if ad.out_pos + count > ad.card_ll then do; /* fold spaces? */ residue = (ad.out_pos - 1) + count - ad.card_ll; /* save the extra for later */ go to send; /* and send off this card image */ end; ad.out_pos = ad.out_pos + count; /* just step over spaces already there */ go to next_char; /* and go on to the next character */ end; end; else if ad.edited then go to next_char; /* edit out back space and ctl chars not handled */ end; /* if control character */ else if rank (char) > rank ("~") then go to next_char; /* drop all above 176 octal */ substr (terminal_io_record_data_chars, ad.out_pos, 1) = char; /* put the char into the output record */ ad.out_pos = ad.out_pos + 1; /* that position is used up */ ad.tab_idx = ad.tab_idx + 1; /* also move the virtual carriage */ if ad.out_pos <= ad.card_ll then go to next_char; /* fill up the card through col ad.card_ll */ else if remaining_count > 0 then do; /* check for terminating char if more input */ char = substr (wp -> char_string, in_pos, 1); /* get the next char */ if char = CR | char = NL | char = VT | char = FF then do; remaining_count = remaining_count - 1; /* skip over the terminator */ in_pos = in_pos + 1; end; end; send: call send_chars; end; /* start a new card image */ end; /* character output */ put_chars_ret: a_code = code; return; /* Control entry point */ remote_punch_control: entry (a_iocbp, a_order, a_infop, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; code = error_table_$not_attached; return; end; infop = a_infop; order = a_order; code, a_code = 0; if order = "reset" then do; ad.records_sent = 0; /* reset the accounting data */ ad.binary = "0"b; /* back to the default of character output */ ad.rec_len, ad.out_pos = 0; /* forget any held output */ if ad.stat_term_rec_ptr ^= null then do; free ad.stat_term_rec_ptr -> terminal_io_record in (my_area); ad.stat_term_rec_ptr = null; end; go to pass_it_on; /* let it go to the terminal also */ end; else if order = "binary_punch" then do; /* cannot allow ad.binary to change during an IO */ if ad.binary & ad.rec_len > 0 then go to noop_error; else if ad.out_pos > 1 then go to noop_error; call iox_$control (ad.terminal_iocbp, order, infop, code); /* see if terminal can do it */ if code = 0 then ad.binary = "1"b; /* set binary mode only if terminal agrees on binary */ else ad.binary = "0"b; /* otherwise, keep character mode */ end; else if order = "get_count" then do; /* give the accounting data */ if infop ^= null then do; infop -> counts.line_count = ad.records_sent; /* use the line count as card count */ infop -> counts.page_count = 0; /* not valid data for a punch */ end; else noop_error: code = error_table_$no_operation; end; else if order = "runout" then do; if ad.binary & ad.rec_len > 0 then call send_binary; else if ad.out_pos > 1 then call send_chars; if ad.stat_term_rec_ptr ^= null then do; free ad.stat_term_rec_ptr -> terminal_io_record in (my_area); ad.stat_term_rec_ptr = null; end; go to pass_it_on; end; else do; pass_it_on: call iox_$control (ad.terminal_iocbp, order, infop, code); end; a_code = code; return; /* Modes entry point */ remote_punch_modes: entry (a_iocbp, new_modes, old_modes, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; a_code = 0; if adp = null then do; a_code = error_table_$not_attached; return; end; call iox_$modes (ad.terminal_iocbp, new_modes, old_modes, a_code); return; /* Position entry point */ remote_punch_position: entry (a_iocbp, a_pos_type, a_pos_value, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; a_code = 0; call iox_$position (ad.terminal_iocbp, a_pos_type, a_pos_value, a_code); return; flip_com_err_sw: entry; /* entry to flip the com_err_sw */ static_com_err_sw = ^static_com_err_sw; /* that's it */ return; get_arg: proc (idx) returns (char (*)); dcl idx fixed bin; idx = idx + 1; /* advance the option index to the option arg */ if idx > hbound (a_option, 1) then do; /* check the range */ code = error_table_$noarg; call abort_attach (code, "No argument after ^a.", (a_option (idx - 1))); end; return (a_option (idx)); end get_arg; abort_attach: proc (code, str1, str2); dcl (str1, str2) char (*) aligned; dcl code fixed bin (35); /* This proc handles attach errors */ if com_err_sw then call com_err_ (code, remote_device_name, str1, str2); call clean_up_handler; go to attach_return; end abort_attach; clean_up_handler: proc; if adp ^= null then do; if ad.terminal_iocbp ^= null then call iox_$detach_iocb (ad.terminal_iocbp, ignore); free adp -> ad in (my_area); if ad.stat_term_rec_ptr ^= null then do; free ad.stat_term_rec_ptr -> terminal_io_record in (my_area); ad.stat_term_rec_ptr = null; end; adp = null; end; return; end clean_up_handler; handler: proc; /* This proc handles faults that occur while masked */ if mask then call hcs_$reset_ips_mask (mask, mask); mask = "0"b; call continue_to_signal_ (ignore); return; end handler; allocate_tio_rec: proc; allocate terminal_io_record in (my_area) set (ad.stat_term_rec_ptr); terminal_io_record_ptr = ad.stat_term_rec_ptr; unspec (terminal_io_record) = "0"b; /* clear any garbage */ terminal_io_record.version = terminal_io_record_version_1; /* announce our view of the record structure */ terminal_io_record.device_type = ad.device_type; /* inform the terminal dim if we are a reader or punch */ terminal_io_record.element_size = terminal_io_record_element_size; /* set by our caller */ terminal_io_record.n_elements = terminal_io_record_n_elements; return; end allocate_tio_rec; send_binary: proc; terminal_io_record.n_elements = ad.rec_len; /* set the data record size */ if ad.stream_output then /* for the stream interface to the terminal */ call iox_$put_chars (ad.terminal_iocbp, addr (terminal_io_record.bits), ad.rec_len, code); else do; call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr, 4 * currentsize (terminal_io_record), code); end; if code ^= 0 then go to put_chars_ret; ad.records_sent = ad.records_sent + 1; /* account for all records we send */ ad.rec_len = 0; /* not holding any data */ end send_binary; send_chars: proc; terminal_io_record.n_elements = ad.out_pos - 1; /* define the final length of this record */ if ad.stream_output then call iox_$put_chars (ad.terminal_iocbp, addr (terminal_io_record.bits), ad.out_pos - 1, code); else call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr, 4 * currentsize (terminal_io_record), code); if code ^= 0 then go to put_chars_ret; ad.records_sent = ad.records_sent + 1; /* for the accounting, only count successful writes */ ad.out_pos = 1; /* start in column 1 */ end send_chars; /* Automatic */ dcl code fixed bin (35); dcl com_err_sw bit (1); /* Set if com_err_ sould be called on attach error */ dcl count fixed bin; /* number of spaces to move to tab stop */ dcl device_type char (32); /* temp for value of the -device att opt */ dcl dummy char (32) var; dcl idx fixed bin; /* index variable for do loops */ dcl ignore fixed bin (35); dcl in_pos fixed bin (24); /* index of next element in callers data */ dcl infop ptr; dcl iocbp ptr; dcl mask bit (36) aligned; /* For setting ips mask */ dcl max_size fixed bin (24); dcl char char (1); /* test char for editing output */ dcl my_options char (64) var; /* this should be small */ dcl open_mode fixed bin; dcl order char (32); dcl data_len fixed bin; /* length of data to fill out current output record */ dcl remaining_count fixed bin (24); /* number of data elements to be punched */ dcl residue fixed bin; /* spaces to be added to next card image */ dcl tab_stop fixed bin; /* next tab stop for tab calculations */ dcl terminal_attach_desc char (256) var; dcl terminal_attach_name char (32) var; dcl terminal_attach_options char (256) var; dcl wp ptr; /* input data workspace pointer */ /* Internal Static */ dcl attach_count fixed bin int static init (0); dcl areap ptr int static init (null); dcl static_com_err_sw bit (1) int static init ("0"b); /* for testing attach options */ /* Based variables */ dcl my_area area (WORDS_PER_SEGMENT) based (areap); dcl bit_string bit (BITS_PER_SEGMENT) based; /* input data for binary punching */ dcl char_string char (CHARS_PER_SEGMENT) based; /* input data for character punching */ /* Constants */ dcl remote_device_name char (13) int static options (constant) init ("remote_punch_"); dcl punch_device char (32) int static options (constant) init ("punch"); dcl space char (1) static init (" ") int options (constant); dcl HT char (1) int static options (constant) init (" "); dcl NL char (1) int static options (constant) init (" "); dcl CR char (1) int static options (constant) init (" "); dcl VT char (1) int static options (constant) init (" "); dcl FF char (1) int static options (constant) init (" "); /* External stuff */ dcl continue_to_signal_ entry (fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl com_err_ entry options (variable); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin, fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$propagate entry (ptr); dcl iox_$position entry (ptr, fixed bin, fixed bin (24), fixed bin (35)); dcl iox_$err_no_operation entry; dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$bad_mode ext fixed bin (35); dcl error_table_$not_attached ext fixed bin (35); dcl error_table_$not_open ext fixed bin (35); dcl error_table_$not_closed ext fixed bin (35); dcl error_table_$not_detached ext fixed bin (35); dcl error_table_$wrong_no_of_args ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); dcl error_table_$no_operation ext fixed bin (35); /* Conditions and Builtins */ dcl (addr, character, convert, currentsize, divide, empty, hbound, ltrim, min, null, rank, rtrim, substr, unspec) builtin; dcl (any_other, cleanup, conversion) condition; dcl adp ptr; dcl 1 ad aligned based (adp), 2 fixed, 3 device_type fixed bin, /* one of the codes defined in terminal_io_record.incl.pl1 */ 3 records_sent fixed bin, /* for accounting, card images sent */ 3 card_ll fixed bin, /* number of columns per card starting in col 1 */ 3 out_pos fixed bin, /* next available output buffer element index */ 3 rec_len fixed bin, /* length of bits in record */ 3 tab_idx fixed bin, /* virtual carriage position for tab calculations */ 2 bits, 3 binary bit (1) unal, /* TRUE when in binary punch mode */ 3 edited bit (1) unal, /* TRUE when character editing is to be done */ 3 htab bit (1) unal, /* TRUE when HT chars are allowed to be sent */ 3 stream_output bit (1) unal, /* TRUE if stream interface to terminal is needed */ 2 ptrs, 3 terminal_iocbp ptr, /* iocbp for terminal dim of this attachment */ 3 stat_term_rec_ptr ptr, /* pointer to data record */ 2 chars, 3 terminal char (32) var, /* name of the terminal dim */ 3 attach_desc char (256) var, /* attach description of this attachment */ 3 open_description char (24) var; /* open desc for this attachment */ dcl 1 counts aligned based (infop), /* accounting data for caller */ 2 line fixed bin, /* for printers */ 2 page_len fixed bin, /* " */ 2 lmarg fixed bin, /* " */ 2 rmarg fixed bin, /* " */ 2 line_count fixed bin, /* this is the relavent information */ 2 page_count fixed bin; /* this could be used, set to zero */ %include terminal_io_record; %include iocb; %include iox_modes; %include system_constants; end remote_punch_;  remote_teleprinter_.pl1 10/28/88 1405.8r w 10/28/88 1257.9 249399 /****^ *********************************************************** * * * 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. * * * *********************************************************** */ /* format: style4,delnl,insnl,^ifthendo */ /* format: off */ /* remote_teleprinter_: An I/O module for communicating with the operator console function of a remote device. */ /* Created: March 1977 by David Vinograd */ /* Modified: May 1978 by David Vinograd for user TTFs */ /* Modified: November 1978 by J. C. Whitmore to make the attach options consistent among all remote_xxx_ dims */ /* Modified: March 1979 by J. C. Whitmore to initialize so get_line function returns a NL char and cleanup returned modes */ /* Modified: March 1980 by J. C. Whitmore to use the terminal_io_record interface to the terminal IO module */ /* Modified: 13 December 1981 by G. Palter to not use illegal PL/I and provide sufficient extra space for prt_conv_ to output control sequences */ /****^ 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): Corrected pl1 warning about terminal_io_record_data_chars_varying_max_len being referenced, but never set. END HISTORY COMMENTS */ /* format: on */ remote_teleprinter_: procedure (); /* Parameters */ dcl a_iocbp ptr parameter; dcl a_option (*) char (*) var parameter; /* Options for attach */ dcl a_sw bit (1) parameter; /* com_err_ switch for attach */ dcl a_code fixed bin (35) parameter; dcl a_mode fixed bin parameter; /* The open mode */ dcl a_buf_ptr ptr parameter; dcl a_data_ptr ptr parameter; dcl a_buf_chars fixed bin (21) parameter; dcl a_data_chars fixed bin (21) parameter; dcl a_pos_type fixed bin parameter; dcl a_pos_value fixed bin (21) parameter; dcl a_order char (*) parameter; dcl a_infop ptr parameter; dcl a_old_modes char (*) parameter; dcl a_new_modes char (*) parameter; /* Automatic */ dcl (prt_modes, card_modes) char (160); dcl last_char char (1); dcl last_pos fixed bin; dcl com_err_sw bit (1); /* Set if com_err_ sould be called on attach error */ dcl charp ptr; dcl device_opt char (32) var; dcl ignore fixed bin (35); dcl (code, ec, prt_code, card_code) fixed bin (35); dcl iocbp ptr; dcl arg char (32); dcl argp ptr; dcl mask bit (36) aligned; /* For setting ips mask */ dcl i fixed bin (21); dcl idx fixed bin; dcl open_mode fixed bin; dcl remaining_chars fixed bin (21); dcl data_chars fixed bin (21); dcl order char (32); dcl prt_conv_outp ptr; /* pointer to output workspace for prt_conv_ */ dcl record_len fixed bin; dcl infop ptr; dcl temp_iocbp ptr; dcl runout_spacing_cnt fixed bin; dcl terminal_switch_name char (32) var; dcl my_options char (256) var; dcl terminal_attach_options char (256) var; dcl terminal_attach_desc char (256) var; dcl nl_string char (32); /* temp string of nl chars */ /* Based */ dcl char_string char (1024) based; dcl info_fixed fixed bin based; dcl my_area area based (get_system_free_area_ ()); /* Internal Static */ dcl put_chars_since_last_runout bit (1) static init ("1"b); dcl attach_count fixed bin int static init (0); dcl static_comerr_sw bit (1) int static init ("0"b); /* Constants */ dcl remote_device_name char (19) int static options (constant) init ("remote_teleprinter_"); dcl teleprinter char (32) int static init ("teleprinter") options (constant); dcl space char (1) static init (" ") int options (constant); dcl Card_Util_Char_Max fixed bin int static init (2000) options (constant); dcl NL char (1) static init (" ") int static options (constant); /* External stuff */ dcl ioa_ entry options (variable); dcl com_err_ entry options (variable); dcl card_util_$modes entry (char (*), bit (36) aligned, char (*), fixed bin (35)); dcl card_util_$translate entry (bit (36) aligned, char (*) var); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl prt_conv_ entry (ptr, fixed bin (21), ptr, fixed bin, ptr); dcl remote_printer_modes_ entry (ptr, char (*), char (*), fixed bin (35)); dcl remote_printer_control_ entry (ptr, char (*), ptr, fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl iox_$propagate entry (ptr); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35)); dcl iox_$get_chars entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$err_no_operation entry; dcl sys_info$max_seg_size fixed bin ext; dcl error_table_$bad_conversion fixed bin (35) ext; dcl error_table_$eof_record ext fixed bin (35); dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$bad_mode ext fixed bin (35); dcl error_table_$not_detached ext fixed bin (35); dcl error_table_$not_attached ext fixed bin (35); dcl error_table_$not_open ext fixed bin (35); dcl error_table_$not_closed ext fixed bin (35); dcl error_table_$data_loss ext fixed bin (35); dcl error_table_$wrong_no_of_args ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); dcl error_table_$unimplemented_version ext fixed bin (35); /* Conditions and Builtins */ dcl (conversion, any_other, cleanup) condition; dcl (addr, bin, hbound, length, min, max, copy, null, substr, ltrim, rtrim, convert, unspec, index, char, currentsize, size) builtin; /* */ remote_teleprinter_attach: entry (a_iocbp, a_option, a_sw, a_code); iocbp = a_iocbp; com_err_sw = a_sw | static_comerr_sw; /* report errors if either is on */ code, a_code = 0; adp = null; if iocbp -> iocb.attach_descrip_ptr ^= null then do; code = error_table_$not_detached; call abort_attach (code, "Switch name: ^a", iocbp -> iocb.name); end; if hbound (a_option, 1) < 1 then do; /* Must be at least one */ code = error_table_$wrong_no_of_args; call abort_attach (code, "Bad attach description.", ""); end; on cleanup call clean_up; /* if we abort, be sure to clean up */ allocate ad in (my_area) set (adp); /* create the attach data structure for this attachment */ /* Initialize the Attach Data Structure variables */ ad.bits = "0"b; ad.fixed = 0; ad.ptrs = null; ad.chars = ""; unspec (ad.remote_pci) = "0"b; ad.device_type = TELEPRINTER_DEVICE; /* for the terminal_io_record structure */ ad.sheets_per_page = 1; ad.phys_line_length = 80; ad.phys_page_length = 66; ad.lpi = 6; ad.line = 1; ad.cv_proc = null; /* co-routine is undefined until switch is opened */ call card_util_$modes ("lower_case,trim,add_nl.", ad.input_modes, "", code); if code ^= 0 then call abort_attach (code, "Unable to set initial modes.", ""); /* Process options */ my_options = ""; terminal_attach_options = ""; terminal_attach_desc = ""; device_opt = "teleprinter"; /* this is our default */ do idx = 1 to hbound (a_option, 1); if a_option (idx) = "-physical_line_length" | a_option (idx) = "-pll" then do; ad.phys_line_length = cv_dec_arg (idx); terminal_attach_options = terminal_attach_options || " -pll " || a_option (idx); end; else if a_option (idx) = "-physical_page_length" | a_option (idx) = "-ppl" then do; ad.phys_page_length = cv_dec_arg (idx); my_options = my_options || " -ppl " || a_option (idx); end; else if a_option (idx) = "-device" then device_opt = get_arg (idx); /* we specify this */ else if a_option (idx) = "-horizontal_tab" | a_option (idx) = "-htab" then do; ad.ht = "1"b; terminal_attach_options = terminal_attach_options || " -htab"; end; else if a_option (idx) = "-runout_spacing" | a_option (idx) = "-runsp" then do; ad.runout_spacing = max (0, min (cv_dec_arg (idx), 32)); /* set the value within the range */ my_options = my_options || " -runsp " || a_option (idx); end; else if a_option (idx) = "-terminal" then do; ad.terminal = get_arg (idx); my_options = my_options || " -terminal " || ad.terminal; end; else terminal_attach_options = terminal_attach_options || space || a_option (idx); end; /* Check out the options we were given */ if ad.terminal = "" then do; code = error_table_$bad_arg; call abort_attach (code, "No terminal IO module specified.", ""); end; if ad.phys_line_length < 1 | ad.phys_line_length > 256 then do; code = error_table_$bad_arg; call abort_attach (code, "Invalid line length specified.", ""); end; if ad.phys_page_length < 10 | ad.phys_page_length > 128 then do; code = error_table_$bad_arg; call abort_attach (code, "Invalid page length specified.", ""); end; if device_opt ^= "teleprinter" then do; /* was it changed? */ code = error_table_$bad_arg; call abort_attach (code, "Invalid -device option: ^a", (device_opt)); end; /* Attach through terminal dim */ attach_count = attach_count + 1; /* new attach name tag number each time */ if attach_count > 999 then attach_count = 1; terminal_switch_name = remote_device_name || ltrim (char (attach_count)); /* make the switch name */ terminal_attach_options = ltrim (terminal_attach_options) || " -device " || device_opt; terminal_attach_desc = ad.terminal || space || terminal_attach_options; ad.attach_desc = remote_device_name || my_options || space || terminal_attach_options; call iox_$attach_ioname ((terminal_switch_name), temp_iocbp, (terminal_attach_desc), code); if code ^= 0 then call abort_attach (code, "Unable to attach to terminal ", ""); ad.terminal_iocbp = temp_iocbp; /* Now mask and complete the iocb */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc); iocbp -> iocb.attach_data_ptr = adp; iocbp -> iocb.open = remote_teleprinter_open; iocbp -> iocb.detach_iocb = remote_teleprinter_detach; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; call remote_printer_control_ (iocbp, "reset", null, code); if code ^= 0 then call abort_attach (code, "Unable to reset printer data", ""); call remote_printer_modes_ (iocbp, "noskip.", "", code); if code ^= 0 then call abort_attach (code, "Unable to set default modes", ""); attach_return: return; /* */ remote_teleprinter_detach: entry (a_iocbp, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; code = error_table_$not_closed; return; end; call clean_up; /* detach terminal, free attach data, clear the iocb */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; /* */ remote_teleprinter_open: entry (a_iocbp, a_mode, a_sw, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; code = error_table_$not_closed; return; end; open_mode = a_mode; if open_mode ^= Stream_input_output then do; a_code = error_table_$bad_mode; return; end; call iox_$open (ad.terminal_iocbp, Sequential_input_output, "0"b, a_code); if a_code = 0 then do; ad.record_io = "1"b; /* we have record interface approval */ call hcs_$make_ptr (null, "remote_conv_", "teleprinter", ad.cv_proc, a_code); if a_code ^= 0 then return; end; else do; ad.record_io = "0"b; /* try for stream interface */ call iox_$open (ad.terminal_iocbp, Stream_input_output, "0"b, a_code); if a_code ^= 0 then return; call hcs_$make_ptr (null, ad.terminal || "conv_", "teleprinter", ad.cv_proc, a_code); if a_code ^= 0 then return; end; ad.open_description = rtrim (iox_modes (open_mode)); mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.get_chars = remote_teleprinter_get_chars; iocbp -> iocb.get_line = remote_teleprinter_get_chars; iocbp -> iocb.put_chars = remote_teleprinter_put_chars; iocbp -> iocb.control = remote_teleprinter_control; iocbp -> iocb.modes = remote_teleprinter_modes; iocbp -> iocb.position = remote_teleprinter_position; iocbp -> iocb.close = remote_teleprinter_close; iocbp -> iocb.open_descrip_ptr = addr (ad.open_description); call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; /* */ remote_teleprinter_close: entry (a_iocbp, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; code = error_table_$not_open; return; end; call iox_$close (ad.terminal_iocbp, a_code); if a_code = error_table_$not_open | a_code = error_table_$not_attached then a_code = 0; /* make it easy to re-synch the attachments */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.open_descrip_ptr = null; iocbp -> iocb.open = remote_teleprinter_open; iocbp -> iocb.detach_iocb = remote_teleprinter_detach; iocbp -> iocb.control = iox_$err_no_operation; iocbp -> iocb.position = iox_$err_no_operation; iocbp -> iocb.modes = iox_$err_no_operation; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; /* */ remote_teleprinter_put_chars: entry (a_iocbp, a_data_ptr, a_data_chars, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; code, a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; code = error_table_$not_open; return; end; if a_data_chars < 0 | a_data_chars > sys_info$max_seg_size * 4 then do; a_code = error_table_$bad_arg; return; end; terminal_io_record_ptr = null (); /* for the cleanup handler */ call iox_$control (ad.terminal_iocbp, "select_device", addr (teleprinter), code); /* HACK FOR THE ibm2780_ TERMINAL */ if code ^= 0 then goto put_chars_ret; put_chars_since_last_runout = "1"b; pcip = addr (ad.remote_pci); /* get ptr to pci structure */ remaining_chars = a_data_chars; /* This is decremented as data is sent */ charp = a_data_ptr; terminal_io_record_element_size = 9; /* always character data */ terminal_io_record_n_elements = 3 * ad.phys_line_length; /* enough room for 1 printing character and 2 non-printing characters per column (eg: DC1-u X) */ on cleanup begin; if terminal_io_record_ptr ^= null () then free terminal_io_record_ptr -> terminal_io_record in (my_area); end; call alloc_tio_rec; /* allocate and initialize the terminal_io_record */ if ad.record_io then prt_conv_outp = terminal_io_record_ptr; /* full record for record interface */ else prt_conv_outp = addr (terminal_io_record.data); /* use the string for stream interface */ do while (remaining_chars > 0 | pci.slew_residue > 0); /* runout chars and trailing NLs */ pci.line = 1; /* fool prt_conv_ and say this is always line one */ /* we are assuming noskip mode and want to suppress */ /* the FF used to align each physical page */ call prt_conv_ (charp, remaining_chars, prt_conv_outp, record_len, pcip); if ad.record_io then do; call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr, 4 * currentsize (terminal_io_record), code); end; else do; /* stream output */ call iox_$put_chars (ad.terminal_iocbp, prt_conv_outp, record_len, code); end; if code ^= 0 then goto put_chars_ret; end; call iox_$control (ad.terminal_iocbp, "runout", null, code); /* make the terminal IO Module ship the message */ put_chars_ret: if terminal_io_record_ptr ^= null () then free terminal_io_record_ptr -> terminal_io_record in (my_area); a_code = code; return; /* */ /* Get_chars and Get_line entry points */ remote_teleprinter_get_chars: entry (a_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; code = error_table_$not_open; return; end; a_data_chars = 0; /* clear the return values */ code, a_code = 0; terminal_io_record_ptr = null; /* for the cleanup handler */ terminal_io_record_element_size = 9; /* always character data */ terminal_io_record_n_elements = a_buf_chars; /* allow for max buffer size */ on cleanup begin; if terminal_io_record_ptr ^= null then free terminal_io_record_ptr -> terminal_io_record in (my_area); end; call alloc_tio_rec; /* allocate and initialize terminal_io_record */ if ad.record_io then do; call iox_$read_record (ad.terminal_iocbp, terminal_io_record_ptr, 4 * size (terminal_io_record), record_len, code); if code = error_table_$eof_record then code = 0; if code ^= 0 then go to get_chars_ret; if terminal_io_record.version ^= terminal_io_record_version_1 then do; code = error_table_$unimplemented_version; go to get_chars_ret; end; /* assume that the data string doesn't have any slew specified (ignore any that was sent) */ end; else do; call iox_$get_chars (ad.terminal_iocbp, addr (terminal_io_record.data), (a_buf_chars), record_len, code); if code = error_table_$eof_record then code = 0; if code ^= 0 then go to get_chars_ret; terminal_io_record.n_elements = record_len; /* make a legal varying string */ end; /* at this point, we must have a record of the form: */ /* where the slew chars are missing - hopefully - for the teleprinter */ /* use card_util_ to do escape processing and adding NL if desired */ terminal_io_record_data_chars_varying_max_len = Card_Util_Char_Max; call card_util_$translate (ad.input_modes, terminal_io_record_data_chars_varying); /* can only shorten the string */ data_chars = terminal_io_record.n_elements; /* get the updated count */ if data_chars > a_buf_chars then code = error_table_$data_loss; /* tell caller we truncated the record */ a_data_chars = min (a_buf_chars, data_chars); substr (a_buf_ptr -> char_string, 1, a_data_chars) = substr (terminal_io_record_data_chars, 1, a_data_chars); get_chars_ret: free terminal_io_record_ptr -> terminal_io_record in (my_area); revert cleanup; a_code = code; return; /* */ remote_teleprinter_control: entry (a_iocbp, a_order, a_infop, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; code = error_table_$not_open; return; end; infop = a_infop; order = a_order; code, ec, a_code = 0; if order = "runout_spacing" then do; if infop = null then do; code = error_table_$bad_arg; go to control_ret; end; ad.runout_spacing = max (0, min (infop -> info_fixed, 32)); end; else if order = "end_write_mode" then go to do_control; /* CHECK THIS OUT */ else if order = "runout" then do; if ^put_chars_since_last_runout then return; /* ignore multiple runouts per switch */ put_chars_since_last_runout = "0"b; if ad.runout_spacing = 0 then go to do_control; /* for another common case */ nl_string = copy (NL, ad.runout_spacing); /* get the right number of new lines */ call iox_$put_chars (iocbp, addr (nl_string), ad.runout_spacing, ignore); /* let the normal entry do the work */ goto do_control; end; else if order = "io_call" then call remote_teleprinter_io_call; else do; call remote_printer_control_ (iocbp, order, infop, ec); if ec ^= 0 then do; do_control: call iox_$control (ad.terminal_iocbp, order, infop, code); if code ^= 0 & ec ^= 0 then code = ec; /* use first code if this fails */ end; if order = "reset" then call iox_$control (ad.terminal_iocbp, order, null, 0); end; control_ret: a_code = code; return; /* */ remote_teleprinter_modes: entry (a_iocbp, a_new_modes, a_old_modes, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; code, a_code = 0; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; code = error_table_$not_open; return; end; prt_modes, card_modes = ""; /* get ready to pickup old modes */ call remote_printer_modes_ (iocbp, a_new_modes, prt_modes, prt_code); call card_util_$modes (a_new_modes, ad.input_modes, card_modes, card_code); if prt_code = 0 | card_code = 0 then a_code = 0; /* say OK if one was good */ else a_code = prt_code; if a_new_modes = "default" then do; call iox_$modes (ad.terminal_iocbp, a_new_modes, "", 0); end; else if index (a_new_modes, "non_edited") ^= 0 then do; i = index (a_new_modes, "non_edited"); if i = 1 then call iox_$modes (ad.terminal_iocbp, "non_edited", "", 0); else if substr (a_new_modes, i - 1, 1) = "^" then call iox_$modes (ad.terminal_iocbp, "default", "", 0); else call iox_$modes (ad.terminal_iocbp, "non_edited", "", 0); end; last_pos = length (rtrim (prt_modes)); /* check last char so we give a good mode string */ last_char = substr (prt_modes, last_pos, 1); if last_char = "," | last_char = "." then last_pos = last_pos - 1; /* we'll put it back */ a_old_modes = rtrim (substr (prt_modes, 1, last_pos) || "," || card_modes); /* put it all together */ return; /* */ remote_teleprinter_position: entry (a_iocbp, a_pos_type, a_pos_value, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; code, a_code = 0; if adp = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; code = error_table_$not_open; return; end; call iox_$position (ad.terminal_iocbp, a_pos_type, a_pos_value, a_code); return; flip_com_err_sw: entry (); static_comerr_sw = ^static_comerr_sw; /* flip the bit */ call ioa_ ("The teleprinter com err sw is now: ^[on^;off^]", static_comerr_sw); return; /* */ get_arg: procedure (idx) returns (character (*)); dcl idx fixed bin; idx = idx + 1; /* advance the index of the major loop */ if idx > hbound (a_option, 1) then do; code = error_table_$noarg; call abort_attach (code, "No argument after ^a.", (a_option (idx - 1))); end; return (a_option (idx)); end get_arg; cv_dec_arg: procedure (idx) returns (fixed binary); dcl idx fixed bin; idx = idx + 1; /* advance the index of the major loop */ if idx > hbound (a_option, 1) then do; code = error_table_$noarg; call abort_attach (code, "No argument after ^a.", (a_option (idx - 1))); end; on conversion go to bad_dec_arg; return (bin (a_option (idx))); bad_dec_arg: code = error_table_$bad_conversion; call abort_attach (code, "Invalid decimal number. ^a", (a_option (idx))); end cv_dec_arg; abort_attach: procedure (code, str1, str2); dcl code fixed bin (35); dcl (str1, str2) char (*) aligned; /* This proc handles attach errors */ if com_err_sw then call com_err_ (code, remote_device_name, str1, str2); a_code = code; /* we were called because code ^= 0 */ call clean_up; go to attach_return; /* do a direct non-local return */ end abort_attach; /* */ alloc_tio_rec: procedure (); allocate terminal_io_record in (my_area) set (terminal_io_record_ptr); unspec (terminal_io_record) = "0"b; /* clear everything */ terminal_io_record.version = terminal_io_record_version_1; /* our view of the record structure */ terminal_io_record.device_type = ad.device_type; terminal_io_record.element_size = terminal_io_record_element_size; /* set by our caller */ return; end alloc_tio_rec; clean_up: procedure (); /* this is for any form of abort during attachment */ if adp ^= null then do; if ad.terminal_iocbp ^= null then call iox_$detach_iocb (ad.terminal_iocbp, ignore); free adp -> ad in (my_area); adp = null; end; iocbp -> iocb.attach_descrip_ptr = null; /* be sure iox_ knows */ iocbp -> iocb.attach_data_ptr = null; iocbp -> iocb.open = iox_$err_no_operation; return; end clean_up; handler: procedure (); /* This proc handles faults that occur while masked */ if mask then /* were we saving any mask bits? */ call hcs_$reset_ips_mask (mask, mask); mask = ""b; call continue_to_signal_ (ignore); return; end handler; /* */ /* Handles the io_call orders by mapping them into control order calls to this dim */ remote_teleprinter_io_call: procedure (); if infop = null then do; code = error_table_$bad_arg; return; end; io_call_infop = infop; order = io_call_info.order_name; if io_call_info.nargs > 0 then do; arg = io_call_info.args (1); argp = addr (arg); end; else argp = null; if order = "runout_spacing" then do; on conversion goto io_call_err; runout_spacing_cnt = convert (runout_spacing_cnt, io_call_info.args (1)); call iox_$control (iocbp, order, addr (runout_spacing_cnt), code); end; else call iox_$control (iocbp, order, argp, code); return; io_call_err: code = error_table_$bad_conversion; return; end remote_teleprinter_io_call; /* */ %include remote_attach_data; %page; %include prt_conv_info; %page; %include prt_info; %page; %include iocb; %page; %include iox_modes; %page; %include io_call_info; %page; %include terminal_io_record; end remote_teleprinter_;  tty_printer_.pl1 11/15/82 1900.8rew 11/15/82 1523.5 248238 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */ tty_printer_: procedure; /* tty_printer_: An I/O module for communicating with tty_ or syn_ from any remote_XXX_ I/O module */ /* Coded 4/79 by J. C. Whitmore */ /* Modified October 1981 by C. Hornig to not call dial_manager_. */ /* Parameters */ dcl a_iocbp ptr; dcl a_option (*) char (*) var; /* Options for attach */ dcl a_sw bit (1); /* com_err_ switch for attach */ dcl a_code fixed bin (35); dcl a_mode fixed bin; /* The open mode */ dcl a_buf_ptr ptr; dcl a_data_ptr ptr; dcl a_buf_chars fixed bin (21); dcl a_data_chars fixed bin (21); dcl a_pos_type fixed bin; dcl a_pos_value fixed bin (21); dcl a_order char (*); dcl a_infop ptr; dcl a_new_modes char (*); dcl a_old_modes char (*); /* Automatic */ dcl com_err_sw bit (1); /* Set if com_err_ sould be called on attach error */ dcl attach_tag picture "99"; dcl code fixed bin (35); dcl iocbp ptr; dcl mask bit (36) aligned; /* For setting ips mask */ dcl i fixed bin (21); dcl open_mode fixed bin; dcl modes char (64); /* for setting initial modes or "reset" control */ dcl old_modes char (256); dcl order char (32); dcl infop ptr; dcl temp_ptr ptr; /* for the repeat loop chain search */ dcl term_type char (32); dcl my_attach_options char (256) var; dcl next_attach_options char (256) var; dcl next_attach_desc char (256) var; dcl next_module char (32) var; dcl target_device char (32) var; /* Internal static */ dcl attach_count fixed bin init (0) int static; dcl first_dibp ptr int static init (null); /* pointer to first device info block in chain */ dcl last_dibp ptr int static init (null); /* pointer to the tail of the info block chain */ dcl areap ptr int static init (null); /* pointer to our area segment */ dcl static_com_err_sw bit (1) int static init ("0"b); /* for testing only */ /* Based variables */ dcl my_area area (262144) based (areap); dcl info_fixed fixed bin based (infop); /* fixed bin control argument */ /* Constants */ dcl my_device_name char (12) int static options (constant) init ("tty_printer_"); dcl space char (1) static int init (" ") options (constant); dcl error_table_$bad_conversion fixed bin (35) ext; dcl error_table_$no_operation fixed bin (35) ext; dcl error_table_$bad_mode ext fixed bin (35); dcl error_table_$not_detached ext fixed bin (35); dcl error_table_$not_attached ext fixed bin (35); dcl error_table_$not_open ext fixed bin (35); dcl error_table_$not_closed ext fixed bin (35); dcl error_table_$wrong_no_of_args ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); /* External stuff */ dcl ( ioa_, ioa_$rsnnl ) entry options (variable); dcl com_err_ entry options (variable); dcl continue_to_signal_ entry (fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl convert_ipc_code_ entry (fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$err_no_operation entry; dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$propagate entry (ptr); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* External Variables */ dcl tty_printer_conv_$send_vt fixed bin ext; dcl tty_printer_conv_$send_ht fixed bin ext; /* Internal PL/I Stuff */ dcl (addr, bin, codeptr, hbound, null, rtrim, empty, unspec, max, fixed) builtin; dcl conversion condition; dcl any_other condition; dcl cleanup condition; %page; dcl adp ptr; /* local copy of pointer to attach data */ dcl 1 ad aligned based (adp), 2 fixed, 3 phys_line_length fixed bin, 2 bits unal, 3 ht bit (1), /* on if caller wants to send tabs */ 3 vt bit (1), /* on if caller wants to send VT chars */ 2 ptrs, 3 dibp ptr, /* device info block pointer for this attachment */ 3 iocbp ptr, /* for easy debugging, ptr back to our iocb */ 2 chars, 3 device_type char (32), /* device type using this switch (e.g. printer, teleprinter) */ 3 term_type char (32), /* the -ttp option for this attachment */ 3 attach_desc char (256) var, /* how this switch was attached */ 3 open_description char (24) var; /* and how it was opened */ dcl dibp ptr; /* pointer to device info block */ dcl 1 dib aligned based (dibp), /* device info block for per target device data */ 2 term_type, /* info for the set_term_type control order */ 3 version fixed bin, /* version if this structure (=1) */ 3 name char (32) unal, /* terminal type name */ 3 flags, 4 initial_string bit (1) unal, /* TRUE - if initial string should be sent (tab set) */ 4 modes bit (1) unal, /* TRUE - if default initial modes are to be set */ 4 ignore_line_type bit (1) unal, /* always FALSE for us, we want the cross check */ 4 MBZ bit (33) unal, /* Must Be Zero */ 2 device char (32), /* name of the target device or switch */ 2 module char (32), /* name of the next IO module */ 2 output_switch char (32) unaligned, /* what we are attached to (sw name) */ 2 next_iocbp ptr, /* iocb ptr for output_switch */ 2 fwd_ptr ptr, /* forward pointer in chain of info blocks */ 2 back_ptr ptr, /* backwards pointer to previous block */ 2 wait_list, /* list for ipc_$block, must start on even word */ 3 n_chan fixed bin, /* number of channels in list (Must Be 1) */ 3 wait_pad fixed bin, 3 channel fixed bin (71), /* IPC channel to get wakeup */ 2 flags, 3 attached bit (1) unal, /* device is ready to be opened */ 3 open bit (1) unal, /* device is ready to do I/O */ 2 n_attached fixed bin, /* number of switches attached to this device */ 2 max_line_length fixed bin; /* the longest phys_line_length requested */ dcl 1 event_info aligned like event_wait_info; dcl 1 write_info aligned, 2 channel fixed bin (71), 2 write_pending bit (1); %page; /* Attach entry point */ tty_printer_attach: entry (a_iocbp, a_option, a_sw, a_code); iocbp = a_iocbp; com_err_sw = a_sw; code, a_code = 0; adp, dibp = null; /* these will be checked by abort_attach */ if iocbp -> iocb.attach_descrip_ptr ^= null then do; code = error_table_$not_detached; call abort_attach ("^a", iocbp -> iocb.name); end; if areap = null then do; /* make an area once per process */ call get_temp_segment_ (my_device_name, areap, code); if code ^= 0 then call abort_attach ("Unable to allocate temp segment.", ""); my_area = empty (); /* initialize the area */ end; on cleanup call clean_up; /* save the area, please */ allocate ad in (my_area) set (adp); /* make an attach data structure allocation */ /* Initialize variables */ ad.bits = "0"b; ad.ptrs = null; ad.chars = ""; ad.phys_line_length = 0; ad.iocbp = iocbp; /* so we can find the IOCB for debugging */ next_attach_desc, next_attach_options = ""; target_device, next_module, term_type = ""; my_attach_options = ""; /* Are there enough attach options specified? */ if hbound (a_option, 1) < 4 then do; /* Must be at least -tty XX and -comm YY */ code = error_table_$wrong_no_of_args; call abort_attach ("Bad attach description.", ""); end; %page; /* Process options */ do i = 1 to hbound (a_option, 1); if a_option (i) ^= "-comm" then my_attach_options = my_attach_options || space || a_option (i); if /* case */ a_option (i) = "-terminal_type" | a_option (i) = "-ttp" then do; term_type = get_arg (); end; else if a_option (i) = "-physical_line_length" | a_option (i) = "-pll" then ad.phys_line_length = cv_dec_arg (); else if a_option (i) = "-horizontal_tab" | a_option (i) = "-htab" then ad.ht = "1"b; else if a_option (i) = "-vtab" then ad.vt = "1"b; else if a_option (i) = "-device" then ad.device_type = get_arg (); else if a_option (i) = "-auto_call" then next_attach_options = next_attach_options || " -destination " || get_arg (); else if a_option (i) = "-tty" then target_device = get_arg (); else if a_option (i) = "-comm" then do; i = i + 1; if i > hbound (a_option, 1) then goto no_arg; next_module = a_option (i); end; else next_attach_options = next_attach_options || space || a_option (i); end; if target_device = "" then do; code = error_table_$badopt; call abort_attach ("No ""-tty"" option given.", ""); end; if next_module = "" then do; code = error_table_$badopt; call abort_attach ("No ""-comm"" option given.", ""); end; /* find a device info block for the target device */ do temp_ptr = first_dibp repeat (temp_ptr -> dib.fwd_ptr) while (temp_ptr ^= null & dibp = null); if temp_ptr -> dib.device = target_device then /* previously defined? */ dibp = temp_ptr; end; if dibp = null then do; /* first for this device */ call make_dib (dibp); /* create a device info block for the target device */ dib.device = target_device; dib.module = next_module; dib.term_type.name = term_type; /* ready to give set_term_type control */ dib.term_type.initial_string = "1"b; /* send the initial tab string if it exists */ dib.term_type.modes = "1"b; /* we always want the default modes set */ end; ad.dibp = dibp; /* point this back to its device info block */ ad.term_type = term_type; /* record the -ttp option */ /* Before attaching, finish the attach data by checking for default values of optional attach options */ if ad.device_type = "" then ad.device_type = "teleprinter"; /* the default */ if ad.phys_line_length = 0 then /* if not given */ if ad.device_type = "printer" then ad.phys_line_length = 136; else ad.phys_line_length = 118; /* for a terminet */ ad.attach_desc = my_device_name || space || next_module || space || my_attach_options; /* If we need to attach, attach through next_module to target_device (which may be a switch) */ if ^dib.attached then do; /* just once per target device */ attach_count = attach_count + 1; attach_tag = attach_count; dib.output_switch = my_device_name || attach_tag; /* make up a new switch name for the next level */ next_attach_desc = next_module || space || target_device || space || next_attach_options; call iox_$attach_name (dib.output_switch, dib.next_iocbp, (next_attach_desc), codeptr (tty_printer_attach), code); if code ^= 0 then call abort_attach ("Unable to attach to target device/switch", ""); dib.attached = "1"b; /* we have a new attachment */ dib.open = "0"b; /* don't forget to open it */ end; /* Set up the target device modes via the next IO module */ if ^dib.open then do; /* if not open, do it */ call iox_$open (dib.next_iocbp, Stream_input_output, "0"b, code); if code ^= 0 then /* OOPS */ if code ^= error_table_$not_closed then /* if open, let it go */ call abort_attach ("Unable to open target device stream.", ""); if dib.term_type.name ^= "" then do; /* set the terminal type if specified */ call iox_$control (dib.next_iocbp, "set_term_type", addr (dib.term_type), code); if code ^= 0 then call abort_attach ("Unable to set terminal type.", ""); end; call iox_$control (dib.next_iocbp, "quit_enable", null, (0)); call iox_$control (dib.next_iocbp, "write_status", addr (write_info), code); if code = 0 then do; /* if OK, set up wait list for runout control */ dib.n_chan = 1; dib.channel = write_info.channel; end; else do; /* can't block for output completion */ code = 0; /* this is OK */ dib.wait_list = 0; /* clear the list */ end; tty_printer_conv_$send_ht = fixed (ad.ht); tty_printer_conv_$send_vt = fixed (ad.vt); dib.open = "1"b; end; dib.max_line_length = max (dib.max_line_length, ad.phys_line_length); call ioa_$rsnnl ("^^edited^[,vertsp^],ll^d^[,tabs^]", modes, i, ad.vt, dib.max_line_length, ad.ht); old_modes = ""; call iox_$modes (dib.next_iocbp, modes, old_modes, code); /* don't abort now, just try the set up */ if code ^= 0 & (com_err_sw | static_com_err_sw) then call com_err_ (code, my_device_name, "Modes error: ^a From: ^a", rtrim (modes), rtrim (old_modes)); /* Mask and complete the iocb */ mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc); iocbp -> iocb.attach_data_ptr = adp; iocbp -> iocb.open = tty_printer_open; iocbp -> iocb.detach_iocb = tty_printer_detach; dib.n_attached = dib.n_attached + 1; /* bump the number of switches to this device */ call iox_$propagate (iocbp); revert cleanup; /* it is good from here on */ call hcs_$reset_ips_mask (mask, mask); revert any_other; attach_return: return; no_arg: code = error_table_$noarg; call abort_attach ("No argument after ^a.", (a_option (i - 1))); %page; /* Detach entry point */ tty_printer_detach: entry (a_iocbp, a_code); iocbp = a_iocbp; a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if iocbp -> iocb.open_descrip_ptr ^= null then do;/* not closed? */ a_code = error_table_$not_closed; return; end; if adp ^= null then do; dibp = ad.dibp; /* find the device info block */ dib.n_attached = dib.n_attached - 1; /* this one is gone! */ if dib.n_attached < 1 then do; /* when the last, take the block and attachment too */ if dib.next_iocbp ^= null then do; call iox_$close (dib.next_iocbp, (0)); /* force the issue */ call iox_$detach_iocb (dib.next_iocbp, (0)); end; call delete_dib (dibp); end; iocbp -> iocb.attach_data_ptr = null; /* this is about to become invalid */ free adp -> ad in (my_area); /* drop the attach data structure for sure */ end; mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = null; iocbp -> iocb.open = iox_$err_no_operation; /* remaining invalid functions */ iocbp -> iocb.close = iox_$err_no_operation; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; %page; /* Open entry point */ tty_printer_open: entry (a_iocbp, a_mode, a_sw, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; a_code = 0; adp = iocbp -> iocb.attach_data_ptr; if iocbp -> iocb.open_descrip_ptr ^= null then do;/* already open? */ a_code = error_table_$not_closed; return; end; if adp = null then do; /* must be valid */ a_code = error_table_$not_attached; return; end; open_mode = a_mode; if ^((open_mode = Stream_input) | (open_mode = Stream_output) | (open_mode = Stream_input_output)) then do; bad_mode: a_code = error_table_$bad_mode; return; end; ad.open_description = rtrim (iox_modes (open_mode)); mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); if ((open_mode = Stream_input) | (open_mode = Stream_input_output)) then do; iocbp -> iocb.get_chars = tty_printer_get_chars; iocbp -> iocb.get_line = tty_printer_get_line; end; if ((open_mode = Stream_output) | (open_mode = Stream_input_output)) then do; iocbp -> iocb.put_chars = tty_printer_put_chars; end; iocbp -> iocb.control = tty_printer_control; iocbp -> iocb.position = tty_printer_position; iocbp -> iocb.modes = tty_printer_modes; iocbp -> iocb.close = tty_printer_close; iocbp -> iocb.detach_iocb = tty_printer_detach; iocbp -> iocb.open_descrip_ptr = addr (ad.open_description); call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; %page; /* Close entry point */ tty_printer_close: entry (a_iocbp, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; a_code = 0; if iocbp -> iocb.open_descrip_ptr = null then do; /* already closed? */ a_code = error_table_$not_open; return; end; mask = "0"b; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.open_descrip_ptr = null; iocbp -> iocb.open = tty_printer_open; iocbp -> iocb.detach_iocb = tty_printer_detach; iocbp -> iocb.control = iox_$err_no_operation; iocbp -> iocb.position = iox_$err_no_operation; iocbp -> iocb.modes = iox_$err_no_operation; iocbp -> iocb.put_chars = iox_$err_no_operation; iocbp -> iocb.get_chars = iox_$err_no_operation; iocbp -> iocb.get_line = iox_$err_no_operation; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; %page; /* Put_chars entry point */ tty_printer_put_chars: entry (a_iocbp, a_data_ptr, a_data_chars, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; /* must be valid */ a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */ a_code = error_table_$not_open; return; end; a_code = 0; dibp = ad.dibp; /* find the device info block */ call iox_$put_chars (dib.next_iocbp, a_data_ptr, a_data_chars, a_code); return; %page; /* Get_chars entry point */ tty_printer_get_chars: entry (a_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; /* must be valid */ a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */ a_code = error_table_$not_open; return; end; a_code = 0; dibp = ad.dibp; /* find the device info block */ call iox_$get_chars (dib.next_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code); return; /* Get_line entry point */ tty_printer_get_line: entry (a_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; /* must be valid */ a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */ a_code = error_table_$not_open; return; end; a_code = 0; dibp = ad.dibp; /* find the device info block */ call iox_$get_line (dib.next_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code); return; %page; /* Control entry point */ tty_printer_control: entry (a_iocbp, a_order, a_infop, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; /* must be valid */ a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */ a_code = error_table_$not_open; return; end; code, a_code = 0; dibp = ad.dibp; infop = a_infop; order = a_order; if order = "io_call" then do; /* we can use a simple mapping for this */ io_call_infop = infop; order = io_call_info.order_name; infop = null; /* can't have an info ptr with io_call */ end; if /* case */ order = "select_device" then do; if ad.term_type ^= dib.term_type.name then do; dib.term_type.name = ad.term_type; /* establish the other terminal type */ if dib.term_type.name ^= "" then /* set the terminal type if specified */ call iox_$control (dib.next_iocbp, "set_term_type", addr (dib.term_type), code); end; tty_printer_conv_$send_ht = fixed (ad.ht); tty_printer_conv_$send_vt = fixed (ad.vt); call ioa_$rsnnl ("^^edited^[,vertsp^],ll^d^[,tabs^]", modes, i, ad.vt, dib.max_line_length, ad.ht); call iox_$modes (dib.next_iocbp, modes, old_modes, (0)); /* don't abort now, just try the set up */ end; else if order = "runout" then do; /* here we wait for the output to complete */ if dib.n_chan = 0 then return; /* in case we can't block */ write_info.write_pending = "0"b; /* clear the flag */ call iox_$control (dib.next_iocbp, "write_status", addr (write_info), code); if write_info.write_pending then do; call ipc_$block (addr (dib.wait_list), addr (event_info), code); if code ^= 0 then call convert_ipc_code_ (code); end; end; else if order = "hangup" & dib.module = "syn_" then do; /* trap this order here */ /* so we don't hangup user_i/o */ end; else if order = "reset" then do; call ioa_$rsnnl ("^^edited^[,vertsp^],ll^d^[,tabs^]", modes, i, ad.vt, dib.max_line_length, ad.ht); call iox_$modes (dib.next_iocbp, modes, old_modes, (0)); /* don't abort now, just try the set up */ end; else if order = "get_error_count" then do; if infop = null then go to no_op; /* not for io_call or a bad ptr */ infop -> info_fixed = 0; /* return a count of zero for now */ end; else do; call iox_$control (dib.next_iocbp, a_order, a_infop, code); end; a_code = code; return; no_op: a_code = error_table_$no_operation; /* it couldn't be done as called */ return; %page; /* Position entry point */ tty_printer_position: entry (a_iocbp, a_pos_type, a_pos_value, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; /* must be valid */ a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */ a_code = error_table_$not_open; return; end; a_code = 0; dibp = ad.dibp; /* find the device info block */ call iox_$position (dib.next_iocbp, a_pos_type, a_pos_value, a_code); return; %page; tty_printer_modes: entry (a_iocbp, a_new_modes, a_old_modes, a_code); iocbp = a_iocbp -> iocb.actual_iocb_ptr; adp = iocbp -> iocb.attach_data_ptr; if adp = null then do; /* must be valid */ a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */ a_code = error_table_$not_open; return; end; a_code = 0; dibp = ad.dibp; /* find the device info block */ call iox_$modes (dib.next_iocbp, a_new_modes, a_old_modes, a_code); return; %page; cv_dec_arg: proc returns (fixed bin); /* This proc picks up the next arg in the attach option array and returns it as fixed bin */ i = i + 1; /* Advance to next arg */ if i > hbound (a_option, 1) then goto no_arg; my_attach_options = my_attach_options || space || a_option (i); on conversion go to bad_dec_arg; return (bin ((a_option (i)))); bad_dec_arg: code = error_table_$bad_conversion; call abort_attach ("Invalid decimal number. ^a", ((a_option (i)))); end cv_dec_arg; get_arg: proc returns (char (*) var); /* This proc picks up the next arg in the attach option array and returns it as a character string */ i = i + 1; if i > hbound (a_option, 1) then goto no_arg; my_attach_options = my_attach_options || space || a_option (i); return ((a_option (i))); end get_arg; %page; make_dib: proc (new_dibp); dcl new_dibp ptr; /* pointer to new info block in chain (output) */ allocate dib in (my_area) set (new_dibp); unspec (new_dibp -> dib) = "0"b; /* set it all to zero */ new_dibp -> dib.fwd_ptr = null; /* chain ends here */ new_dibp -> dib.device = ""; /* for string compares */ new_dibp -> dib.module = ""; new_dibp -> dib.output_switch = ""; new_dibp -> dib.back_ptr = last_dibp; /* if the first, this is null */ new_dibp -> dib.next_iocbp = null; new_dibp -> dib.term_type.version = 1; /* be sure we give the right version */ new_dibp -> dib.term_type.name = ""; /* not defined yet */ if first_dibp = null then first_dibp = new_dibp; /* set the head of the chain */ else last_dibp -> dib.fwd_ptr = new_dibp; /* otherwise, link it into the list */ last_dibp = new_dibp; /* record the new end of of the chain */ end make_dib; delete_dib: proc (dibp); dcl dibp ptr; /* pointer to the info block to be deleted */ if dibp -> dib.back_ptr = null then /* it was the head of the chain */ first_dibp = dibp -> dib.fwd_ptr; else dibp -> dib.back_ptr -> dib.fwd_ptr = dibp -> dib.fwd_ptr; /* move our fwd ptr to previous block */ if dibp -> dib.fwd_ptr = null then /* if the tail of the chain */ last_dibp = dibp -> dib.back_ptr; else dibp -> dib.fwd_ptr -> dib.back_ptr = dibp -> dib.back_ptr; /* move our back ptr to next block */ free dibp -> dib in (my_area); dibp = null; return; end delete_dib; %page; abort_attach: proc (str1, str2); dcl (str1, str2) char (*) aligned; /* This proc handles attach errors */ if com_err_sw | static_com_err_sw then call com_err_ (code, my_device_name, str1, str2); a_code = code; call clean_up; /* free things up */ go to attach_return; end abort_attach; clean_up: procedure; /* clean up procedure for cleanup condition and abort_attach, kills the attempted attachment */ if adp ^= null then free adp -> ad in (my_area); if dibp ^= null then if dib.n_attached < 1 then do; if dib.next_iocbp ^= null then do; call iox_$close (dib.next_iocbp, (0)); /* just in case */ call iox_$detach_iocb (dib.next_iocbp, (0)); end; call delete_dib (dibp); /* drop it */ end; iocbp -> iocb.attach_descrip_ptr = null; iocbp -> iocb.attach_data_ptr = null; return; end clean_up; handler: procedure; /* This proc handles faults that occur while masked */ if mask then call hcs_$reset_ips_mask (mask, mask); mask = "0"b; call continue_to_signal_ (code); return; end handler; %page; flip_com_err_sw: entry; /* this entry is for testing so the state of the static com_err_sw can be changed */ static_com_err_sw = ^static_com_err_sw; call ioa_ ("The static switch is now ^[on^;off^].", static_com_err_sw); return; %page; %include iocb; %include iox_modes; %include io_call_info; %include event_wait_info; end tty_printer_;  tty_printer_conv_.alm 02/02/88 1702.2r w 02/02/88 1538.3 52155 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " tty_printer_conv_ - co-routine for prt_conv_ to be used " from the remote_teleprinter_ and remote_printer_ " IO modules when attaching through the tty_printer_ IO module. " " coded 4/79 by J. C. Whitmore (with print_conv_ and ibm2780_conv_ as guides) " include stack_header include prt_conv_info name tty_printer_conv_ segdef tty_printer_conv_ segdef teleprinter segdef printer even tempd saved_lp temp char,VTstop,residue,last_print,a_reg,temp1,temp2 tty_printer_conv_: teleprinter: printer: tra print_send_init tra print_send_chars tra print_send_slew_pattern tra print_send_slew_count " " Entry called at beginning of conversion print_send_init: stz last_print no print positions used yet ldq lb|pci.line get current line or end of slew sbq lb|pci.slew_residue calc actual line for this call sbq 1,dl .. cause VT stops are at 11 ... div 10,dl compute starting VT stop stq VTstop save tab stop of current line sta residue save number of lines from current tab stop tra sb|0 return " print_send_chars: " " Here we are to write out the number of chars given in "au" after " putting out the number of white spaces shown in X2. " We are starting from the char position defined by last_print " eax2 0,2 set indicators from X2 tmoz nospace if no white space, skip following sta a_reg save the printable char count sprilp saved_lp save the current lp epaq * get our seg no in au epbplp sp|0 find the stack base lprplp lp|stack_header.lot_ptr,*au get static ptr in lp ldq lp|send_ht see if we can send HT chars tmoz no_ht if not just use space chars ldq last_print look for current HT stop div 10,dl get starting HT stop in ql stq temp1 save this sta temp2 save positions after stop eaq 0,2 get space count in Q qrs 18 move to ql adq last_print get target position div 10,dl get total tabs to target sbq temp1 convert to relative tabs " spaces beyond last tab are in al tze no_ht if none, just use spaces mlr (),(pr,rl),fill(011) desc9a *,0 move nothing... desc9a bb|0,ql but fill with "ql" tabs a9bd bb|0,ql move output pointer past the tabs eax2 0,al put the remaining space count back in x2 lda 10,dl sba temp2 get spaces for first tab sta temp2 and save it sbq 1,dl take first tab from count mpy 10,dl get spaces for other tabs adq temp2 get total spaces asq last_print update the last position used no_ht: lda a_reg restore the original A register epp4 saved_lp,* restore the lp mlr (),(pr,rl),fill(040) insert blanks into output desc9a *,0 .. desc9a bb|0,x2 .. a9bd bb|0,2 step output pointer over blanks eaq 0,2 get the space count qrs 18 ..into ql asq last_print and update the last position used eax2 0 set white space count back to zero nospace: mlr (pr,rl),(pr,rl) copy characters into output desc9a bp|0,au .. desc9a bb|0,au .. a9bd bp|0,au step input and output pointers a9bd bb|0,au .. ars 18 move char count to al asa last_print and update the position count als 18 restore it, just in case tra sb|0 return to caller " print_send_slew_pattern: " " The A contains the pattern to search for 000 -> FF, 013 -> TOIP, 011 -> TOOP. " But, for tty_printer_conv_ we can only assume the device supports a FF and no " other patterns. So, always give a form feed for this entry. " lda ffchar sta char stslew: mlr (pr),(pr) move the slew char in "char" to output string desc9a char,1 .. desc9a bb|0,1 .. ldq 1,dl a9bd bb|0,ql move output pointer past the slew char tra sb|0 return to caller nlchar: vfd o9/012 crchar: vfd o9/015 vtchar: vfd o9/013 ffchar: vfd o9/014 " print_send_slew_count: " " When called at this entry, the count of the number of lines to slew " is in the A register (al). If the target device can accept VT chars " to get to the target line, we will try to send them instead of " writting out the slew count as NL chars. " cmpa 1,dl try to optomize for CR and NL alone tmoz no_vt sta a_reg save the slew count for later sprilp saved_lp save the current lp epaq * get our seg no in au epbplp sp|0 find the stack base lprplp lp|stack_header.lot_ptr,*au get static ptr in lp ldq lp|send_vt see if we can send VT chars at all tmoz send_nl if not send NL chars ldq lb|pci.line pickup target of slew sbq 1,dl correct for tabs at 11, 21,... div 10,dl get total VT stops in ql sbq VTstop reduce the total VT count by current VTstop tze send_nl if not passing a stop, send new_lines ldq vtchar put out one VT char for this call stq char save where stslew can find it ldq 10,dl max lines per stop to ql sbq residue compute number of lines slewed by VT stq temp1 .. epp4 saved_lp,* lda a_reg restore the original slew count sba temp1 reduce the slew count by lines slewed tra stslew let common code do the work send_nl: epp4 saved_lp,* restore the lp lda a_reg no_vt: ldq crchar sba 1,dl one at a time tmi 2,ic ldq nlchar stq char tra stslew " " EXTERNAL VARIABLES - to be set by the IO module to control " which slew characters can be put into the output string. " use internal_static join /link/internal_static segdef send_vt segdef send_ht send_vt: even vfd o36/0 if zero, don't output VT chars send_ht: vfd o36/0 if zero, don't output HT chars end bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved