



		    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 <days allowed to remain>");
		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
