cards_overseer_.pl1 03/27/85 1136.2r w 03/27/85 1132.0 155763 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ cards_overseer_: procedure options (separate_static); /* This is an overseer for the SysDaemon process whose sole responsibility is to read card decks for users. All it does is attach the card reader and call the read_cards_ subroutine. Its principal reason for existence is to prevent the card daemon from being used at command level. */ /* Modified February, 1975 by S. Vestal for security fix */ /* Modified August, 1975 by J. C. Whitmore for new card dim interface */ /* Modified April, 1976 by J. C. Whitmore to resetread after a quit */ /* Modified January, 1978 by DRV to fix bug in cleanup of test entry */ /* Modified January 1978 by J. C. Whitmore to request station id and use iox_ for input */ /* Modified 1984-08-17 by E. Swenson for version 2 PNTs. */ dcl com_err_ entry options (variable); dcl condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr); dcl continue_to_signal_ entry (fixed bin (35)); dcl cu_$arg_count entry () returns (fixed bin); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl debug entry; dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl get_at_entry_ entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl read_password_ entry (char (*), char (*)); dcl ioa_$ioa_stream entry options (variable); dcl ioa_$ioa_stream_nnl entry options (variable); dcl ioa_ entry options (variable); dcl ios_$attach entry (char (*) aligned, char (*), char (*), char (*), bit (72) aligned); dcl ( ios_$setsize, ios_$getsize ) entry (char (*) aligned, fixed bin, bit (72) aligned); dcl ios_$detach entry (char (*) aligned, char (*), char (*), bit (72) aligned); dcl ios_$resetread entry (char (*), bit (72) aligned); dcl iox_$user_input ext ptr; dcl iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl logout entry; dcl new_proc entry; dcl pool_manager_$init entry (char (*) aligned, fixed bin, bit (36) aligned, fixed bin (35)); dcl pool_manager_$clean_pool entry (char (*) aligned, fixed bin, fixed bin, fixed bin (35)); dcl read_cards_ entry (char (*) aligned, ptr, char (*), bit (1) aligned, fixed bin (35)); dcl read_cards_$set_station entry (char (*), fixed bin (35)); dcl scramble_ entry (char (8)) returns (char (8)); dcl standard_default_handler_ entry (ptr, char (*), ptr, ptr, bit (1) aligned); dcl validate_card_input_$station entry (char (*), char (*), char (*), fixed bin (35)); dcl (any_other, cput, alrm, finish, cleanup, resume) condition; dcl (addr, null, ltrim, substr) builtin; dcl answer char (80); dcl age fixed bin; dcl a_card_dim char (*); dcl a_card_device char (*); dcl card_device char (32) init ("rdra"); dcl card_dim char (32) init ("crz"); dcl code fixed bin (35); dcl dev char (32); dcl dim char (32); dcl stream_name char (32) aligned; dcl iocbp ptr; dcl i fixed bin; dcl ig char (4); dcl nchar fixed bin; dcl password char (32); dcl station char (32); dcl status bit (72) aligned; dcl error_msg char (132); /* for message from validate_card_input_ */ dcl root_dir char (168) aligned init ("System_Card_Pool"); /* dir into which we look for card_pool_root */ dcl temp_password char (8); /* temporary for password manipulation */ dcl test_sw bit (1) aligned int static init ("0"b); /* =1 if testing */ dcl user_mode bit (36) aligned int static init ("100"b || (33)"0"b) options (constant); dcl quit_flag bit (1) int static init ("0"b); dcl recursion_flag fixed bin int static init (0); dcl resume_label label int static; dcl error_table_$ionmat ext static fixed bin (35); dcl 1 stat aligned based (addr (status)), 2 word1 fixed bin (35), 2 iocode fixed bin (35); dcl 1 stream_info aligned like card_stream_info; /* allocate the structure for read_cards_ */ %include card_stream_info; /* Normal entry point */ go to start; /* test entry point */ test: entry (a_root_dir, a_card_dim, a_card_device); dcl a_root_dir char (*); /* input arg for system storage location */ if cu_$arg_count () ^= 3 then do; /* must have 3 args for this entry */ call ioa_ ( "cards_overseer_: USAGE: cards_overseer_$test card_pool_root_dir card_dim card_device"); return; end; test_sw = "1"b; /* testing in progress */ root_dir = a_root_dir; /* copy the root */ card_dim = a_card_dim; card_device = a_card_device; start: stream_info.n_streams = 0; /* no streams defined yet */ stream_info.name (*) = "undefined"; stream_info.format (*) = ""; stream_info.control_stream = "undefined"; /* set up a condition wall - we will handle all conditions */ on cleanup call clean_up; on any_other call cards_handler; /* for all other conditions */ resume_label = no_attach; quit_flag = "0"b; /* if using message coordinator, attach error_output stuff */ call get_at_entry_ ("user_i/o", dim, dev, ig, code); if dim = "mrd_" then do; call ios_$attach ("error_i/o", "mrd_", dev, "", status); call ios_$attach ("error_output", "syn", "error_i/o", "", status); end; iocbp = iox_$user_input; re_init: call ios_$attach ("card_in_stream", card_dim, card_device, "", status); if stat.word1 ^= 0 /* oh well */ then if stat.word1 ^= error_table_$ionmat /* let it ride if already attached */ then do; call com_err_ (stat.word1, "cards_overseer_", "^/Could not attach card reader on channel ^a.", card_device); call ioa_ ("Card Daemon: Enter new device channel or type ""quit""."); answer = ""; /* clear junk */ call iox_$get_line (iocbp, addr (answer), 80, nchar, code); if code ^= 0 then go to no_attach; card_device = substr (answer, 1, nchar - 1); /* assume a new channel */ if card_device ^= "quit" then go to re_init; /* try the new channel */ no_attach: call ioa_ ("Card Input Daemon cannot run."); go to exit; end; if test_sw then call ios_$setsize ("card_in_stream", 972, status); stream_info.control_stream = "mcc_card_input_"; /* we use this to read control cards */ stream_info.n_streams = 4; /* we will support 4 input formats */ stream_info.format (1) = "mcc"; /* first describe the MCC format stream */ stream_info.name (1) = "mcc_card_input_"; /* this is also the control stream */ stream_info.format (2) = "viipunch"; /* next we have the 7 punch format */ stream_info.name (2) = "viipunch_card_input_"; stream_info.format (3) = "raw"; /* next is the raw card format */ stream_info.name (3) = "raw_card_input_"; stream_info.format (4) = "rmcc"; /* last is rmcc for compatability with remote input */ stream_info.name (4) = "mcc_card_input_"; /* this is the same as mcc format */ /* now attach the format dims as we said above */ stream_name = "mcc_card_input_"; /* use a dummy variable for use in error msg */ call ios_$attach (stream_name, "mcc_", "card_in_stream", "", status); if stat.word1 ^= 0 then if stat.word1 ^= error_table_$ionmat then do; /* if attached, assume it is ok */ attach_err: call com_err_ (stat.word1, "cards_overseer_", "^/Unable to attach ^a stream.", stream_name); go to exit; /* at this point we quit */ end; stream_name = "viipunch_card_input_"; call ios_$attach (stream_name, "viipunch_", "card_in_stream", "", status); if stat.word1 ^= 0 then if stat.word1 ^= error_table_$ionmat then go to attach_err; /* if attached, assume it is ok */ stream_name = "raw_card_input_"; call ios_$attach (stream_name, "raw_", "card_in_stream", "", status); if stat.word1 ^= 0 then if stat.word1 ^= error_table_$ionmat then go to attach_err; /* if attached, assume it is ok */ do i = 1 to stream_info.n_streams; /* get the element size for each format stream */ call ios_$getsize (stream_info.name (i), stream_info.el_size (i), status); if stat.word1 ^= 0 then do; call com_err_ (stat.word1, "cards_overseer_", "^/Unable to get element size for ^a stream.", stream_info.name (i)); go to no_attach; /* give the bad news message */ end; end; call pool_manager_$init (root_dir, 10, user_mode, code); if code ^= 0 then do; call com_err_ (code, "cards_overseer_", "^/Could not initialize pool."); go to exit; end; /* ask the operator for the reader station and validate its password */ do i = 1 to 5; /* try five times at most */ station, password = ""; /* clear any junk */ call ioa_ ("Card Daemon: enter Station_id"); call iox_$get_line (iocbp, addr (station), 80, nchar, code); if code ^= 0 then go to no_attach; station = substr (station, 1, nchar - 1); call read_password_ ("Enter station password:", password); if password ^= "" then do; temp_password = password; password = scramble_ (temp_password); temp_password = ""; end; call validate_card_input_$station (station, password, error_msg, code); if code = 0 then go to set_station; /* all was well */ call ioa_ ("***: ^a", error_msg); end; call ioa_ ("Card Daemon cannot run."); go to exit; /* that's all folks */ set_station: call read_cards_$set_station (station, code); /* pass on the good station name */ call iox_$control (iocbp, "quit_enable", null, code); resume_label = ask; /* we are ready to come to command level after errors */ ask: recursion_flag = 0; /* we are at the base stack frame */ quit_flag = "0"b; call command_level; /* ask the operator what he wants to do */ call ios_$resetread ("card_in_stream", status); /* throw out any previous cards */ if stat.word1 ^= 0 then do; call com_err_ (stat.word1, "cards_overseer_", "^/Invalid resetread to card dim. Card Daemon cannot run."); go to exit; end; call read_cards_ (root_dir, addr (stream_info), "user_output", test_sw, code); if code ^= 0 then call com_err_ (code, "cards_overseer_"); go to ask; /* what do we do next? */ /* all done, detach reader and log out */ exit: call clean_up; /* detach the streams */ if test_sw then return; else call logout; /* ============================================================================================== */ clean_up: proc; dcl status bit (72) aligned; /* use some local variables */ dcl i fixed bin; do i = 1 to stream_info.n_streams; /* detach the format streams */ call ios_$detach (stream_info.name (i), "", "", status); end; call ios_$detach ("card_in_stream", "", "", status); end clean_up; command_level: proc; /* This is the procedure that implements card daemon commands */ get_line: call ioa_ ("Card Daemon: Command?"); read_again: answer = ""; call iox_$get_line (iocbp, addr (answer), 80, nchar, code); if code ^= 0 then go to no_attach; answer = substr (answer, 1, nchar - 1); answer = ltrim (answer); if answer = "" then go to read_again; if answer = "." then go to get_line; if answer = "start" /* only valid after a quit */ then if quit_flag then return; else go to only_after_quit; if answer = "read_cards" then /* not valid after a quit */ if ^quit_flag then return; else do; call ioa_ ("The read_cards command is not valid while processing cards. Use start."); go to get_line; end; if answer = "reinit" then do; call clean_up; quit_flag = "0"b; go to re_init; end; if answer = "logout" then go to exit; if answer = "abort" then if quit_flag then do; quit_flag = "0"b; go to resume_label; end; else go to only_after_quit; if test_sw then if answer = "return" then go to exit; else if answer = "debug" then do; call ioa_ ("calling debug"); call debug; go to get_line; end; if answer = "clean_pool" then do; /* time for garbage collection */ call ioa_ ("Enter retention time in days (or 0 to abort):"); answer = ""; call iox_$get_line (iocbp, addr (answer), 80, nchar, code); if code ^= 0 then go to no_attach; answer = substr (answer, 1, nchar - 1); age = cv_dec_check_ ((answer), code); if code ^= 0 then do; call ioa_ ( "The allowed age of segments to remain in the pool must be a decimal number of days."); go to get_line; end; if age = 0 then go to get_line; if age < 1 then do; call ioa_ ("The retention time cannot be less than 1 day."); go to get_line; end; call pool_manager_$clean_pool (root_dir, age, 1, code); /* allow 1 page grace quota */ if code ^= 0 then call com_err_ (code, "cards_overseer_"); go to get_line; end; if answer = "help" then do; call ioa_ ("^/** Card Daemon Commands **^/"); call ioa_ ("read_cards - begin read operations"); call ioa_ ("start - continue after a quit"); call ioa_ ("logout - log out the Card Daemon"); call ioa_ ("clean_pool - garbage collect the card pool"); call ioa_ ("reinit - re-attach the card reader"); call ioa_ ("abort - halt current reading after a quit"); if test_sw then do; call ioa_ ("return"); call ioa_ ("debug"); end; go to get_line; end; call ioa_ ("Illegal command: ^a", answer); go to get_line; only_after_quit: call ioa_ ("The ^a command is only valid during interrupted card reading.", answer); go to get_line; end command_level; cards_handler: proc; /* Unclaimed signal handler. Will print default_error_handler-type message and ask if more * cards are to be read */ dcl mcptr ptr; dcl condition char (32); dcl coptr ptr; dcl info_ptr ptr; dcl 1 cond_info aligned, %include cond_info; dcl code fixed bin (35); cond_info.version = 1; /* set the version number for the subr */ call find_condition_info_ (null, addr (cond_info), code); condition = cond_info.condition_name; mcptr = cond_info.mcptr; coptr = cond_info.wcptr; info_ptr = cond_info.infoptr; if condition = "mme2" then if test_sw then do; call continue_to_signal_ (code); return; end; if condition = "finish" then do; /* now for the system conditions */ call_sdh: call standard_default_handler_ (mcptr, condition, coptr, infoptr, "0"b); return; end; if condition = "cput" then go to call_sdh; if condition = "alrm" then go to call_sdh; if condition = "command_question" then return; if condition = "command_error" then return; on cleanup quit_flag = "0"b; /* be sure this gets reset */ if condition = "card_command_level" then do; /* we want to go to command level */ quit_flag = "1"b; /* this allows different commands */ call ioa_ ("Use the ""clean_pool"" and ""start"" commands to continue."); call command_level; quit_flag = "0"b; /* reset what we did */ return; end; if condition = "quit" then do; /* we'll handle quits ourselves, else big trouble */ call ios_$resetread ("user_i/o", status); /* clear any input junk */ if quit_flag then do; /* avoid multiple quits */ call ioa_$ioa_stream ("error_output", "QUIT still in progress."); call iox_$control (iocbp, "start", null, code); return; end; call ioa_ ("QUIT"); quit_flag = "1"b; call command_level; /* see what operator wants */ quit_flag = "0"b; /* we are done */ call iox_$control (iocbp, "start", null, code); return; end; on resume go to return_label; if recursion_flag ^= 0 then do; /* compound unclaimed signals, can't handle */ call com_err_ (0, "cards_handler", "Condition ^a signalled while handling unclaimed signal. Process terminated.", condition); if test_sw then do; call ioa_ ("Calling debug"); call debug; return; end; call new_proc; end; recursion_flag = 1; call ioa_ ("Cards handler: condition ^a intercepted.", condition); call condition_interpreter_ (null, null, 0, 3, mcptr, condition, coptr, info_ptr); /* if we got a message, print it out */ if test_sw then do; call ioa_ ("Calling debug"); call debug; end; go to resume_label; return_label: recursion_flag = 0; /* reset the flag and ... */ return; /* then do a clean return */ end cards_handler; end cards_overseer_;  clean_card_pool.pl1 03/27/85 1136.2rew 03/27/85 1132.0 44568 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ clean_card_pool: proc; /* Originally written in Feb 1975 by Stan C. Vestal */ dcl age fixed bin; /* age of entries to delete */ dcl age_flag bit (1) aligned init ("0"b); /* on if -age specified */ dcl arglen fixed bin; /* length of an argument */ dcl argptr ptr init (null); /* pointer to argument */ dcl argstr char (arglen) based (argptr); /* argument overlay */ dcl card_dir char (168) aligned int static init ("System_Card_Pool"); /* path for the card pool root */ dcl code fixed bin (35); /* error return code */ dcl default_npages fixed bin; /* default grace_quota */ dcl entry char (15); /* entryname of the entry point called */ dcl grace_flag bit (1) aligned init ("0"b); /* on if -grace_quota specified */ dcl grace_quota fixed bin; /* quota to leave on undeleted pool dirs */ dcl i fixed bin; /* loop index */ dcl keyword char (168) aligned; /* pool name */ dcl nargs fixed bin; /* number of arguments called with */ dcl tape_dir char (168) aligned int static init ("System_Tape_Pool"); /* path for the tape pool root */ dcl (error_table_$wrong_no_of_args, error_table_$noarg, error_table_$bad_arg) ext fixed bin (35); dcl (substr, null) builtin; dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl pool_manager_$clean_pool entry (char (*) aligned, fixed bin, fixed bin, fixed bin (35)); dcl (com_err_, ioa_) entry options (variable); /* */ /* clean_card_pool entry point */ entry = "clean_card_pool"; /* for com_err_ calls */ keyword = card_dir; default_npages = 0; /* leave no spare pages for cards */ go to COMMON; /* clean_tape_pool entry */ clean_tape_pool: entry; entry = "clean_tape_pool"; keyword = tape_dir; default_npages = 50; /* more sharing in the tape pool */ /* Common processing */ COMMON: grace_quota = default_npages; /* assign the defaults in case user supplies no arguments */ age = -1; /* start with an illegal value to be sure it is set */ call cu_$arg_count (nargs); if nargs = 0 then go to PRINT_HELP; /* give the user some advice */ if nargs ^= 2 & nargs ^= 4 then do; /* arguments must be in pairs */ code = error_table_$wrong_no_of_args; go to ERROR; end; do i = 1 to nargs; /* process the arguments */ call cu_$arg_ptr (i, argptr, arglen, code); if code ^= 0 then go to ERROR; if age_flag then do; /* already seen the -age argument */ age_flag = "0"b; age = cv_dec_check_ (argstr, code); /* this argument must be ndays */ if code ^= 0 | age < 0 then go to arg_err; go to end_arg_loop; end; if grace_flag then do; /* already seen the -grace_quota argument */ grace_flag = "0"b; grace_quota = cv_dec_check_ (argstr, code); if code ^= 0 | grace_quota < 0 then go to arg_err; go to end_arg_loop; end; if argstr = "-age" then do; /* -age found */ age_flag = "1"b; go to end_arg_loop; end; if argstr = "-quota" then do; grace_flag = "1"b; /* -quota found */ go to end_arg_loop; end; arg_err: code = error_table_$bad_arg; /* unknown argument */ call com_err_ (code, entry, "^a", substr (argstr, 1, arglen)); return; end_arg_loop: end; if age < 0 then do; /* true if age arg was not given */ call com_err_ (error_table_$noarg, entry, "The ""-age N"" control arg must be given."); return; end; code = 0; /* initialize the return code */ call pool_manager_$clean_pool (keyword, age, grace_quota, code); ERROR: if code ^= 0 then do; call com_err_ (code, entry); return; end; call ioa_ ("All entries older than ^d days have been removed.", age); return; /* help for operators */ PRINT_HELP: call ioa_ ("Usage is: ^a -age ndays [-quota npages]", entry); call ioa_ ("Where ndays is the time segments are allowed to remain in the pool, and npages is the amount of unused quota for sharing among users of an access class. When quota is not specified, the default is ^d pages.", default_npages); return; test_card_pool: entry (dir); /* entry to set the card pool root dirname */ dcl dir char (*); card_dir = dir; return; test_tape_pool: entry (dir); /* entry to set the tape pool root dirname */ tape_dir = dir; return; end clean_card_pool;  read_cards_.pl1 03/15/89 0841.5r w 03/15/89 0800.0 347841 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ read_cards_: proc (root, stream_info_ptr, error_stream, test, a_code); /* Standard card input procedure for Bulk card input and Remote Job Entry */ /* Modified Oct. 1977 by DRV to add new control card formats and RJE function */ /* Modified Jan. 1978 by J. C. Whitmore for minor bug fixes and to restore deletion of aborted decks */ /* Modified 5/78 by DRV to change calling sequence to validate_card_input_ for card input password changing */ /* Modified 12/78 by DRV for general bug fixes */ /* Modified by J. C. Whitmore, 3/79, for several gross bug fixes */ /* Modified by J. C. Whitmore, 5/79, to fix the blank password bug */ /* Modified by J. C. Whitmore, 3/80, to allow 2 EOF records between decks (for HASP) */ /* Modified: 8 October 1981 by G. Palter to bypass the "classic" segment to MSF conversion problem */ /* Modified 1984-08-16 by E. Swenson for Version 2 PNTs. */ /* Modified 1984-12-27 by Keith Loepere for version 2 create_branch_info. */ /* Modified: 03 March 1985 by C. Marker to fix problem where the use of AF brackets or semicolons on the ++RJECONTROL and ++RJEARGS could cause the Multics server to execute random commands. */ dcl error_stream char (*); /* message stream for the caller */ dcl a_prt_rqt char (*); dcl a_station char (*); dcl root char (*); /* card_pool_root directory */ dcl test bit (1); /* =1 if in test mode */ dcl a_code fixed bin (35); dcl a_pun_rqt char (*); dcl absin_ename char (32); dcl absin_online bit (1); dcl absin_pname char (168) var; dcl absout_pname char (168) var; dcl password char (8); dcl new_password char (8); dcl temp_password char (8); dcl aclec fixed bin; dcl add_nl bit (1); dcl aim_string char (720) var; dcl bc fixed bin (24); /* bit count of seg */ dcl cancel_rje bit (1); dcl card_buffer char (100) aligned;/* read buffer for character input */ dcl card_image char (160) var; dcl output_string char (string_len) based (deckp); dcl string_len fixed bin; dcl deck_char_pos (200) char (1) based (deckp); /* actually only 80 will be used at a time */ dcl remaining_chars fixed bin (24); dcl left fixed bin (24); dcl code fixed bin (35); dcl command char (1000) var; dcl component fixed bin; dcl contin bit (1); dcl control_iocbp ptr; dcl deck_auth bit (72); dcl deck_format char (12); /* requested format form control card */ dcl deck_name char (32) var; /* user supplied name of deck(truncated to 32 chars) */ dcl deck_name_prefix char (32) var; dcl deckp ptr; dcl dirname char (168); /* pathname of personid directory in pool */ dcl done bit (1); dcl element_size fixed bin; /* element size for deck format */ dcl epilogue_string char (256) var; dcl error_iocbp ptr; dcl error_msg char (132); /* message from validate_card_input_ */ dcl fcbp ptr; dcl field (40) char (80) var; dcl field_begin fixed bin; dcl field_cnt fixed bin; dcl field_len fixed bin; dcl header_len fixed bin; dcl header_string char (600) var; dcl i fixed bin; dcl ignore fixed bin (35); dcl input_iocbp ptr; dcl input_modes char (256); dcl input_mode_bits bit (36); dcl control_mode_bits bit (36); dcl j fixed bin; dcl k fixed bin; dcl key char (32) var; dcl lnd fixed bin; /* length of new_deck_name with tag */ dcl long char (100); /* space to expand an error_table_ code */ dcl lower_case bit (1); dcl mode fixed bin; dcl nel fixed bin (24); dcl nelt fixed bin (24); /* number of elements transmitted */ dcl num_chars_rec fixed bin (24); dcl new_deck_name char (32); /* internal name of deck */ dcl overwrite bit (1); dcl person char (32); /* person part of personid */ dcl personid char (32); dcl pool_open bit (1); dcl proc_auth bit (72); /* access class of the process */ dcl project char (32); /* and the project part */ dcl rje_arg_string char (256) var; dcl rje_control_string char (256) var; dcl scan_done bit (1); dcl prior_read_aborted bit (1); /* flag to attempt to sync control cards */ dcl short char (8); /* dummy for convert_status_code_ */ dcl string char (160) var; dcl tag fixed bin; /* dupe deck counter */ dcl trailer_len fixed bin; dcl trailer_string char (600) var; dcl trim bit (1); dcl uid char (32) var; /* unique ID from first and last cards */ dcl (record_quota_overflow, card_command_level, cleanup, command_error, out_of_bounds) condition; dcl any_other condition; dcl 1 header aligned, 2 system_lines (6) char (80) var init ("&command_line off", "rdf;rje_args$set prt_rqt", "rje_args$set pun_rqt", "rje_args$set station", "&command_line on", "set_epilogue_command ""dp -dl -rqt [rje_args prt_rqt] [user absout]"";rdn"), 2 user_lines (1) char (120) var init (""); dcl 1 trailer aligned, 2 system_lines (1) char (80) var init ("logout"), 2 user_lines (1) char (120) var init (""); dcl 1 count_structure aligned, /* structure used for the get_count control order */ 2 line fixed bin, /* most fields are pads, because this structure */ 2 page_len fixed bin, /* is based on the printer defined structure */ 2 lmarg fixed bin, /* shown in prt_order_info.incl.pl1 */ 2 rmarg fixed bin, 2 cards fixed bin (35), /* this is the normal line count field */ 2 page_count fixed bin; dcl 1 cond_info aligned, %include cond_info; dcl 1 command_error_info aligned based (cond_info.infoptr), %include cond_info_structure; 2 name_ptr ptr, 2 name_lth fixed bin, 2 errmess_ptr ptr, 2 errmess_lth fixed bin, 2 max_errmess_lth fixed bin, 2 print_sw bit (1); dcl 1 acle (2) aligned, /* ACL entry */ 2 name char (32), 2 mode bit (36), 2 pad bit (36), 2 code fixed bin (35); dcl control_modes char (32) int static init ("^add_nl,lower_case,^trim.") options (constant); dcl tools_dir char (32) var int static init (">system_library_tools") options (constant); dcl space char (1) int static init (" ") options (constant); dcl NL char (1) int static options (constant) init (" "); dcl SPECIAL_CHARACTERS char (8) static init ("()[]; ") options (constant); dcl tell_user bit (1) int static init ("1"b) options (constant); dcl silent bit (1) int static init ("0"b) options (constant); dcl data fixed bin int static init (1); dcl rje fixed bin int static init (2); dcl prt_rqt char (32) var init ("printer") int static; dcl pun_rqt char (32) var init ("punch") int static; dcl station char (32) var int static init ("reader"); dcl error_message char (command_error_info.errmess_lth) based (command_error_info.errmess_ptr); dcl 1 local_cbi aligned like create_branch_info auto; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl error_table_$short_record ext fixed bin (35); dcl error_table_$end_of_info fixed bin (35) ext; dcl error_table_$ai_restricted ext static fixed bin (35); dcl error_table_$eof_record ext fixed bin (35); dcl error_table_$namedup ext static fixed bin (35); dcl card_util_$modes entry (char (*), bit (36), char (*), fixed bin (35)); dcl card_util_$translate entry (bit (36), char (*) var); dcl continue_to_signal_ entry (fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl scramble_ entry (char (8)) returns (char (8)); dcl send_mail_ entry (char (*), char (*), ptr, fixed bin (35)); dcl validate_card_input_$user entry (char (*), char (*), char (*), char (*), char (*), fixed bin, char (*), fixed bin (35)); dcl suffixed_name_$make entry (char (*), char (*), char (*), fixed bin (35)); dcl msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35)); dcl aim_check_$equal entry (bit (72), bit (72)) returns (bit (1)); dcl convert_status_code_ entry (fixed bin (35), char (8), char (100)); dcl convert_authorization_$from_string entry (bit (72), char (*), fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin, fixed bin (35)); dcl cu_$level_get entry returns (fixed bin); dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl get_authorization_ entry returns (bit (72)); dcl get_group_id_ entry returns (char (32)); dcl get_group_id_$tag_star entry returns (char (32)); dcl msf_manager_$close entry (ptr); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)); dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)); dcl msf_manager_$acl_add entry (ptr, ptr, fixed bin, fixed bin (35)); dcl hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35)); dcl ioa_$ioa_stream entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl iox_$get_chars entry (ptr, ptr, fixed bin (24), fixed bin (24), fixed bin (35)); dcl iox_$look_iocb entry (char (*) aligned, ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*) aligned, ptr, fixed bin (35)); dcl pool_manager_$add_quota entry (char (*), fixed bin, fixed bin (35)); dcl pool_manager_$close_user_pool entry (char (*), char (*), fixed bin, bit (36), fixed bin (35)); dcl pool_manager_$open_user_pool entry (char (*), char (*), char (*), fixed bin (35)); dcl (addr, null, index, substr, verify, length, addrel, multiply, hbound, divide) builtin; dcl (rtrim, before, after, unspec, search, ltrim) builtin; %include card_stream_info; %include create_branch_info; %include send_mail_info; unspec (send_mail_info) = "0"b; send_mail_info.version = send_mail_info_version_2; send_mail_info.sent_from = station; send_mail_info.wakeup = "1"b; send_mail_info.always_add = "1"b; send_mail_info.never_add = "0"b; send_mail_info.notify = "0"b; send_mail_info.acknowledge = "0"b; /* process arguments */ call init; proc_auth = get_authorization_ (); /* get caller's authorization */ on record_quota_overflow call overflow_handler; on command_error begin; call find_condition_info_ (null, addr (cond_info), (0)); if before (error_message, ":") = "enter_abs_request" then do; call notify_user ("Unable to submit RJE request: " || after (error_message, ":")); call ioa_$ioa_stream (error_stream, "^a", error_message); call report ("Unable to submit RJE request.", silent); /* don't give message twice */ call clean_up; call iox_$control (error_iocbp, "runout", null, code); /* be sure operator sees any messages */ go to start; /* get back in sync */ end; else call continue_to_signal_ (0); end; on cleanup begin; code = 0; call report ("Aborting card input. Clear the hopper before continuing.", silent); /* don't tell user */ call clean_up; /* delete any partial input */ end; call iox_$look_iocb (card_stream_info.control_stream, control_iocbp, code); if code ^= 0 then call abort ("Unable to find control iocbp."); call iox_$look_iocb ((error_stream), error_iocbp, code); if code ^= 0 then call abort ("Unable to find error iocbp."); call card_util_$modes (control_modes, control_mode_bits, "", code); if code ^= 0 then call abort ("Unable to set modes on control stream."); start: call init; call read_control_card; if code ^= error_table_$eof_record then do; /* not an EOF? not nice */ call abort_read ("Deck must begin with ++EOF card.", silent); end; read_uid: call read_control_card; if code = error_table_$eof_record then do; /* an EOF? */ call read_control_card; /* allow 2 in a row */ if code = error_table_$eof_record then do; /* but no more */ call ioa_$ioa_stream (error_stream, "Unexpected ++EOF card. Check deck format."); goto finale; end; end; if key = "++uid" then do; uid = field (1); if uid = "" then call abort_read ("Blank field in ++UID card.", silent); end; else call abort_read ("++UID card expected.", silent); call read_control_card; if code = error_table_$eof_record then do; if prior_read_aborted then goto read_uid; /* when out of sync, this is probably the next deck */ call abort_read ("++EOF card found among control cards. Aborting deck.", silent); end; call ioa_$ioa_stream (error_stream, "*Begin deck*"); if key = "++data" then do; mode = data; call parse_first_card ("++DATA"); personid = rtrim (person) || "." || rtrim (project); call check_card_input_password; done = "0"b; do while (^done); call read_control_card; if code = error_table_$eof_record then call abort_read ("Unexpected ++EOF card among control cards.", tell_user); if key = "++format" then call parse_format_card; else if key = "++aim" then aim_string = aim_string || string; else if key = "++control" then do; if field (1) = "overwrite" & password ^= "" then overwrite = "1"b; else call abort_read ("Invalid ++CONTROL card", tell_user); end; else if key = "++input" then done = "1"b; else if key = "++data" then call abort_read ("Out of sequence ++DATA card", tell_user); else call abort_read ("Unrecognized control card key: " || key, tell_user); end; end; else if key = "++rje" then do; mode = rje; call parse_first_card ("++RJE"); if substr (deck_name, length (deck_name) - 6) = ".absin" then deck_name = substr (deck_name, 1, length (deck_name) - 6); personid = rtrim (person) || "." || rtrim (project); call check_card_input_password; rje_arg_string = "-arguments"; rje_control_string = "-proxy " || rtrim (personid) || " -sender " || rtrim (station); done = "0"b; do while (^done); call read_control_card; if code = error_table_$eof_record then call abort_read ("Unexpected ++EOF card among control cards.", tell_user); if key = "++aim" then aim_string = aim_string || string; else if key = "++rjeargs" then rje_arg_string = rje_arg_string || space || string; else if key = "++rjecontrol" then rje_control_string = rje_control_string || space || string; else if key = "++format" then call parse_format_card; else if key = "++epilogue" then epilogue_string = epilogue_string || space || string; else if key = "++absin" then do; absin_online = "1"b; if field_cnt < 1 | field_cnt > 2 then call abort_read ("Incorrect ++ABSIN card", tell_user); call expand_pathname_ ((field (1)), dirname, absin_ename, code); if code ^= 0 then call abort_read ("Unable to decode ++ABSIN segment definition. " || field (1), tell_user); call suffixed_name_$make ((absin_ename), "absin", absin_ename, code); if code ^= 0 then call abort_read ("Bad absin name on ++ABSIN card " || field (1), tell_user); if field (2) ^= "" then do; if field (2) = "system" then do; absin_pname = tools_dir || ">" || absin_ename; end; else call abort_read ("Invalid option on ++ABSIN card " || field (2), tell_user); call ioa_$rsnnl (">user_dir_dir>^a>^a>^a.absout", absout_pname, 0, project, person, before (absin_ename, ".absin")); end; else do; if substr (field (1), 1, 1) = ">" then absin_pname = rtrim (dirname) || ">" || absin_ename; else call ioa_$rsnnl (">user_dir_dir>^a>^a>^a", absin_pname, 0, project, person, absin_ename); absout_pname = substr (absin_pname, 1, length (rtrim (absin_pname)) - 6) || ".absout"; end; end; else if key = "++input" then done = "1"b; else if key = "++rje" then call abort_read ("Out of sequence ++RJE card", tell_user); else call abort_read ("Unrecognized control card key: " || key, tell_user); end; end; else call abort_read ("Unexpected control card key: " || key, tell_user); call convert_authorization_$from_string (deck_auth, (aim_string), code); /* and convert the access_class */ if code ^= 0 then call abort_read ("Unable to convert deck access class " || aim_string, tell_user); if ^aim_check_$equal (proc_auth, deck_auth) then do; /* wrong level ? */ a_code = error_table_$ai_restricted; return; end; if mode = data | mode = rje & ^absin_online then do; do k = 1 to card_stream_info.n_streams while (card_stream_info.format (k) ^= deck_format); end; if k > card_stream_info.n_streams then call abort_read ("Undefined deck format for this device: " || deck_format, tell_user); else do; call iox_$look_iocb (card_stream_info.name (k), input_iocbp, code); element_size = card_stream_info.el_size (k); end; if mode = rje & element_size ^= 9 then /* require character input for absin segments */ call abort_read ("Invalid conversion format for RJE: " || rtrim (deck_format), tell_user); call pool_manager_$open_user_pool (root, person, dirname, code); if code ^= 0 then /* pool error is very bad */ call abort ("Unable to open pool storage."); pool_open = "1"b; /* be sure we close the pool on error */ unspec (local_cbi) = "0"b; local_cbi.version = create_branch_version_2; local_cbi.mode = "101"b; local_cbi.rings (1), local_cbi.rings (2), local_cbi.rings (3) = cu_$level_get (); local_cbi.userid = get_group_id_ (); local_cbi.access_class = proc_auth; tag, code = -1; do while (code ^= 0); tag = tag + 1; /* change the name to "name.n" */ if tag > 499 then /* avoid infinite loop, but try hard */ call abort_read ("Aborting deck: 500 duplicate decks in " || dirname, tell_user); call ioa_$rsnnl ("^a.^d^[.absin^]", new_deck_name, lnd, deck_name, tag, (mode = rje)); if lnd > 32 then call abort_read ("Entry name too long: " || substr (new_deck_name, 1, lnd), tell_user); call hcs_$create_branch_ (dirname, new_deck_name, addr (local_cbi), code); if code = error_table_$namedup & overwrite then code = 0; if code ^= 0 & code ^= error_table_$namedup then /* also very bad */ call abort_read ("Unable to create branch in pool: " || new_deck_name, silent); end; call msf_manager_$open (dirname, new_deck_name, fcbp, code); if fcbp = null then call abort_read ("Unable to open new pool entry", silent); component = 0; call msf_manager_$get_ptr (fcbp, component, "0"b, deckp, bc, code); if deckp = null then call abort_read ("Unable to initiate new pool entry: " || new_deck_name, silent); call ioa_$ioa_stream (error_stream, "Reading ^a (^a) for ^a.", new_deck_name, deck_format, personid); if mode = rje then do; absin_pname = rtrim (dirname) || ">" || new_deck_name; deck_name_prefix = substr (new_deck_name, 1, length (rtrim (new_deck_name)) - 6); call ioa_$rsnnl (">user_dir_dir>^a>^a>^a.absout", absout_pname, (0), project, person, deck_name_prefix); call set_abs_header; end; call ioa_$rsnnl ("^[^^^]trim,^[^^^]lower_case,^[^^^]add_nl,^[^^^]contin.", input_modes, (0), ^trim, ^lower_case, ^add_nl, ^contin); call card_util_$modes (input_modes, input_mode_bits, "", code); if code ^= 0 then call abort_read ("Unable to set user input modes", tell_user); on out_of_bounds go to oob; call iox_$control (input_iocbp, "reset", null, ignore); /* clear the record totals */ nel = divide ((sys_info$max_seg_size * 36), element_size, 35); /* get number of elements in a segment */ if element_size ^= 9 then do; call iox_$get_chars (input_iocbp, deckp, nel + 1, nelt, code); if code ^= 0 then do; if code = error_table_$eof_record then goto end_read_loop; else if code = error_table_$end_of_info | code = error_table_$short_record then code = 0; else call abort_read ("Error while reading user data. Aborting deck.", silent); end; else call abort_read ("Attempted read of more then a segments worth of data succeeded", silent); end; else do; /* This group ASSUMES an element size of 9 bits (chars) */ nelt = header_len; /* set the number of chars used in last MSF component */ /* if not RJE, header_len is zero */ remaining_chars = nel - header_len; /* set number of chars remaining in segment */ read_one_card: num_chars_rec = 0; card_buffer = ""; call iox_$get_chars (input_iocbp, addr (card_buffer), 80, num_chars_rec, code); if code ^= 0 then do; if code = error_table_$eof_record then goto end_read_loop; /* NORMAL EXIT */ else if code = error_table_$end_of_info | code = error_table_$short_record then code = 0; else call abort_read ("Error while reading user data. Aborting deck.", silent); /* ERROR EXIT */ end; card_image = substr (card_buffer, 1, num_chars_rec); /* put into var string for translation */ call card_util_$translate (input_mode_bits, card_image); num_chars_rec = length (card_image); /* get the new length after translation */ left = remaining_chars - num_chars_rec; /* must be at least 1 char left to bump ptr */ if left <= 0 then do; /* if not enough, put in part and start new component */ string_len = remaining_chars; /* set size of output_string */ output_string = substr (card_image, 1, remaining_chars); component = component + 1; /* start the next MSF component */ if component = 1 then do; /* about to force conversion to MSF ... */ call pool_manager_$add_quota (root, 260, code); /* ... need extra quota during conversion */ if code ^= 0 then do; /* couldn't get it: let the operator try to correct it ... */ call report (NL || "Insufficient quota in pool to convert to MSF." || NL, silent); signal card_command_level; call pool_manager_$add_quota (root, 260, code); /* ... and try again */ end; if code ^= 0 then call abort_read ("Insufficient quota in pool to convert to MSF.", silent); end; call msf_manager_$get_ptr (fcbp, component, "1"b, deckp, bc, code); if deckp = null then call abort_read ("Unable to initiate next MSF component", silent); if component = 1 then /* give back the quota we got temporarily */ call pool_manager_$add_quota (root, -260, (0)); if left = 0 then card_image = ""; /* if it fit exactly.... */ else card_image = substr (card_image, remaining_chars + 1); /* set image to last part of card */ string_len = length (card_image); /* set the output_string size */ output_string = card_image; deckp = addr (deck_char_pos (string_len + 1)); /* where the next char goes */ remaining_chars = nel - string_len; /* room left in this component */ nelt = string_len; /* restart last component count */ end; else do; /* the full card (+ 1 char) will fit this MSF component */ string_len = length (card_image); /* set the length of output_string */ output_string = card_image; /* and write out the data */ deckp = addr (deck_char_pos (string_len + 1)); /* where the next char goes */ remaining_chars = left; /* do the accounting */ nelt = nelt + string_len; /* update the number received */ end; go to read_one_card; end; end_read_loop: unspec (count_structure) = ""b; /* clear the count in case the control order is unknown */ call iox_$control (input_iocbp, "get_count", addr (count_structure), ignore); /* get the total */ /* this data can be used for accounting in the future */ /* now compute the bitcount of the last component */ if mode = rje then do; call set_abs_trailer; /* this will modify nelt and maybe component */ end; revert out_of_bounds; bc = multiply (nelt, element_size, 24, 0); /* set bitcount of last component ... all others are max_seg_size * 36 */ call msf_manager_$adjust (fcbp, component, bc, "111"b, code); if code ^= 0 then call abort_read ("Error setting bit-count.", silent); unspec (acle) = "0"b; acle (1).name = rtrim (personid) || ".*"; /* set the acl */ acle (1).mode = "1"b; if mode = rje then do; aclec = 2; acle (2).name = get_group_id_$tag_star (); acle (2).mode = "1"b; end; else aclec = 1; call msf_manager_$acl_add (fcbp, addr (acle), aclec, code); if code ^= 0 then call abort_read ("Error setting ACL.", silent); end; else do; /* for rje absin online case */ call read_control_card; if code ^= error_table_$eof_record then call abort_read ("Unexpected control card " || key, silent); end; call read_control_card; if key ^= "++uid" then call abort_read ("Expected ++UID card not found", silent); else if uid ^= field (1) then call abort_read ("Mismatched ++UID card. Looking for: " || uid, silent); if fcbp ^= null then call msf_manager_$close (fcbp); fcbp = null; if pool_open then do; call pool_manager_$close_user_pool (root, person, 1, "100"b || (33)"0"b, code); /* close the pool */ if code ^= 0 then call abort_read ("Error closing user's pool.", silent); end; pool_open = "0"b; /* all is well */ call ioa_$ioa_stream (error_stream, "*Successful read^[(^d cards)^]*", (count_structure.cards > 0), count_structure.cards); if mode = rje then do; /* submit abs request */ if index (rje_control_string, " -of ") = 0 & index (rje_control_string, " -output_file ") = 0 then rje_control_string = rje_control_string || space || "-output_file " || absout_pname; command = "enter_abs_request " || absin_pname || " -brief " || rje_control_string || space || rje_arg_string; call cu_$cp (addrel (addr (command), 1), length (command), code); call notify_user ("RJE job: """ || rtrim (deck_name) || """, queued for absentee."); end; else call notify_user ("Successful read of card deck: " || rtrim (deck_name)); call iox_$control (error_iocbp, "runout", null, code); /* be sure operator sees any messages */ goto start; /* see if there is another deck to read */ end_card: call ioa_$ioa_stream (error_stream, "++END card read.^/"); call clean_up; finale: a_code = code; return; oob: call abort_read ("Multi-segment input not allowed for card mode" || rtrim (deck_format), tell_user); set_station: entry (a_station, a_code); a_code = 0; station = a_station; return; set_rqt: entry (a_prt_rqt, a_pun_rqt, a_code); a_code = 0; prt_rqt = a_prt_rqt; pun_rqt = a_pun_rqt; return; abort: proc (message); dcl message char (*); call report (message, silent); /* use the standard messages */ call clean_up; call ioa_$ioa_stream (error_stream, "Unable to continue."); /* then say it is bad */ call iox_$control (error_iocbp, "runout", null, (0)); /* force out the message */ goto finale; end abort; abort_read: proc (message, tell_user); dcl message char (*); dcl tell_user bit (1); call report (message, tell_user); /* give an error message and cleanup the pool */ call clean_up; call ioa_$ioa_stream (error_stream, "Skipping to next ++EOF card. "); call iox_$control (error_iocbp, "runout", null, (0)); /* force out the message */ prior_read_aborted = "1"b; do j = 1 by 1; call read_control_card; if code = error_table_$eof_record then do; /* is this an EOF? */ if uid ^= "" then do; /* are we expecting ++UID match ? */ call read_control_card; if code = error_table_$eof_record then call read_control_card; /* this one must be good .. */ if key = "++uid" & field (1) = uid then goto start; end; else do; call init; prior_read_aborted = "1"b; goto read_uid; end; end; end; return; end abort_read; report: proc (message, tell_user); dcl message char (*); dcl tell_user bit (1); if code ^= 0 then call convert_status_code_ (code, short, long); else long = ""; on any_other goto report_ret; /* in case the error stream is not there */ if tell_user then call notify_user ("Aborted card input deck: " || rtrim (deck_name) || NL || message); call ioa_$ioa_stream (error_stream, /* give message to the operator */ "read_cards_: ^[Error while processing deck ""^a"" for ^a^/^;^2s^]^a^/^a", (deck_name ^= ""), deck_name, personid, message, long); report_ret: return; end report; read_control_card: proc; dcl i fixed bin; field_cnt = 0; field (*) = ""; card_buffer, key = ""; call iox_$get_chars (control_iocbp, addr (card_buffer), 80, nelt, code); if code ^= 0 then do; if code = error_table_$eof_record then return; else if code = error_table_$end_of_info | code = error_table_$short_record then code = 0; else call abort ("Read error."); end; card_image = substr (card_buffer, 1, nelt); call card_util_$translate (control_mode_bits, card_image); card_image = ltrim (card_image); /* strip any leading spaces */ card_image = rtrim (card_image, NL || space); /* and trailing NL's or spaces */ i = search (card_image, space); if i = 0 then do; /* no space, could be ++INPUT */ key = card_image; /* try for it */ if key = "++end" then goto end_card; return; end; key = substr (card_image, 1, i - 1); /* record the key value */ if key = "++end" then goto end_card; string = ltrim (substr (card_image, i + 1)); /* see what is after the space */ if search (string, SPECIAL_CHARACTERS) > 0 then call abort ("Special characters in control string."); field_begin = 1; scan_done = "0"b; do i = 1 by 1 while (^scan_done); field_len = search (substr (string, field_begin), " "); if field_len = 0 then do; field_len = length (string) - field_begin + 1; scan_done = "1"b; end; else field_len = field_len - 1; field (i) = substr (string, field_begin, field_len); field_begin = field_begin + field_len + verify (substr (string, field_begin + field_len), " ") - 1; field_cnt = i; end; return; end read_control_card; clean_up: proc; if fcbp ^= null then do; call msf_manager_$close (fcbp); fcbp = null; /* don't repeat this */ call delete_$path (dirname, new_deck_name, "100100"b, "", (0)); end; if pool_open then do; call pool_manager_$close_user_pool (root, person, 1, "100"b || (33)"0"b, (0)); pool_open = "0"b; end; return; end clean_up; overflow_handler: proc; call pool_manager_$add_quota (root, 10, code); /* add 10 pages and keep going */ if code ^= 0 then do; call report ("^/No available quota in card pool.", silent); signal card_command_level; /* allow operator to respond */ end; return; /* restart where we stopped if it returns */ end overflow_handler; set_abs_header: proc; header_string = header.system_lines (1) || NL || header.system_lines (2) || space || prt_rqt || NL || header.system_lines (3) || space || pun_rqt || NL || header.system_lines (4) || space || station || NL || header.system_lines (5) || NL; if epilogue_string ^= "" then header_string = header_string || "set_epilogue_command """ || epilogue_string || """" || NL; else header_string = header_string || header.system_lines (6) || NL; do i = 1 to hbound (header.user_lines, 1) while (header.user_lines (i) ^= ""); header_string = header_string || header.user_lines (i) || NL; end; header_len, string_len = length (header_string); deckp -> output_string = header_string; deckp = addr (deckp -> deck_char_pos (header_len + 1)); return; end set_abs_header; set_abs_trailer: proc; trailer_string = trailer.system_lines (1) || NL; do i = 1 to hbound (trailer.user_lines, 1) while (trailer.user_lines (i) ^= ""); trailer_string = trailer_string || trailer.user_lines (i) || NL; end; trailer_len, string_len = length (trailer_string); left = remaining_chars - trailer_len; /* will it all fit this segment? */ if left < 0 then do; /* OOPS */ string_len = remaining_chars; /* set size of output_string */ output_string = substr (trailer_string, 1, remaining_chars); component = component + 1; /* start the next MSF component */ if component = 1 then do; /* about to force conversion to MSF ... */ call pool_manager_$add_quota (root, 260, code); /* ... need extra quota during conversion */ if code ^= 0 then do; /* couldn't get it: let the operator try to correct it ... */ call report (NL || "Insufficient quota in pool to convert to MSF." || NL, silent); signal card_command_level; call pool_manager_$add_quota (root, 260, code); /* ... and try again */ end; if code ^= 0 then call abort_read ("Insufficient quota in pool to convert to MSF.", silent); end; call msf_manager_$get_ptr (fcbp, component, "1"b, deckp, bc, code); if deckp = null then call abort_read ("Unable to initiate next MSF component", silent); if component = 1 then /* give back the quota we got temporarily */ call pool_manager_$add_quota (root, -260, (0)); trailer_string = substr (trailer_string, remaining_chars + 1); /* set image to last part of card */ string_len = length (trailer_string); /* set the output_string size */ output_string = trailer_string; nelt = string_len; /* restart last component count */ end; else do; output_string = trailer_string; nelt = nelt + trailer_len; /* fix the element count so we can compute the bit count */ end; return; end set_abs_trailer; init: proc; a_code, code = 0; deck_name, person, project, personid, absin_pname, absin_ename, absout_pname, dirname = ""; aim_string, rje_control_string, rje_arg_string, epilogue_string = ""; deck_format = card_stream_info.format (1); /* set the default to the first stream we use */ header_len, trailer_len, nelt = 0; input_mode_bits = "0"b; pool_open = "0"b; /* the user pool is not yet open */ add_nl = "1"b; absin_online = "0"b; lower_case = "0"b; overwrite = "0"b; cancel_rje = "0"b; contin = "0"b; trim = "1"b; uid = ""; /* get ready for a new uid value */ deckp, fcbp = null; prior_read_aborted = "0"b; return; end init; %page; check_card_input_password: proc (); call read_control_card; if code = error_table_$eof_record then call abort_read ("Unexpected ++EOF card looking for password.", tell_user); if key ^= "++password" then call abort_read ("Expected ++PASSWORD card not found", tell_user); if field_cnt = 2 | field_cnt > 3 then /* allow no PW, PW, or PW -cpw NPW only */ call abort_read ("Invalid ++PASSWORD card", tell_user); if field (2) = "-cpw" then do; if field (3) ^= "" then do; temp_password = field (3); new_password = scramble_ (temp_password); field (3) = ""; temp_password = ""; end; else new_password = ""; end; else if field (2) ^= "" then call abort_read ("Invalid ++PASSWORD control argument.", tell_user); else new_password = ""; if field (1) ^= "" then do; temp_password = field (1); password = scramble_ (temp_password); field (1) = ""; temp_password = ""; end; else password = ""; call validate_card_input_$user (person, project, password, new_password, (station), mode, error_msg, code); if code ^= 0 then do; code = 0; call abort_read (error_msg, tell_user); end; personid = rtrim (person) || "." || project; /* redefine to remove any alias */ return; end check_card_input_password; %page; parse_format_card: proc; if field_cnt < 1 then call abort_read ("Incorrect ++FORMAT card.", tell_user); deck_format = field (1); do i = 2 to field_cnt; if field (i) = "trim" then trim = "1"b; else if field (i) = "notrim" then trim = "0"b; else if field (i) = "lowercase" then lower_case = "1"b; else if field (i) = "uppercase" then lower_case = "0"b; else if field (i) = "noconvert" then lower_case = "0"b; else if field (i) = "addnl" then add_nl = "1"b; else if field (i) = "noaddnl" then add_nl = "0"b; else if field (i) = "contin" then contin = "1"b; else if field (i) = "nocontin" then contin = "0"b; else call abort_read ("Undefined mode on ++FORMAT card: " || field (i), tell_user); end; return; end parse_format_card; notify_user: proc (message); dcl message char (*); if personid ^= "" then call send_mail_ (personid, message, addr (send_mail_info), (0)); return; end notify_user; parse_first_card: proc (string); dcl string char (*); if field_cnt ^= 3 & field_cnt ^= 2 then call abort_read ("Incorrect " || string || " card format.", tell_user); deck_name = field (1); if field_cnt = 3 then do; person = field (2); project = field (3); end; else if field_cnt = 2 then do; person = before (field (2), "."); project = after (field (2), "."); end; if person = "*" | person = "" then /* a personid of * is illegal */ call abort_read ("Person name must be defined.", tell_user); if project = "*" | project = "" then call abort_read ("Project name must be defined.", tell_user); end parse_first_card; end read_cards_;  reader_driver_.pl1 10/28/88 1351.4rew 10/28/88 1234.0 133065 /****^ ************************************************************ * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright, (C) Honeywell Information Systems Inc., 1980. * * * ************************************************************ */ /* format: style2 */ reader_driver_: procedure; return; /* this is not a legal entry */ /* Standard reader device driver control module for the I/O daemon. */ /* Stolen from punch_driver_ 12 24 79 */ /* Cleaned up for installation October 1980 */ /* Coded by Benson I. Margulies, give or take the above */ /* Modified: February 23, 1985 by C. Marker to use version 5 message segments */ /****^ HISTORY COMMENTS: 1) change(88-08-19,Brunelle), approve(88-08-19,MCR7911), audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199): Upgraded to version 5 iod tables. END HISTORY COMMENTS */ /* BASED */ dcl sys_dir char (168) based (iodd_static.sys_dir_ptr); /* AUTOMATIC VARIABLES */ dcl age fixed bin; dcl date_string char (24); dcl code fixed bin (35); dcl i fixed bin; /* general index variable */ dcl io_stat bit (72) aligned; /* ios_ status code */ dcl major_args char (major_args_length) based (major_args_ptr); dcl major_args_ptr ptr; dcl major_args_length fixed bin; dcl major_args_name char (256) varying; dcl retry_sw bit (1); dcl 1 st aligned based (addr (io_stat)), /* breakdown of status code */ 2 code fixed bin (35), 2 flags bit (36); dcl station char (32); /* EXTERNAL ENTRIES */ dcl add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); 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_$setsize entry (char (*) aligned, fixed bin (21), bit (72) aligned); dcl ios_$attach entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$detach entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); dcl ios_$getsize entry (char (*) aligned, fixed bin, bit (72) aligned); dcl pool_manager_$init entry (char (*), fixed bin, bit (36) aligned, fixed bin (35)); dcl pool_manager_$clean_pool entry (char (*), fixed bin, fixed bin, fixed bin (35)); dcl 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)); /* INTERNAL STATIC */ dcl pool_dir char (168) internal static; dcl meter_sw bit (1) int static;/* TRUE - if we are to keep metering data (future) */ dcl p ptr int static; dcl both fixed bin int static options (constant) init (0); dcl master fixed bin int static options (constant) init (1); dcl slave fixed bin int static options (constant) init (2); dcl normal fixed bin int static options (constant) init (1); dcl error fixed bin int static options (constant) init (2); dcl whoami char (25) int static options (constant) init ("reader_driver_"); dcl terminals (2) int static char (32); dcl DEFAULT_STATION char (6) init ("reader") int static options (constant); dcl card_dims (3) aligned int static /* format stream (switch) data structure */ char (32) init ("mcc_", "viipunch_", "raw_") options (constant); /* BUILTINS */ dcl (addr, clock, convert, divide, rtrim) builtin; /* CONDITIONS */ dcl (cleanup, card_command_level) 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_$ionmat fixed bin (35) ext static; dcl 1 card_info aligned static like card_stream_info; %page; %skip (5); init: entry (arg_p); dcl arg_p ptr; stat_p = arg_p; /* put the arg into static for easy reference */ text_strings_ptr = iodd_static.text_strings_ptr; /* get ptr to i/o daemon table text area */ p = iodd_static.driver_ptr; /* get current driver status ptr */ terminals (master) = iodd_static.master_input; terminals (slave) = "Undefined"; retry_sw = "1"b; /* retry attachments once on error */ if iodd_static.attach_type ^= ATTACH_TYPE_IOM then do; /* this driver expects an IOM channel */ code = error_table_$fatal_error; call iodd_msg_ (error, master, code, whoami, "This driver requires a reader attached through the IOM."); return; /* quit now */ end; if iodd_static.assigned_devices > 1 then do; /* be sure all is correct */ code = error_table_$fatal_error; call iodd_msg_ (error, master, code, whoami, "Multiple minor devices are not supported by the reader driver."); return; end; /* 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)); 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; iodd_static.device_dim = iodd_parse_$args ("dim=", major_args); /* see if a dim was specified */ if iodd_static.device_dim = "" then iodd_static.device_dim = "crz"; /* no, use the default */ iodd_static.dev_out_stream = "Undefined"; iodd_static.dev_io_stream = iodd_static.dev_out_stream; /* make them the same */ iodd_static.dev_in_stream = "card_in_stream"; /* TIME TO GET STATION ID */ station = iodd_parse_$args ("station=", major_args); if station = "" then station = DEFAULT_STATION; call read_cards_$set_station (station, code); if code ^= 0 then do; call iodd_msg_ (error, master, code, whoami, "Fatal Error: Could not set station to ^a.", station); return; end; call read_cards_$set_rqt ("printer", "punch", code); /* make the rje active functions work right */ if code ^= 0 then do; call iodd_msg_ (error, master, code, whoami, "Fatal Error: Unable to set default request types."); return; end; attach: call ios_$attach (iodd_static.dev_in_stream, iodd_static.device_dim, iodd_static.attach_name, "", io_stat); if st.code ^= 0 then do; if st.code = error_table_$ionmat & retry_sw then do; /* can we try again */ retry: retry_sw = "0"b; /* yes, but only once */ call detach_all; /* clear the slate */ go to attach; end; call iodd_msg_ (2, master, st.code, whoami, "Fatal Error: Unable to attach channel ^a", iodd_static.attach_name); go to clean_out; end; if iodd_static.test_entry then call ios_$setsize (iodd_static.dev_in_stream, 972, io_stat); card_info.control_stream = "mcc_card_input_"; /* we use this to read control cards */ card_info.n_streams = 4; /* we will support 4 input formats */ card_info.format (1) = "mcc"; /* first describe the MCC format stream */ card_info.name (1) = "mcc_card_input_"; /* this is also the control stream */ card_info.format (2) = "viipunch"; /* next we have the 7 punch format */ card_info.name (2) = "viipunch_card_input_"; card_info.format (3) = "raw"; /* next is the raw card format */ card_info.name (3) = "raw_card_input_"; card_info.format (4) = "rmcc"; /* last is rmcc for compatability with remote input */ card_info.name (4) = "mcc_card_input_"; /* this is the same as mcc format */ if iodd_static.test_entry then pool_dir = rtrim (iodd_static.sys_dir_ptr -> sys_dir) || ">card_pool"; else pool_dir = "System_Card_Pool"; call pool_manager_$init (pool_dir, 10, "01000"b, code); if code ^= 0 then do; call iodd_msg_ (2, master, code, whoami, "Fatal Error: cannot initialize card pool."); go to clean_out; end; on cleanup call detach_all; /* for reinit, no_coord, logout, new_device, etc... */ /* set up the reader code formatting dims corresponding to the dprint_msg outer_module variable */ do i = 1 to 3; call ios_$attach (card_info.name (i), card_dims (i), iodd_static.dev_in_stream, "", io_stat); if st.code ^= 0 then do; if st.code = error_table_$ionmat & retry_sw then go to retry; /* start_over */ call iodd_msg_ (2, master, st.code, whoami, "Fatal Error: Unable to attach ^a to ^a.", card_info.name (i), iodd_static.dev_in_stream); go to clean_out; end; end; do i = 1 to card_info.n_streams; call ios_$getsize (card_info.name (i), card_info.el_size (i), io_stat); if st.code ^= 0 then do; call iodd_msg_ (2, master, st.code, whoami, "Fatal Error: Invalid getsize call for dim ^a.", card_dims (i)); go to clean_out; end; end; if iodd_static.ctl_term.attached then do; call iodd_msg_ (2, master, st.code, whoami, "The reader driver does not support a ctl terminal."); go to clean_out; end; meter_sw = "0"b; /* no metering (future) */ call date_time_ (clock (), date_string); /* get set for ready message */ call iodd_msg_ (1, both, 0, "", "^/^a driver ready for station ^a at ^16a^/", p -> driver_status.dev_name_label, station, date_string); call iodd_listen_ (stat_p); /* iodd_listen_ will never return */ clean_out: /* this label is for error recovery */ call detach_all; return; %page; request: entry; /* This is the entry which is called by the iodd_listen_ procedure when a request for this driver has been received from the coordinator. The purpose of the code for this entry of the reader driver is to complain bitterly!! */ call iodd_msg_ (2, master, 0, "", "The reader device can't accept requests."); return; %page; command: entry (source, state, arg_list_p, c_code); dcl source fixed bin; /* 1 = master console, 2 = slave */ dcl state fixed bin; /* 0 = not quite ready to handle a request */ /* 1 = drivers are ready */ /* 2 = command entered after a quit */ dcl arg_list_p ptr; /* ptr to structure returned by parse_command_ */ dcl c_code fixed bin (35); /* error code: zero if command handled correctly */ /* error_table_ code for bad syntax or unknown command */ dcl 1 arg_list aligned based (arg_list_p), /* 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 */ if command = "help" then do; call iodd_msg_ (normal, source, 0, "", "^/** Commands for the reader driver **^/"); call iodd_msg_ (normal, source, 0, "", "clean_pool "); call iodd_msg_ (normal, source, 0, "", "read_cards"); c_code = 0; /* it was understood */ end; if command = "read_cards" | command = "readcards" then do; c_code = 0; call iodd_msg_ (normal, source, 0, "", "Card input started."); on card_command_level goto abort_read; /* grab control after record quota overflow */ call read_cards_ (pool_dir, addr (card_info), terminals (source), (iodd_static.test_entry), code); if code ^= 0 then do; call iodd_msg_ (normal, source, code, whoami, "Check card deck format."); c_code = code; return; end; return; abort_read: call iodd_msg_ (normal, source, 0, "", "Use the ""clean_pool"" command and retry card input."); go to cmd_error; end; if command = "clean_pool" | command = "cleanpool" then do; /* garbage collect the card pool */ if arg_list.n_tokens < 2 then do; /* we must have an age arg */ call iodd_msg_ (normal, source, 0, "", "Argument missing: days allowed to remain in the pool."); go to cmd_error; end; age = convert (age, arg_list.arg (1)); /* convert to binary */ if age < 1 then do; /* be sure the value is right */ call iodd_msg_ (normal, source, 0, "", "Invalid argument: ^a", arg (1)); go to cmd_error; end; call pool_manager_$clean_pool (pool_dir, age, 10, code); /* let pool_manager_ do the work */ if code ^= 0 then call iodd_msg_ (normal, source, code, whoami, "Unable to clean the card pool."); c_code = code; return; end; return; /* return any undefined commands without changing anything */ cmd_error: c_code = error_table_$action_not_performed; return; %page; detach_all: proc; /* cleanup proc to detach all possible streams we could have attached */ call ios_$detach (iodd_static.dev_in_stream, "", "", io_stat); do i = 1 to card_info.n_streams; call ios_$detach (card_info.name (i), "", "", io_stat); end; return; end detach_all; %page; initiate_the_file: proc (pathname_string, args_ptr, args_length, message, code); dcl pathname_string char (256) varying; dcl args_ptr ptr; dcl args_length fixed bin; dcl message char (*); dcl code fixed bin (35); dcl dirname char (168); dcl entname char (32); dcl compname char (32); dcl args_bc fixed bin (24); call expand_pathname_$component ((pathname_string), dirname, entname, compname, code); if code ^= 0 then return; call initiate_file_$component (dirname, entname, compname, R_ACCESS, args_ptr, args_bc, code); if code ^= 0 then return; args_length = divide (args_bc + 8, 9, 17, 0); end initiate_the_file; %page; %include access_mode_values; %page; %include card_stream_info; %page; %include driver_status; %page; %include iod_constants; %page; %include iod_tables_hdr; %page; %include iodd_static; %page; %include mseg_message_info; %page; %include request_descriptor; end reader_driver_;  validate_card_input_.pl1 03/27/85 1136.2r w 03/27/85 1132.1 71946 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ validate_card_input_: procedure options (separate_static); /* Changed by DRV 5/78 to add check for default password acs and to allow changing of card input password */ /* Modified by J. C. Whitmore, 5/24/79, to add locking to the PNT changes and hash table changes */ /* Modified by C. Hornig, January 1980, for new PNT. */ /* Modified 1984-08-16 by E. Swenson for Version 2 PNT */ /* Modified 1984-12-11 by E. Swenson to handle aliases correctly. */ /* Automatic */ dcl mode fixed bin (5); dcl ec fixed bin (35); dcl username char (32); dcl 1 pnte aligned like pnt_entry; /* Constant */ dcl access (2) bit (5) static init ("01000"b, "00100"b) options (constant); /* Internal Static */ dcl sysdir char (168) static init (">system_control_1"); /* External Static */ dcl error_table_$bad_arg fixed bin (35) external static; dcl error_table_$bad_password fixed bin (35) external static; dcl error_table_$action_not_performed fixed bin (35) external static; dcl iox_$error_output pointer external static; /* External Entries */ dcl continue_to_signal_ entry (fixed bin (35)); dcl convert_status_code_ entry (fixed bin (35), char (8), char (100)); dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin (3), fixed bin (5), fixed bin (35)); /* SWS */ dcl ioa_$ioa_switch entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl pnt_manager_$test entry (character (*)); dcl pnt_manager_$network_get_entry entry (char (*), char (*), ptr, fixed bin (35)); dcl pnt_manager_$update_entry entry (ptr, bit (1), bit (1), fixed bin (35)); dcl system_privilege_$seg_priv_on entry (fixed bin (35)); dcl system_privilege_$seg_priv_off entry (fixed bin (35)); /* Builtins */ dcl (bit, rtrim) builtin; /* Program */ /* * * * * * * * * * USER * * * * * * * * * */ user: entry (person, project, password, new_password, station_id, type, error_message, code); dcl (person, project, password, new_password, station_id, error_message) char (*) parameter; dcl code fixed bin (35) parameter; dcl type fixed bin parameter; /* 1 -> data, 2 -> RJE */ code = 0; error_message = ""; /* First check: In the system rcp directory, there must exist a segment called station_id.acs, and the user must have R access for bulk data input and E access for RJE. . */ username = rtrim (person) || "." || rtrim (project) || ".p"; call hcs_$get_user_effmode (rtrim (sysdir) || ">rcp", rtrim (station_id) || ".acs", username, 4, mode, ec); if ec ^= 0 then call error (ec, "Unable to check user access to station ACS"); if (bit (mode) & access (type)) ^= access (type) then call error (0, "Incorrect user access to station"); /* Second check: In user's mailbox directory >udd>project>person, there must exist a segment called card_input.acs, and station_id.*.* must have R access for bulk data input and E access for RJE. */ call hcs_$get_user_effmode (">udd>" || rtrim (project) || ">" || person, "card_input.acs", rtrim (station_id) || ".*.*", 4, mode, ec); if ec ^= 0 then call error (ec, "Unable to check station access to user access control segment"); if (bit (mode) & access (type)) ^= access (type) then call error (0, "Incorrect station access for user"); /**** Third check: If a password is supplied (and it must be for RJE input) it must be the valid network password in the PNT. If it is not supplied, the user must have access to the acs segment >sc1>rcp>card_input_password.acs. */ if password = "" then if type ^= 1 /* DATA */ then call error (0, "No password supplied"); else do; call hcs_$get_user_effmode (rtrim (sysdir) || ">rcp", "card_input_password.acs", username, 4, mode, ec); if ec ^= 0 then call error (ec, "Unable to check user access to card_input_password.acs"); if (bit (mode) & access (1)) ^= access (1) then call error (0, "Incorrect access to card_input_password.acs"); end; else call check_password (person, (password), (new_password)); RETURN_TO_CALLER: return; /* ============================================= */ station: entry (station_id, password, error_message, code); code = 0; error_message = ""; /**** Station names are registed in the PNT with only a network password. The password must match. */ call check_password (station_id, (password), ""); return; /* * * * * * * * * * TEST * * * * * * * * * */ test: entry (tdir); dcl tdir char (*); sysdir = tdir; call pnt_manager_$test (sysdir); return; /* * * * * * * * * * * CHECK_PASSWORD * * * * * * * * * */ check_password: procedure (Uid, Password, New_password); dcl Uid char (*) parameter; dcl (Password, New_password) char (8) aligned parameter; dcl dont_use_aim_priv bit aligned static init ("0"b); dcl aim_ind fixed bin (35) init (-1); /* When zero, priv has been enabled */ dcl code fixed bin (35); dcl (any_other, cleanup, linkage_error) condition; /**** First verify the password and get the PNT entry.*/ call pnt_manager_$network_get_entry (Uid, (Password), addr (pnte), code); if code ^= 0 then if code = error_table_$bad_password then call error (0, "Incorrect password supplied."); else call error (code, "Checking card password."); /**** If we get here, the password was valid. Set Uid to the userid in the PNT entry (in case an alias was used). */ Uid = pnte.user_id; /**** See if the user wants it changed. */ if New_password ^= "" then do; /* Changing password */ on any_other begin; /* keep tight control over AIM */ if aim_ind = 0 then do; /* Priv has been enabled */ call priv_off (); /* Disable */ call ioa_$ioa_switch (iox_$error_output, "validate_card_input_: Fault with AIM privilege on. Privilege revoked."); end; call continue_to_signal_ (code); end; on cleanup call priv_off; if ^dont_use_aim_priv then do; /* set AIM privilege */ on linkage_error begin; dont_use_aim_priv = "1"b; goto no_aim; end; call system_privilege_$seg_priv_on (aim_ind); no_aim: revert linkage_error; end; pnte.network_password = New_password; call pnt_manager_$update_entry (addr (pnte), "0"b, /* don't set regular password */ "1"b, /* do set network password */ code); call priv_off (); if code ^= 0 then call error (code, "Changing network password."); end; /* End of changing password code */ return; %page; priv_off: procedure (); dcl code fixed bin (35); if aim_ind = 0 then do; call system_privilege_$seg_priv_off (code); aim_ind = -1; end; end priv_off; end check_password; %page; /* * * * * * * * * * ERROR * * * * * * * * * */ error: proc (Ec, String); dcl Ec fixed bin (35) parameter; dcl String char (*) parameter; dcl long char (100); if Ec ^= 0 then call convert_status_code_ (Ec, (""), long); call ioa_$rsnnl ("^a ^[because ^a^]", error_message, (0), String, (Ec ^= 0), long); if Ec = 0 then code = error_table_$action_not_performed; else code = Ec; goto RETURN_TO_CALLER; end error; /* format: off */ %page;%include pnt_entry; /* format: on */ end validate_card_input_; 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