



		    cv_bcd_to_ascii_.alm            11/19/82  1409.3rew 11/19/82  0949.6       25272



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

"  Modified by RH Morrison 6/22/76

name	cv_bcd_to_ascii_
entry	cv_bcd_to_ascii_

cv_bcd_to_ascii_:

	push

	eppbp	ap|2,*		bp -> input data
	eppbp	bp|0,*

	eppap	ap|4,*		ap -> output data
	eppap	ap|0,*

	eax7	80   		init total character count
	eax4	0   		init ascii word offset
	eax3	0   		init bcd word offset
	eax2	4   		init ascii char count
	eax1	6   		init bcd char count
	ldq	bp|0		init btemp
	stq	btemp

continue:

	cmpx2	=0,du		check for full ascii word
	tnz	moreascii		need more ascii characters
	sta	ap|0,4		store full ascii word in output string
	adx4	=1,du		increment ascii word count
	eax2	4   		re-init ascii character count

	cmpx7	=0,du		check for completion
	tze	fin

moreascii:

	cmpx1	=0,du		check for used bcd word
	tnz	morebcd		need more bcd characters
	adx3	=1,du		increment bcd word count
	eax1	6		re-init bcd character count
	ldq	bp|0,3		get next full bcd word
	stq	btemp		save it

morebcd:

	ldq	btemp		load current bcd word
	qlr	6		make next bcd char leftmost
	stq	btemp		save for next time
	anq	=o000077,dl	isolate current character
	ldq	btable,ql		load ascii character into q
	lls	9		concatenate in a
	sbx2	=1,du		decrement ascii char count
	sbx1	=1,du		decrement bcd char count
	sbx7	=1,du		decrement total character count
	tra	continue		convert another character

fin:

	return

btable:	vfd	a9/0,27/0
	vfd	a9/1,27/0
	vfd	a9/2,27/0
	vfd	a9/3,27/0
	vfd	a9/4,27/0
	vfd	a9/5,27/0
	vfd	a9/6,27/0
	vfd	a9/7,27/0
	vfd	a9/8,27/0
	vfd	a9/9,27/0
	vfd	a9/[,27/0
	vfd	a9/#,27/0
	vfd	a9/@,27/0
	vfd	a9/:,27/0
	vfd	a9/>,27/0
	vfd	a9/?,27/0
	vfd	a9/ ,27/0
	vfd	a9/a,27/0
	vfd	a9/b,27/0
	vfd	a9/c,27/0
	vfd	a9/d,27/0
	vfd	a9/e,27/0
	vfd	a9/f,27/0
	vfd	a9/g,27/0
	vfd	a9/h,27/0
	vfd	a9/i,27/0
	vfd	a9/&,27/0
	vfd	a9/.,27/0
	vfd	a9/],27/0
	vfd	a9/(,27/0
	vfd	a9/<,27/0
	vfd	a9/\,27/0
	vfd	a9/^,27/0
	vfd	a9/j,27/0
	vfd	a9/k,27/0
	vfd	a9/l,27/0
	vfd	a9/m,27/0
	vfd	a9/n,27/0
	vfd	a9/o,27/0
	vfd	a9/p,27/0
	vfd	a9/q,27/0
	vfd	a9/r,27/0
	vfd	a9/-,27/0
	vfd	a9/$,27/0
	vfd	a9/*,27/0
	vfd	a9/),27/0
	vfd	o9/073,27/0		";
	vfd	a9/',27/0
	vfd	a9/+,27/0
	vfd	a9//,27/0
	vfd	a9/s,27/0
	vfd	a9/t,27/0
	vfd	a9/u,27/0
	vfd	a9/v,27/0
	vfd	a9/w,27/0
	vfd	a9/x,27/0
	vfd	a9/y,27/0
	vfd	a9/z,27/0
	vfd	a9/_,27/0			"<-
	vfd	o9/054,27/0		",
	vfd	a9/%,27/0
	vfd	a9/=,27/0
	vfd	a9/",27/0
	vfd	a9/!,27/0

temp	btemp

end




		    cv_bin_to_ascii_.pl1            11/19/82  1409.3rew 11/19/82  0929.1       51192



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/*  *****************************************************************************
   *								*
   *	Modified by RH Morrison  6/22/76				*
   *								*
   ***************************************************************************** */

cv_bin_to_ascii_: proc (a_input_ptr, a_output_ptr, a_code);


/* DECLARATIONS */
/* ------------ */


/* fixed bin */

dcl (
     direction,					/* direction of 1/2 interval search */
     i,						/* loop index */
     interval,					/* interval of 1/2 interval search */
     j,						/* loop index */
     search_index					/* index from search into binary table */
     ) fixed bin aligned;

dcl (
     a_code					/* error code */
     ) fixed bin (35) aligned;


/* pointers */

dcl (
     a_input_ptr,					/* pointer to input bit string (argument) */
     a_output_ptr,					/* pointer to output character string (argument) */
     bit_ptr,					/* pointer to input bit string (internal) */
     letter_ptr					/* pointer to output bit string (argument) */
     ) ptr aligned;


/* bit strings */

dcl (
     bin_char_not_found				/* ON until a binary table match is found */
     ) bit (1) aligned;

dcl  bin_table (0: 63) bit (12) aligned init (
     "000000000000"b,
     "000000000001"b,
     "000000000010"b,
     "000000000100"b,
     "000000000110"b,
     "000000001000"b,
     "000000001010"b,
     "000000010000"b,
     "000000010010"b,
     "000000100000"b,
     "000000100010"b,
     "000001000000"b,
     "000001000010"b,
     "000010000000"b,
     "000010000010"b,
     "000100000000"b,
     "001000000000"b,
     "001000000001"b,
     "001000000010"b,
     "001000000100"b,
     "001000000110"b,
     "001000001000"b,
     "001000001010"b,
     "001000010000"b,
     "001000010010"b,
     "001000100000"b,
     "001000100010"b,
     "001001000000"b,
     "001001000010"b,
     "001010000000"b,
     "001010000010"b,
     "001100000000"b,
     "010000000000"b,
     "010000000001"b,
     "010000000010"b,
     "010000000100"b,
     "010000000110"b,
     "010000001000"b,
     "010000001010"b,
     "010000010000"b,
     "010000010010"b,
     "010000100000"b,
     "010000100010"b,
     "010001000000"b,
     "010001000010"b,
     "010010000000"b,
     "010100000000"b,
     "011000000000"b,
     "100000000000"b,
     "100000000001"b,
     "100000000010"b,
     "100000000100"b,
     "100000000110"b,
     "100000001000"b,
     "100000001010"b,
     "100000010000"b,
     "100000010010"b,
     "100000100000"b,
     "100000100010"b,
     "100001000000"b,
     "100001000010"b,
     "100010000000"b,
     "100100000000"b,
     "101000000000"b
     );


/* character strings */

dcl  letter_table (0: 63) char (1) aligned init (
     " ",
     "9",
     "8",
     "7",
     "?",
     "6",
     ">",
     "5",
     ":",
     "4",
     "@",
     "3",
     "#",
     "2",
     "[",
     "1",
     "0",
     "z",
     "y",
     "x",
     "!",
     "w",
     """",
     "v",
     "=",
     "u",
     "%",
     "t",
     ",",
     "s",
     "_",						/* left arrow */
     "/",
     "-",
     "r",
     "q",
     "p",
     "'",
     "o",
     ";",
     "n",
     ")",
     "m",
     "*",
     "l",
     "$",
     "k",
     "j",
     "^",						/* up arrow */
     "&",
     "i",
     "h",
     "g",
     "\",
     "f",
     "<",
     "e",
     "(",
     "d",
     "]",
     "c",
     ".",
     "b",
     "a",
     "+"
     );


/* built in functions */

dcl (
     divide
     ) builtin;


/* masks */

dcl 1 columns aligned based (bit_ptr),			/* card columns */
    2 bin_char (0:79) bit (12) unaligned;		/* binary characters on card */

dcl 1 output aligned based (letter_ptr),		/* output character string */
    2 letter (0:79) char (1) unaligned;			/* each output character */

dcl  output_letters char (80) aligned based (letter_ptr);	/* for zapping characters in case of error */

/*  */

	a_code = 0;				/* initialize returned error code */
	bit_ptr = a_input_ptr;			/* copy in 2 pointer arguments */
	letter_ptr = a_output_ptr;

	do i = 0 to 79;				/* perform conversion */

	     if bin_char (i) = "0"b			/* make quick check for blank */
	     then letter (i) = " ";

	     else					/* binary character is not a blank */
	     do;

		direction = 1;			/* initialize 1/2 interval search variables */
		interval = 32;
		search_index = 0;
		bin_char_not_found = "1"b;

		do j = 1 to 6 while (bin_char_not_found); /* perform search */

		     search_index = search_index + direction * interval; /* set index */

		     if bin_char (i) = bin_table (search_index) /* match found */
		     then do;
			letter (i) = letter_table (search_index); /* set output letter */
			bin_char_not_found = "0"b;	/* turn off search flag */
		     end;

		     else				/* match not found */
		     do;				/* increment 1/2 interval search variables */
			if bin_char (i) > bin_table (search_index)
			then direction = 1;
			else
			direction = -1;
			interval = divide (interval, 2, 17, 0);
		     end;

		end;

		if bin_char_not_found		/* illegal binary character */
		then go to ERROR;

	     end;

	end;

	return;

ERROR:

	a_code = 1;				/* return error code */
	output_letters = " ";			/* zap output string */
	return;

     end cv_bin_to_ascii_;




		    cv_bin_to_bcd_.pl1              11/19/82  1409.3rew 11/19/82  0929.2       63072



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* ******************************************************************************
   *								*
   *	Modified by RH Morrison  6/28/76				*
   *								*
   ****************************************************************************** */

cv_bin_to_bcd_: proc (a_input_ptr, a_output_ptr, a_code);


/* DECLARATIONS */
/* ------------ */


/* fixed bin */

dcl (
     direction,					/* direction of half-interval search */
     i,						/* loop index */
     interval,					/* increment for half-interval search */
     j,						/* loop index */
     search_index					/* index into binary table */
     ) fixed bin aligned;

dcl (
     a_code					/* error code (argument) */
     ) fixed bin (35) aligned;


/* pointers */

dcl (
     a_input_ptr,					/* pointer to binary data (argument) */
     a_output_ptr,					/* pointer to bcd output (argument) */
     bcd_ptr,					/* pointer to internal bcd */
     input_ptr,					/* pointer to binary data (internal) */
     output_ptr					/* pointer to bcd output (internal) */
     ) ptr aligned;


/* bit strings */

dcl (
     bin_char_not_found				/* ON until bin_table search is successful */
     ) bit (1) aligned;


/* built  in functions */

dcl (
     addr,
     divide
     ) builtin;


/* structures */

dcl 1 bcd_chars aligned,				/* bcd output structure */
    2 bcd_char (0:79) bit (6) unaligned;

dcl  bcd_table (0:63) bit (6) aligned internal static init (
     "010000"b,					/* " " */
     "001001"b,					/* "9" */
     "001000"b,					/* "8" */
     "000111"b,					/* "7" */
     "001111"b,					/* "?" */
     "000110"b,					/* "6" */
     "001110"b,					/* ">" */
     "000101"b,					/* "5" */
     "001101"b,					/* ":" */
     "000100"b,					/* "4" */
     "001100"b,					/* "@" */
     "000011"b,					/* "3" */
     "001011"b,					/* "#" */
     "000010"b,					/* "2" */
     "001010"b,					/* "[" */
     "000001"b,					/* "1" */
     "000000"b,					/* "0" */
     "111001"b,					/* "z" */
     "111000"b,					/* "y" */
     "110111"b,					/* "x" */
     "111111"b,					/* "!" */
     "110110"b,					/* "w" */
     "111110"b,					/* """ */
     "110101"b,					/* "v" */
     "111101"b,					/* "=" */
     "110100"b,					/* "u" */
     "111100"b,					/* "%" */
     "110011"b,					/* "t" */
     "111011"b,					/* "," */
     "110010"b,					/* "s" */
     "111010"b,					/* "<-" */
     "110001"b,					/* "/" */
     "101010"b,					/* "-" */
     "101001"b,					/* "r" */
     "101000"b,					/* "q" */
     "100111"b,					/* "p" */
     "101111"b,					/* "'" */
     "100110"b,					/* "o" */
     "101110"b,					/* ";" */
     "100101"b,					/* "n" */
     "101101"b,					/* ")" */
     "100100"b,					/* "m" */
     "101100"b,					/* "*" */
     "100011"b,					/* "l" */
     "101011"b,					/* "$" */
     "100010"b,					/* "k" */
     "100001"b,					/* "j" */
     "100000"b,					/* "^" */
     "011010"b,					/* "&" */
     "011001"b,					/* "i" */
     "011000"b,					/* "h" */
     "010111"b,					/* "g" */
     "011111"b,					/* "\" */
     "010110"b,					/* "f" */
     "011110"b,					/* "<" */
     "010101"b,					/* "e" */
     "011101"b,					/* "(" */
     "010100"b,					/* "d" */
     "011100"b,					/* "]" */
     "010011"b,					/* "c" */
     "011011"b,					/* "." */
     "010010"b,					/* "b" */
     "010001"b,					/* "a" */
     "110000"b					/* "+" */
     );

dcl  bin_table (0: 63) bit (12) aligned internal static init (
     "000000000000"b,
     "000000000001"b,
     "000000000010"b,
     "000000000100"b,
     "000000000110"b,
     "000000001000"b,
     "000000001010"b,
     "000000010000"b,
     "000000010010"b,
     "000000100000"b,
     "000000100010"b,
     "000001000000"b,
     "000001000010"b,
     "000010000000"b,
     "000010000010"b,
     "000100000000"b,
     "001000000000"b,
     "001000000001"b,
     "001000000010"b,
     "001000000100"b,
     "001000000110"b,
     "001000001000"b,
     "001000001010"b,
     "001000010000"b,
     "001000010010"b,
     "001000100000"b,
     "001000100010"b,
     "001001000000"b,
     "001001000010"b,
     "001010000000"b,
     "001010000010"b,
     "001100000000"b,
     "010000000000"b,
     "010000000001"b,
     "010000000010"b,
     "010000000100"b,
     "010000000110"b,
     "010000001000"b,
     "010000001010"b,
     "010000010000"b,
     "010000010010"b,
     "010000100000"b,
     "010000100010"b,
     "010001000000"b,
     "010001000010"b,
     "010010000000"b,
     "010100000000"b,
     "011000000000"b,
     "100000000000"b,
     "100000000001"b,
     "100000000010"b,
     "100000000100"b,
     "100000000110"b,
     "100000001000"b,
     "100000001010"b,
     "100000010000"b,
     "100000010010"b,
     "100000100000"b,
     "100000100010"b,
     "100001000000"b,
     "100001000010"b,
     "100010000000"b,
     "100100000000"b,
     "101000000000"b
     );


/* masks */

dcl  bcd_output bit (480) unaligned based (bcd_ptr);	/* mask for copying bcd as a whole */

dcl  bin_char (0:79) bit (12) unaligned based (input_ptr);	/* mask for looking at binary input */

/*  */

/* copy in arguments */

	input_ptr = a_input_ptr;
	output_ptr = a_output_ptr;
	bcd_ptr = addr (bcd_chars);			/* pointer to internal bcd */

/* perform conversion */

	do i = 0 to 79;				/* convert 80 characters */

	     if bin_char (i) = "0"b			/* make quick check for blank */
	     then bcd_char (i) = "010000"b;

	     else					/* not binary blank */
	     do;

		direction = 1;			/* set up half-interval search */
		interval = 32;
		search_index = 0;
		bin_char_not_found = "1"b;

		do j = 1 to 6 while (bin_char_not_found);

		     search_index = search_index + direction*interval; /* compute index into binary table */

		     if bin_char (i) = bin_table (search_index) /* match found */
		     then do;
			bcd_char (i) = bcd_table (search_index); /* set bcd character */
			bin_char_not_found = "0"b;
		     end;

		     else				/* not a match */
		     do;
			if bin_char (i) > bin_table (search_index) /* set direction of search increment */
			then direction = 1;
			else direction = -1;
			interval = divide (interval, 2, 17, 0); /* set search increment magnitude */
		     end;

		end;

		if bin_char_not_found		/* no match found */
		then go to ERROR;			/* illegal binary character */

	     end;

	end;

	output_ptr -> bcd_output = bcd_output;		/* return output string */
	a_code = 0;				/* and "successful" code */

	return;					/* and your own self */

ERROR:

	a_code = 1;				/* return "unsuccessful" code */

	return;

     end cv_bin_to_bcd_;




		    gcos_convert_time_.pl1          11/19/82  1409.3rew 11/19/82  0929.3       39213



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


gcos_convert_time_: proc (a_gcos_time, a_deferral, a_code);


/* DECLARATIONS */
/* ------------ */


/* fixed bin */
/* ----- --- */

dcl (
     hundredth_length,				/* length of string representing converted hundredths */
     minutes,
     seconds
     ) fixed bin aligned;

dcl (
     a_code,					/* error code (argument) */
     code,					/* error code (internal) */
     fixed_bin_hundredths				/* converted hundredths of a second */
     ) fixed bin (35) aligned;

dcl (
     a_deferral,					/* multics deferral time (argument) */
     deferral					/* multics deferral time (internal) */
     ) fixed bin (71) aligned;


/* character strings */
/* --------- ------- */

dcl (
     ascii_hundredths				/* 100ths of an hr in ascii */
     ) char (4) aligned;

dcl (
     converted_hundredths				/* ascii 100ths converted to hh:mm */
     ) char (8) aligned;

dcl (
     a_gcos_time,					/* gcos date-time to be converted (argument) */
     gcos_time					/* gcos date-time to be converted (internal) */
     ) char (16) aligned;

dcl (
     multics_time					/* ascii multics time */
     ) char (32) aligned;


/* built in */
/* ----- -- */

dcl (
     divide,
     fixed,
     substr
     ) builtin;


/* external entries */
/* -------- ------- */

dcl  convert_date_to_binary_ ext entry
    (char (*) aligned, fixed bin (71) aligned, fixed bin (35) aligned);

dcl  cv_dec_check_ ext entry
    (char (*) aligned, fixed bin (35) aligned) returns (fixed bin (35) aligned);

dcl  ioa_$rsnnl ext entry
     options (variable);


/*  */

	gcos_time = a_gcos_time;			/* copy in argument */
	code = 0;					/* initialize error code */
	deferral = 0;				/* initialize deferral field */


/* convert MMDDYY to MM/DD/YY */

	multics_time = "";				/* blank out time field */
	substr (multics_time, 1, 2) = substr (gcos_time, 1, 2); /* month */
	substr (multics_time, 4, 2) = substr (gcos_time, 3, 2); /* day */
	substr (multics_time, 7, 2) = substr (gcos_time, 5, 2); /* year */
	substr (multics_time, 3, 1),
	substr (multics_time, 6, 1) = "/";		/* put slashes between fields */

/* pick up HH */

	substr (multics_time, 10, 2) = substr (gcos_time, 8, 2);
	substr (multics_time, 12, 1) = ":";

/* pick up MM or convert XX to MM */

	if substr (gcos_time, 10, 1) = ":"		/* gcos time given in minutes */
	then do;
	     substr (multics_time, 13, 2) = substr (gcos_time, 11, 2); /* just copy */
	     substr (multics_time, 15, 3) = ":00";	/* no seconds */
	end;

	else					/* gcos time in 100ths of an hour */
	do;

	     if substr (gcos_time, 10, 1) = "."		/* field is HH.XX */
	     then ascii_hundredths = substr (gcos_time, 11, 2);
	     else					/* field is HHXX */
	     ascii_hundredths = substr (gcos_time, 10, 2);

	     call convert_hundredths;			/* convert hundredths to ascii MM:SS */
	     if code ^= 0				/* error converting */
	     then go to RETURN;

	     substr (multics_time, 13, hundredth_length) = substr (converted_hundredths, 1, hundredth_length);

	end;

	call convert_date_to_binary_ (multics_time, deferral, code); /* convert date */

RETURN:	

	if code ^= 0				/* an error occurred */
	then code = 1 ;				/* return non-fatal error */

	a_deferral = deferral;			/* return deferred time */

	a_code = code;				/* return error code */

	return;

/*  */

convert_hundredths: proc;				/* internal procedure */

	     fixed_bin_hundredths = cv_dec_check_ (ascii_hundredths, code); /* convert to fixed bin */
	     if code ^= 0				/* error converting */
	     then return;

	     seconds = fixed (fixed_bin_hundredths*36, 17); /* convert to seconds */

	     minutes = divide (seconds, 60, 17, 0);	/* convert to minutes and seconds */
	     seconds = seconds - minutes*60;
	     call ioa_$rsnnl ("^d:^d", converted_hundredths, hundredth_length, minutes, seconds);

	     return;

	end convert_hundredths;

     end gcos_convert_time_;




		    gcos_daemon.pl1                 11/19/82  1409.3rew 11/19/82  0853.2      184203



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

%page;
/*

Modified:	Scott C. Akers	FEB 82	Add  'help' request, change action
				of  'return'  request to just quit
				out    of    Daemon   instead   of
				NEW_PROCing the user.

*/
%page;
gcos_daemon: proc;					/* MAIN ENTRY */


	call init_pointers;
	test_entry = "0"b;
	call default_handler_$set (standard_default_handler_); /* use standard fault handler */
	call gcos_daemon_init_ (fatal_error);
	go to COMMON;
%page;
/* TEST ENTRY */


test: entry;


/*
" N__a_m_e: test
" 
" The test entry  point  to  gcos_daemon
" allows  testing  of  the  daemon  from a private user process. It
" allows the user  to  specify  a  private  directory  (instead  of
" >ddd>GCOS) to be used as the root directory during testing.
" 
" U__s_a_g_e
"      gcos_daemon$test path
"        or
"      gcos_daemon$test control_arg
" 
" where:
"      1. path is the pathname of a root directory to  be  used  in
"         the test.
" 
"      2. control_arg  is  -wd  or  -working_dir  if  the   working
"         directory is to be used as the root directory.
" 
" N__o_t_e
" Prior  to  calling  this  entry point the following setup must be
" done for the root directory.  The gcos_user_table_ must be copied
" from >ddd>GCOS into the root directory.  Table entries must exist
" for the gcos_account_id, Multics Person_id and Multics Project_id
" which will be used in testing the gcos daemon.  See Appendix B of
" the GCOS Environment Simulator manual  AN05  for  information  on
" setting up the gcos_user_table_.
" 
" Next four subdirectories should be created in the root directory.
" They  are  "input_dir",  "pool_dir", "Anonymous", and "gdd".  The
" Access Control List for the subdirectories must include:
" 
"           sma       Anonymous.GCOS.*
" 
" and the Initial Access Control List for the  subdirectories  must
" include:
" 
"           rw        Anonymous.GCOS.*
" 
" Under  gdd  a  subdirectory  must  be  created and named with the
" Multics Project_id as specified in the  gcos_user_table_.   Under
" this  project  directory a subdirectory must be created and named
" with the Multics Person_id as specified in the  gcos_user_table_.
" This  person  directory  must  have  an Access Control List which
" includes:
" 
"           sma       Anonymous.GCOS.*
" 
" and an Initial Access Control List which includes:
" 
"           rw        Anonymous.GCOS.*
" 
*/

	call init_pointers;
	test_entry = "1"b;

	call cu_$arg_count (arg_count);
	if arg_count = 0 then do;
	     code = error_table_$noarg;
	     call com_err_ (code, "gcos_daemon$test",
		"^/Usage: gcos_daemon$test directory_name");
	     return;
	end;

	if arg_count > 1 then do;
	     code = error_table_$too_many_args;
	     call com_err_ (code, "gcos_daemon$test",
		"^/Usage: gcos_daemon$test directory_name");
	     return;
	end;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then do;
	     call com_err_ (code, "gcos_daemon$test");
	     return;
	end;

	if arg = "-wd" | arg = "-working_dir" then
	     abspath = get_wdir_ ();
	else if substr (arg, 1, 1) = "-"
	then do;
	     code = error_table_$badopt;
	     call com_err_ (code, "gcos_daemon$test", "^a", arg);
	     return;
	end;
	else do;
	     call absolute_pathname_ (arg, abspath, code);
	     if code ^= 0 then do;
		call com_err_ (code, "gcos_daemon$test",
		     "/^a", arg);
		return;
	     end;
	end;

	path_len = length (rtrim (abspath));

	gcos_daemon_stat_$default_home_dir = rtrim (abspath)||">Anonymous";
	gcos_daemon_stat_$home_root_dir = rtrim (abspath)||">gdd";
	gcos_daemon_stat_$input_dir = rtrim (abspath)||">input_dir";
	gcos_daemon_stat_$pool_dir = rtrim (abspath)||">pool_dir";
	gcos_daemon_stat_$root_dir = abspath;
	gcos_daemon_stat_$default_home_dir_len = path_len + length (">Anonymous");
	gcos_daemon_stat_$home_root_dir_len = path_len + length (">gdd");
	gcos_daemon_stat_$input_dir_len = path_len + length (">input_dir");
	gcos_daemon_stat_$pool_dir_len = path_len + length (">pool_dir");
	gcos_daemon_stat_$root_dir_len = path_len;

	call gcos_daemon_init_$gd_test (fatal_error);
	go to COMMON;



/* QUIT ENTRY */

quit_entry: entry;

	call init_pointers;
	call ios_$resetread ("user_i/o", status_stuff);
	code = status.code;
	if code ^= 0
	then do;
	     call com_err_ (code, "gcos_daemon", "Error resetting user_i/o");
	     go to GET_REQUEST;
	end;

	invocation_level = invocation_level + 1;	/* bump count of times called */
	go to SET_QUIT;


/* OVERFLOW ENTRIES */

overflow_handler: entry;

	call init_pointers;
	call ioa_ ("Record quota overflow:  Input for snumb ^a deleted", gcos_daemon_stat_$snumb);
	signal condition (goback);

abs_overflow_handler: entry;

	call init_pointers;
	call ioa_ ("******ATTENTION******^/Record quota overflow from absentee gcos job in^/^a",
	     gcos_daemon_stat2_$overflow_dir);
	return;
%page;
COMMON:	;
	if (fatal_error)
	then do;
	     call com_err_ (0, "gcos_daemon", "Fatal error encountered during initialization");
	     return;
	end;

	if (^init)				/* first time called */
	then do;
	     init = "1"b;				/* remember */
	     cleanup_return = CLEANUP_RETURN;		/* set internal static label */
	end;

	reader_is_attached = "0"b;

	input_dir = substr (gcos_daemon_stat_$input_dir, 1, gcos_daemon_stat_$input_dir_len);

/* run date deleter */

	if ^test_entry
	then do;
	     call hcs_$make_ptr (myp, "date_deleter", "date_deleter", ddp, code); /* get pointer to date_deleter */
	     if ddp = null				/* error getting pointer */
	     then call com_err_ (code, "gcos_daemon", "Error finding date deleter");
	     else					/* got pointer */
	     do dir_name = input_dir, substr (gcos_daemon_stat_$pool_dir, 1, gcos_daemon_stat_$pool_dir_len),
		     substr (gcos_daemon_stat_$default_home_dir, 1, gcos_daemon_stat_$default_home_dir_len);
		call ioa_$rsnnl ("^d", delete_interval, i, gcos_daemon_stat_$delete_interval); /* get time interval */
		call cu_$ptr_call (ddp, dir_name, delete_interval);
	     end;
	end;

/* set up condition handlers */

CLEANUP_RETURN:	;

	on condition (goback)
	     begin;

	     invocation_level = 0;			/* will bring daemon back to lowest invocation level */
	     call ioa_ ("Cleanup invoked");
	     go to cleanup_return;			/* pop stack back to first invocation level */

	end;

SET_QUIT:	;

	on condition (record_quota_overflow)
	     call gcos_daemon$overflow_handler;

	on condition (quit)
	     call gcos_daemon$quit_entry;

GET_REQUEST:	;

	request = " ";				/* blank out request line */

	call ioa_ ("ENTER REQUEST");			/* ask for a request */

NULL_REQUEST:	;

	call ios_$read_ptr (addr (request), 120, request_len); /* read the request */
	if request_len = 1				/* null request */
	then go to NULL_REQUEST;
%page;
	if substr (request, 1, 4) = "imcv"		/* request to read tape */
	then do;
	     call gcos_read_tape_ (request, request_len - 1, test_entry);
	     go to GET_REQUEST;
	end;
%page;
	else
	if substr (request, 1, 6) = "attach"		/* request to attach card reader */
	then do;

	     if (reader_is_attached)			/* card reader already attached */
	     then call com_err_ (0, "gcos_daemon", "Card reader already attached");

	     else					/* card reader not yet attached */
	     do;
		call ios_$attach ("card_input", gcos_daemon_stat_$card_dim, "rdra", "", status_stuff);
		code = status.code;
		if code ^= 0
		then do;
		     call com_err_ (code, "gcos_daemon", "Error attaching card reader");
		     go to GET_REQUEST;
		end;
		else
		reader_is_attached = "1"b;
	     end;

	end;
%page;
	else
	if substr (request, 1, 4) = "read"		/* request to block on card reader */
	then do;

	     if (^reader_is_attached)			/* card reader isn't attached yet */
	     then do;
		call com_err_ (0, "gcos_daemon", "Card reader is not attached");
		go to GET_REQUEST;
	     end;

	     else do;				/* reader is attached, prepare to read */
		code = 0;
		eof_found = "0"b;
		do   while (code = 0 & ^eof_found);
		     call gcos_read_cards_ ("card_input", test_entry, eof_found, code); /* pass request on */
		     end;
		end;
	     end;
%page;
	else
	if substr (request, 1, 5) = "abort"		/* request to abort current job */
	then do;

	     if invocation_level = 0			/* at lowest invocation level */
	     then do;
		call ioa_ ("You are at command level");
		go to GET_REQUEST;
	     end;

	     signal condition (goback);

	end;
%page;
	else
	if substr (request, 1, 6) = "detach"		/* request to detach card reader */
	then do;

	     if (^reader_is_attached)			/* reader is not attached */
	     then do;
		call com_err_ (0, "gcos_daemon", "Card reader is not attached");
		go to GET_REQUEST;
	     end;

	     call detach;				/* detach card reader */
	     if code = 0				/* successful detach */
	     then reader_is_attached = "0"b;

	end;
%page;
	else
	if substr (request, 1, 7) = "re_init"		/* request to re-initialize process */
	then do;

RE_INIT:	;
	     if (reader_is_attached)			/* card reader is attached */
	     then call detach;

	     call new_proc;				/* create a new process */

	end;
%page;
	else
	if substr (request, 1, 6) = "logout"		/* request to log process out */
	then do;

	     if (reader_is_attached)			/* card reader is attached */
	     then call detach;

	     call logout;				/* log daemon out */

	end;
%page;
	else
	if substr (request, 1, 5) = "admin"		/* request to enter admin mode */
	then do;

	     on quit system;			/* take away control of quits */
	     revert condition (record_quota_overflow);	/* and record quota overflows */
	     call user_info_ (name, project, account);
	     if project = "SysDaemon"
	     then do;
		call hcs_$initiate (
		     substr (gcos_daemon_stat_$sysdir, 1, gcos_daemon_stat_$sysdir_len),
		     "communications", "", 0, 1, com_p, code);
		if com_p ^= null then do;
		     if communications.admin_word = "*" then go to enter_admin;
		     call ioa_ ("Password:");
		     call iox_$control (iox_$user_io, "printer_off", null, ioxcode);
		     call iox_$get_line (iox_$user_io, addr (request), 120, i, ioxcode);
		     call iox_$control (iox_$user_io, "printer_on", null, ioxcode);
		     w_password = substr (request, 1, i-1); /* Get password. */
		     if w_password = communications.admin_word then go to enter_admin;
		     call com_err_ (0, "gcos_daemon", "password incorrect");
		     go to xadmin;
		end;
		else call com_err_ (code, "gcos_daemon", "Error in initiating communications segment");
	     end;

enter_admin:   ;
	     call enter_admin_mode_ ();		/* Call Multics listener. */

xadmin:	     ;					/* Get here on "ame" command. */
	     call change_wdir_ (input_dir, code);	/* make sure in proper dir */
	     if code ^= 0				/* can't do it */
	     then call com_err_ (code, "gcos_daemon", "Error changing to ^a", input_dir);
	     go to SET_QUIT;

	end;
%page;
	else
	if substr (request, 1, 3) = "smq"		/* request to reset maximum queue priority */
	then do;

	     code = 0;				/* prevents spurious message printing */
	     i = index (request, " ");		/* find first blank in request */

	     if i > request_len			/* no blank: no second argument */
	     then do;
NO_QUEUE:	;
		call com_err_ (0, "gcos_daemon", "Missing or invalid queue number in smq request");
		go to GET_REQUEST;
	     end;

	     do j = i to request_len while		/* find beginning of argument */
		     (substr (request, j, 1) = " ");
	     end;
	     if j > request_len			/* no second argument */
	     then go to NO_QUEUE;

	     max_queue = cv_dec_check_ (substr (request, j, request_len-j), code);
	     if code ^= 0				/* invalid queue specification */
	     then go to NO_QUEUE;

	     call gcos_queue_job_$set_priority (max_queue);

	end;
%page;
	else
	if substr (request, 1, 5) = "start"		/* request to return from quit */
	then do;

	     if invocation_level = 0			/* at lowest level */
	     then do;
		call ioa_ ("You are at command level");
		go to GET_REQUEST;
	     end;
	     invocation_level = invocation_level - 1;	/* decrement count of stacked invocations */
	     return;				/* and return */
	end;
%page;
	else
	if substr (request, 1, 6) = "return"		/* request to return to command level */
	then do;

	     if (^test_entry)			/* not allowed for daemon itself */
	     then go to NOT_RECOGNIZED;

	     goto ALL_DONE;

	end;
%page;
	else
	if substr (request, 1, 1) = "."		/* user wants to know who he is */
	then call ioa_ ("gcos_daemon");
%page;
	else if   substr (request, 1, 1) = "?"
	        | substr (request, 1, 4) = "help"
	then call ioa_ (  "^/REQUEST^-DESCRIPTION"
		      ||"^2/abort^-Abort current job"
		      ||"^/admin^-Enter 'admin' mode"
		      ||"^/attach^-Attach the card reader"
		      ||"^/detach^-Detach the card reader"
		      ||"^/help^-Print this list"
		      ||"^/imcv^-Read from tape"
		      ||"^/logout^-Log out the Daemon"
		      ||"^/read^-Read from the card reader"
		      ||"^/return^-Return to command level"
		      ||"^/^-(test entry only)"
		      ||"^/re_init^-Reinitialize the Daemon"
		      ||"^/smq N^-Set max priority abs queue for Daemon to N"
		      ||"^/^-(Default is 1)"
		      ||"^/start^-Restart from QUIT"
		      ||"^/.^-Tell Daemon to identify itself"
		      ||"^/?^-Print this list"
		      ||"^/");
%page;
	else					/* request not recognized */

NOT_RECOGNIZED:

	call com_err_ (0, "gcos_daemon", "Unrecognized request:^-^a", request);

	go to GET_REQUEST;
%page;
/* INTERNAL PROCEDURES */


detach:	proc;					/* procedure to detach devices */

	     call ios_$detach ("card_input", "rdra", "", status_stuff);
	     code = status.code;
	     if code ^= 0
	     then call com_err_ (code, "gcos_daemon", "Error detaching card reader");
	     return;
	end detach;


init_pointers: proc;
	     myp = addr (gcos_daemon$);		/* pointer to this proc */
	     sp = addr (status_stuff);		/* overlay pointer for ios_ status */
	     return;
	end init_pointers;
%page;
ALL_DONE: ;

	return;					/* Bail out from the Daemon. */
%page;
/* fixed bin */
/* ----- --- */

dcl (
     gcos_daemon_stat_$default_home_dir_len ext,		/* length of default home dir name */
     gcos_daemon_stat_$delete_interval ext,		/* days afted which to delete segment */
     gcos_daemon_stat_$input_dir_len ext,		/* length of input directory name */
     gcos_daemon_stat_$pool_dir_len ext,		/* length of pool dir name */
     gcos_daemon_stat_$sysdir_len ext,			/* length of sysdir name */
     gcos_daemon_stat_$home_root_dir_len ext,		/* length of home root dir name */
     gcos_daemon_stat_$root_dir_len ext,		/* length of root dir name */
     i,						/* random variable */
     invocation_level int static init (0),		/* number of stacked calls to quit entry */
     j,						/* random variable */
     max_queue,					/* maximum priority queue for absentee, output */
     arg_count,					/* total number of args in cmd line */
     arg_len,					/* size in chars of last arg retrieved with cu_$arg_ptr */
     path_len,					/* length of root dir name specified by gcos_test entry */
     request_len					/* length of request typed by operator */
     ) fixed bin aligned;

dcl (
     ioxcode,					/* error code from iox */
     code,					/* error code */
     error_table_$noarg ext,
     error_table_$too_many_args ext,
     error_table_$badopt ext
     ) fixed bin (35) aligned;
%page;
/* bit strings */
/* --- ------- */

dcl (
     fatal_error,					/* ON when fatal error occurs during initialization */
     eof_found,					/* ON when eof is found reading cards */
     init int static init ("0"b),			/* internal static initialization switch */
     reader_is_attached int static,			/* ON when card reader is attached */
     test_entry int static				/* ON when called by user */
     ) bit (1) aligned;

dcl (
     status_stuff					/* return location for ios_ status */
     ) bit (72) aligned;
%page;
/* character strings */
/* --------- ------- */

dcl (
     gcos_daemon_stat_$snumb ext
     ) char (6) aligned;

dcl (
     w_password,					/* Password for entering admin mode. */
     delete_interval init (""),			/* days after which to delete segment */
     gcos_daemon_stat_$card_dim ext			/* variable dim name for debugging */
     ) char (8) aligned;

dcl (
     name,					/* name returned by user_info_ */
     project,					/* project returned by user_info_ */
     account					/* account returned by user_info_ */
     ) char (32) aligned;

dcl (
     request					/* request from operator */
     ) char (120) aligned;

dcl (
     dir_name,					/* loop dir name */
     gcos_daemon_stat2_$overflow_dir ext,
     gcos_daemon_stat_$default_home_dir ext,		/* default home dir for absentee jobs */
     gcos_daemon_stat_$input_dir ext,			/* input directory name */
     gcos_daemon_stat_$pool_dir ext,			/* pool directory name */
     gcos_daemon_stat_$sysdir ext,			/* sysdir directory name */
     gcos_daemon_stat_$home_root_dir ext,		/* home root dir name */
     gcos_daemon_stat_$root_dir ext,			/* root dir name */
     input_dir internal static			/* input directory name (internal) */
     ) char (168) aligned;

dcl  abspath char (168);				/* absolute path for root dir given by gcos_test entry */
%page;
/* pointers */
/* -------- */

dcl (
     arg_ptr,					/* returned by cu_$arg_ptr */
     com_p,					/* pointer to sc1>communications */
     iox_$user_io ext,
     ddp,						/* pointer to date_deleter proc */
     myp,						/* pointer to this proc */
     sp						/* overlay pointer for ios_ status */
     ) pointer aligned;
%page;
/* built in functions */
/* ----- -- --------- */

dcl (
     addr,
     index,
     null,
     substr
     ) builtin;
%page;
/* masks */
/* ----- */

dcl  arg char (arg_len) based (arg_ptr);

dcl 1 status aligned based (sp),			/* return status from ios_ */
    2 code fixed bin (35);				/* error code portion */

/* labels */
/* ------ */

dcl (
     cleanup_return
     ) label int static;


/* conditions */
/* ---------- */

dcl (
     goback,
     quit,
     record_quota_overflow
     ) condition;
%page;
/* entries */
/* ------- */

dcl  change_wdir_ ext entry (char (168) aligned, fixed bin (35) aligned);
dcl  com_err_ ext entry options (variable);
dcl  cu_$ptr_call ext entry options (variable);
dcl  cv_dec_check_ ext entry (char (*), fixed bin (35) aligned) returns (fixed bin aligned);
dcl  default_handler_$set ext entry (entry);
dcl  enter_admin_mode_ ext entry;
dcl  gcos_daemon$ entry;
dcl  gcos_daemon$overflow_handler ext entry;
dcl  gcos_daemon$quit_entry ext entry;
dcl  gcos_daemon_init_ ext entry (bit (1) aligned);
dcl  gcos_daemon_init_$gd_test ext entry (bit (1) aligned);
dcl  gcos_queue_job_$set_priority ext entry (fixed bin aligned);
dcl  gcos_read_cards_ ext entry (char (12) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35) aligned);
dcl  gcos_read_tape_ ext entry (char (120) aligned, fixed bin aligned, bit (1) aligned);
dcl  hcs_$make_ptr ext entry (ptr aligned, char (*), char (*), ptr aligned, fixed bin (35) aligned);
dcl  ioa_ ext entry options (variable);
dcl  ioa_$rsnnl ext entry options (variable);
dcl  ios_$attach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);
dcl  ios_$detach ext entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);
dcl  ios_$read_ptr ext entry (ptr aligned, fixed bin aligned, fixed bin aligned);
dcl  ios_$resetread ext entry (char (*) aligned, bit (72) aligned);
dcl  logout ext entry;
dcl  new_proc ext entry;
dcl  standard_default_handler_ ext entry;
dcl  user_info_ ext entry (char (*) aligned, char (*) aligned, char (*) aligned);
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  get_wdir_ entry returns (char (168));
%page;
%include communications;

end gcos_daemon;




		    gcos_daemon_init_.pl1           11/19/82  1409.3rew 11/19/82  0929.5       78768



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* ******************************************************************************
   *								*
   *	Written by  P. Haber					*
   *	Modified by  R.H. Morrison	March,1975			*
   *								*
   ****************************************************************************** */


gcos_daemon_init_: proc (fatal_error);

/* DECLARATIONS */
/* ------------ */

dcl (
     gcos_daemon$abs_overflow_handler ext		/* bypass compiler problem */
     ) fixed;



/* fixed bin */
/* ----- --- */

dcl (
     mode						/* access to directory */
     ) fixed bin (5) aligned;

dcl (
     rbs (3) init (5, 5, 5)				/* ring brackets for append call */
     ) fixed bin (6) aligned;

dcl (
     gcos_daemon_stat_$anonymous_user_len ext,
     gcos_daemon_stat_$default_home_dir_len ext,
     gcos_daemon_stat_$input_dir_len ext,
     gcos_daemon_stat_$max_priority ext,
     gcos_daemon_stat_$pool_dir_len ext,
     gcos_daemon_stat_$root_dir_len ext,
     i						/* loop index */
     ) fixed bin aligned;

dcl (
     code,					/* error code */
     error_table_$namedup ext
     ) fixed bin (35) aligned;

dcl (
     channel_name,					/* name of created event channel */
     gcos_daemon_stat_$overflow_channel ext
     ) fixed bin (71) aligned;

/* pointers */
/* -------- */

dcl (
     aclp,					/* pointer to acl data */
     sp						/* pointer to return status from ios_ calls */
     ) ptr aligned;

/* bit strings */
/* --- ------- */

dcl (
     fatal_error					/* ON if fatal error encountered during initialization */
     ) bit (1) aligned;

dcl (
     gcos_daemon_stat_$process_id ext			/* process id of gcos daemon */
     ) bit (36) aligned;

dcl (
     status_stuff					/* returned status from ios_ calls */
     ) bit (72) aligned;

/* character strings */
/* --------- ------- */

dcl (
     gcos_daemon_stat_$snumb ext
     ) char (6) aligned;

dcl (
     account,					/* user's account */
     en,						/* entry portion of dir name */
     gcos_daemon_stat_$anonymous_user ext,		/* name of anonymous user */
     group_id,					/* from get_group_id */
     name,					/* user's name */
     project					/* user's project */
     ) char (32) aligned;


dcl (
     dn,						/* dir portion of directory */
     gcos_daemon_stat_$default_home_dir ext,
     gcos_daemon_stat_$input_dir ext,
     gcos_daemon_stat_$pool_dir ext,
     gcos_daemon_stat_$root_dir ext,
     dir_name
     ) char (168) aligned;

/* masks */
/* ----- */

dcl 1 status aligned based (sp),			/* mask for ios_ status */
    2 code fixed bin (35);				/* code portion */

/* structures */
/* ---------- */

dcl 1 dir_acl (2) aligned,				/* for possible call to add_dir_acl */
    2 access_name char (32) aligned,
    2 dir_modes bit (36) aligned,
    2 a_code fixed bin (35) aligned;


/* built-in */
/* -------- */

dcl (
     addr,
     null,
     substr
     ) builtin;

/* conditions */

dcl (
     quit
     ) condition;


/* external entries */
/* -------- ------- */

dcl  change_wdir_ ext entry
    (char (168) aligned, fixed bin (35) aligned);

dcl  com_err_ ext entry
     options (variable);

dcl  expand_path_ ext entry
    (ptr aligned, fixed bin aligned, ptr aligned, ptr aligned, fixed bin (35) aligned);

dcl  gcos_daemon_init_$early_quit ext entry;

dcl  get_group_id_$tag_star ext entry
     returns (char (32) aligned);

dcl  get_process_id_ ext entry
     returns (bit (36) aligned);

dcl  hcs_$add_dir_acl_entries ext entry
    (char (*) aligned, char (*) aligned, ptr aligned, fixed bin aligned, fixed bin (35) aligned);

dcl  hcs_$append_branchx ext entry
    (char (*) aligned, char (*) aligned, fixed bin (5) aligned, (3) fixed bin (6) aligned, char (*) aligned,
     fixed bin (1) aligned, fixed bin (1) aligned, fixed bin (24) aligned, fixed bin (35) aligned);

dcl  hcs_$get_user_effmode ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin aligned, fixed bin (5) aligned,
     fixed bin (35) aligned);

dcl  ioa_ ext entry
     options (variable);

dcl  ios_$resetread ext entry
    (char (*) aligned, bit (72) aligned);

dcl  ios_$order ext entry
    (char (*) aligned, char (*) aligned, ptr aligned, bit (72) aligned);

dcl  ipc_$create_ev_chn ext entry
    (fixed bin (71) aligned, fixed bin (35) aligned);

dcl  ipc_$decl_ev_call_chn ext entry
    (fixed bin (71) aligned, ptr aligned, ptr aligned, fixed bin aligned, fixed bin (35) aligned);

dcl  user_info_ ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned);

/*  */

	call user_info_ (name, project, account);	/* determine callers' project */
	if name ^= "GCOS"|
	project ^= "SysDaemon"			/* not being called by init_admin_ */
	then do;					/* caller should use test entry */
	     call com_err_ (0, "gcos_daemon_init_", "Use test entry");
	     fatal_error = "1"b;
	     return;
	end;

gd_test:	entry (fatal_error);			/* entry for testing from user process */
	call init_pointers;
	on condition (quit)
	     call gcos_daemon_init_$early_quit;

	call ios_$order ("user_i/o", "quit_enable", null, status_stuff);
	if status.code ^= 0
	then do;
	     call com_err_ (status.code, "gcos_daemon_init_", "Order call to enable quits");
	     fatal_error = "1"b;
	     return;
	end;

	fatal_error = "0"b;				/* initialize argument */

	group_id = get_group_id_$tag_star ();		/* get user name */

	dir_acl (1).access_name = group_id;		/* fill in acl structure for calls */
	dir_acl (2).access_name = substr (gcos_daemon_stat_$anonymous_user, 1, gcos_daemon_stat_$anonymous_user_len);
	do i = 1 to 2;
	     dir_acl (i).dir_modes = "111000000000000000000000000000000000"b;
	end;

	do dir_name = substr (gcos_daemon_stat_$root_dir, 1, gcos_daemon_stat_$root_dir_len),
		substr (gcos_daemon_stat_$pool_dir, 1, gcos_daemon_stat_$pool_dir_len),
		substr (gcos_daemon_stat_$default_home_dir, 1, gcos_daemon_stat_$default_home_dir_len),
		substr (gcos_daemon_stat_$input_dir, 1, gcos_daemon_stat_$input_dir_len);

	     do i = 168 to 1 by -1 while (substr (dir_name, i, 1) = " ");
	     end;

	     call expand_path_ (addr (dir_name), i, addr (dn), addr (en), code);
	     if code ^= 0
	     then go to END_LOOP;

	     call hcs_$append_branchx (dn, en, 01011b, rbs, group_id, 1, 0, 0, code);
	     if code ^= 0
	     then if code ^= error_table_$namedup	/* returned if dir already exists */
		then go to END_LOOP;

	     do i = 1 to 2;				/* init return code */
		dir_acl (i).a_code = 0;
	     end;

	     call hcs_$add_dir_acl_entries (dn, en, aclp, 2, code); /* set minimum acl */
	     if code ^= 0				/* error setting acl */
	     then if code ^= error_table_$namedup	/* returned if all names are on acl */
		then go to END_LOOP;

	end;

END_LOOP:

	if code = 0				/* access on dirs okay */
	then call change_wdir_ (dir_name, code);	/* switch to input dir */

	if code ^= 0				/* an error occurred in checking or switching to dir */
	then do;
	     call com_err_ (code, "gcos_daemon_init_", dir_name);
	     fatal_error = "1"b;
	end;

	gcos_daemon_stat_$snumb = "";			/* initialize current snumb */

	call ipc_$create_ev_chn (channel_name, code);	/* create channel to signal quota overflows */
	if code ^= 0
	then do;
	     call com_err_ (code, "gcos_daemon_init_", "Error creating event channel");
	     fatal_error = "1"b;
	     return;
	end;

	call ipc_$decl_ev_call_chn (channel_name, addr (gcos_daemon$abs_overflow_handler), null, 0, code);
	if code ^= 0
	then do;
	     call com_err_ (code, "gcos_daemon_init_", "Error converting event channel to call channel");
	     fatal_error = "1"b;
	     return;
	end;

	gcos_daemon_stat_$overflow_channel = channel_name;

	gcos_daemon_stat_$process_id = get_process_id_ ();

	gcos_daemon_stat_$max_priority = 1;

	return;

/*  */

early_quit: entry;

	call init_pointers;
	call ios_$resetread ("user_i/o", status_stuff);
	code = status.code;
	if code ^= 0
	then do;
	     call com_err_ (code, "gcos_daemon_init_", "Error resetting user_i/o");
	     fatal_error = "1"b;
	     return;
	end;

	call ioa_ ("QUIT^/START");
	return;
						/*  */
						/* INTERNAL PROCEDURES */

init_pointers: proc;
	     aclp = addr (dir_acl (1).access_name);	/* pointer to acl data */
	     sp = addr (status_stuff);		/* pointer to return status from ios_ calls */
	     return;
	end init_pointers;

     end gcos_daemon_init_;




		    gcos_daemon_temp_.pl1           11/19/82  1409.3rew 11/19/82  0929.6       41193



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


gcos_daemon_temp_: proc;

/* DECLARATIONS */
/* ------------ */


/* fixed bin */

dcl (
     fixed_bin2					/* variable from callers' star_ call passed on */
     ) fixed bin (2) aligned;

dcl (
     a_ecount,					/* number of entries corresponding to segment_name (argument) */
     ecount					/* number of entries corresponding to segment_name (internal) */
     ) fixed bin aligned;

dcl (
     a_code,					/* error code (argument) */
     code,					/* error code (internal) */
     error_table_$nomatch ext
     ) fixed bin (35) aligned;


/* pointers */

dcl (
     freep int static,				/* pointer to system free area */
     ptr1,					/* dummy arguments */
     ptr2,
     ptr3,
     ptr4,
     ptr5,
     sp						/* mask pointer for status from ios_ */
     ) ptr aligned;


/* bit strings */

dcl (
     init int static init ("0"b)			/* ON once system free area is called */
     ) bit (1) aligned;

dcl (
     a_status_stuff,				/* returned status from ios_ (argument) */
     status_stuff					/* returned status from ios_ (internal) */
     ) bit (72) aligned;


/* character strings */

dcl (
     a_stream_name,					/* stream name (argument) */
     stream_name					/* stream name (internal) */
     ) char (12) aligned;

dcl (
     a_segment_name,				/* star name (argument) */
     segment_name					/* star name (internal) */
     ) char (32) aligned;

dcl (
     a_dir_name,					/* directory being searched for names (argument) */
     dir_name					/* directory being searched for names (internal) */
     ) char (168) aligned;


/* built in */

dcl (
     addr,
     null
     ) builtin;


/* masks */

dcl 1 status aligned based (sp),			/* for interpreting status from ios_ */
    2 code fixed bin aligned;


/* external entries */

dcl  freen_ ext entry
    (ptr aligned);

dcl  get_system_free_area_ ext entry
     returns (ptr aligned);

dcl  hcs_$star_ ext entry
    (char (*) aligned, char (*) aligned, fixed bin (2) aligned, ptr aligned, fixed bin aligned, ptr aligned,
     ptr aligned, fixed bin (35) aligned);

dcl  ios_$attach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$detach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

/*  */

star_:	entry (a_dir_name, a_segment_name, fixed_bin2, ptr1, a_ecount, ptr2, ptr3, a_code);

/* This entry simulates a star handler which returns a count of the entries corresponding to
   only the star name if ptr1 is null.  The current star handler returns a count of all the
   entries in the directory */


	sp = addr (status_stuff);			/* mask pointer for status from ios_ */

	if ^init					/* first time proc called */
	then do;
	     freep = get_system_free_area_ ();		/* get pointer to system free area */
	     init = "1"b;				/* remember you've been called */
	end;

	dir_name = a_dir_name;			/* copy in arguments */
	segment_name = a_segment_name;

	call hcs_$star_ (dir_name, segment_name, fixed_bin2, freep, ecount, ptr4, ptr5, code);
						/* make a call to current star_ */

	if ptr4 ^= null				/* free any allocation */
	then call freen_ (ptr4);
	if ptr5 ^= null
	then call freen_ (ptr5);

	if code = error_table_$nomatch		/* no entries with star name */
	then do;
	     code = 0;				/* return sensible variables */
	     ecount = 0;
	end;

	a_code = code;				/* return arguments */
	a_ecount = ecount;

	return;

/*  */

resetread: entry (a_stream_name, a_status_stuff);

/* This function simulates a currently missing function in the card reader dim: resetread.
   It does this by first detaching, then reattaching the card reader */

	sp = addr (status_stuff);			/* mask pointer for status from ios_ */

	stream_name = a_stream_name;			/* copy in argument */

	call ios_$detach (stream_name, "rdra", "", status_stuff); /* detach the card reader */
	if status.code = 0				/* detach o.k. */
	then call ios_$attach (stream_name, "rdr21", "rdra", "", status_stuff); /* reattach it */

	a_status_stuff = status_stuff;		/* return status */

	return;

     end gcos_daemon_temp_;




		    gcos_queue_job_.pl1             08/01/88  1051.0r w 08/01/88  1029.5      169938



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* ****************************************************************************************

   This procedure maps data from the gcos daemon absentee data structure (currently
   gcos_abs_data) into the absentee structure used as the absentee message format
   (currently abs_message_format) and then queues a gcos job by calling a message
   segment primitive (currently message_segment_$add_file)

   Arguments are
   1) -- a_data_ptr	A pointer to the gcos daemon created absentee data (Input).
   2) -- a_code	An error code (Output).


   WRITTEN BY:	P. Haber		March 21, 1974
   MODIFIED BY:	R.H. Morrison	August 19, 1974
   March 1975	July 21, 1975

   Modified by T. Casey, May 1978, To use version 4 absentee request structure.
   Modified by S. Akers, Mar 1982, To make a neater absin seg and check for 
			     duplicate SNUMBs. Also to use
			     gcos_daemon_stat_$snumb instead of passing
			     the SNUMB as an argument to all and sundry.
   Modified by R. Barstad  August 1982  Fixed gcos job absin where last line
                                        of absin deleted itself.

   **************************************************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-03-01,Gilcrease), approve(86-03-17,MCR7370),
     audit(86-06-25,Lippard), install(86-06-30,MR12.0-1082):
     Update version to 5 in abs_message_format. SCP6297.
  2) change(87-07-27,GDixon), approve(87-07-27,MCR7741),
     audit(87-07-28,Hartogs), install(87-08-04,MR12.1-1055):
      A) Include user_abs_attributes.incl.pl1 to accommodate change made to
         abs_message_format.incl.pl1
  3) change(88-02-12,Parisek), approve(88-02-12,MCR7849),
     audit(88-03-23,Lippard), install(88-07-13,MR12.2-1047):
     Reference version 6 abs_message_format structure.
                                                   END HISTORY COMMENTS */


%page;
gcos_queue_job_: proc (a_data_ptr, a_test_entry, a_code);

/* PER PROCESS INITIALIZATION */

	call setup;				/* initialize automatics */
	if ^init					/* first time called */
	then do;

	     call hcs_$make_seg ("", "gcos_abs_temp_", "", 01011b, temp_ptr, code); /* create temporary in pdir */
	     if temp_ptr = null			/* error creating temporary */
	     then do;
		call com_err_ (code, "gcos_queue_job_", "Error creating temporary segment");
		go to RETURN;
	     end;

	     input_dir = substr (gcos_daemon_stat_$input_dir, 1, gcos_daemon_stat_$input_dir_len); /* set input_dir name */
	     sysdir = substr (gcos_daemon_stat_$sysdir, 1, gcos_daemon_stat_$sysdir_len); /* and sysdir name */

	     call hcs_$initiate (sysdir, "whotab", "", 0, 0, stat_whoptr, code); /* initiate who table */
	     if stat_whoptr = null			/* error initiating table */
	     then do;
		call com_err_ (code, "gcos_queue_job_", "Error initiating who_table");
		go to RETURN;
	     end;

	     init = "1"b;				/* initialization finished */

	end;

%page;

	on condition (cleanup)			/* establish cleanup handler */
	     call error_wrap_up;

	call hcs_$truncate_seg (temp_ptr, 0, code);	/* make sure it's empty for this call */
	if code ^= 0				/* error truncating */
	then do;
	     call com_err_ (code, "gcos_queue_job_", "Error truncating temporary");
	     go to RETURN;
	end;

/* initializations */

	code = 0;
	abs_data_ptr = a_data_ptr;
	whoptr = stat_whoptr;
	reqp = temp_ptr;
%page;
/* MAP ABSENTEE DATA */

	request.request_version = abs_message_version_6;	/* version number */
	request.hdr_version = queue_msg_hdr_version_1;

	char32 = get_group_id_ ();			/* submitters'  name (gcos daemon) & length */
	group_id_len = length (rtrim (char32));
	request.len_name = group_id_len;
	request.name = substr (char32, 1, group_id_len);
	absentee_dir_len = length (rtrim (abs_data.absentee_dir));
	request.dirname = substr (abs_data.absentee_dir, 1, absentee_dir_len);
	request.ename = rtrim (gcos_daemon_stat_$snumb)||".absin";

	request.arg_count = 0;			/* argument count */
	request.arg_lengths = 0;			/* argument length */
	request.len_args = 0;			/* argument string lengths */
	request.len_resource = 0;			/* resource length */
	request.len_sender = 0;			/* sender userid length */
	request.len_comment = 0;			/* comment string length */
	request.len_vpad = 0;			/* spare variable length */
	unique_snumb  =  rtrim (gcos_daemon_stat_$snumb)
		     ||"_"
		     ||unique_chars_ (unique_bits_ ()); /* make SNUMB unique */
	unique_snumb_len = length (rtrim (unique_snumb));	/* compute its length */

	if unique_snumb_len > 18 then			/* if unique SNUMB too long, shorten it */
	     do;					/* retain low order characters
						/* of unique_chars_ & the "!" */

	     snumb_len = length (rtrim (gcos_daemon_stat_$snumb));
	     unique_snumb = substr (unique_snumb, 1, snumb_len+2)
		||substr (unique_snumb, snumb_len+3 + unique_snumb_len-18);
	     unique_snumb_len = 18;
	end;

	request.len_output = absentee_dir_len + unique_snumb_len + 8; /* output path-name and length */
	request.output_file =
	     substr (abs_data.absentee_dir, 1, absentee_dir_len)||">"||rtrim (unique_snumb)||".absout";

	request.abs_attributes.user_deferred_until_time =
	     abs_data.absentee_options.deferral_switch;	/* deferral time */
	if abs_data.absentee_options.deferral_switch	/* one has been specified */
	then request.deferred_time = abs_data.absentee_data.deferral;
	else					/* no deferred time specified */
	request.deferred_time = 0;

	user_name_len = length (rtrim (abs_data.user_name));
	request.len_proxy = user_name_len;
	request.proxy_name = substr (abs_data.user_name, 1, user_name_len);
	request.abs_attributes.proxy = "1"b;

	request.max_cpu_time = gcos_daemon_stat_$max_cpu_time; /* max cpu time */

	request.set_bit_cnt = "0"b;			/* don't set bit count after every write */

	request.abs_attributes.restartable = "1"b;	/* gcos jobs are restartable */
						/* Defaults for version 6 stuff */
	request.initial_ring = -1;
	request.len_homedir = 0;
	request.len_initproc = 0;
	
	call user_info_$authorization_range (authrng);
	request.requested_authorization = authrng (1);	/* use the low range */

	request.std_length = currentsize (request);	/* store request's word length in its header */
	message_bit_count = request.std_length * 36;	/* remember its bitcount for later */

%page;

/* CREATE ABSIN FILE */

	call hcs_$make_seg (abs_data.absentee_dir, rtrim (gcos_daemon_stat_$snumb)||".absin", "", 01011b,
	     absin_ptr, code);			/* make segment "snumb.absin" */
	if absin_ptr = null				/* error creating "snumb.absin" */
	then do;
	     call com_err_ (code, "gcos_queue_job_", "Error creating ^a>^a.absin",
		abs_data.absentee_dir, gcos_daemon_stat_$snumb);
	     go to RETURN;
	end;

	call hcs_$set_ring_brackets (abs_data.absentee_dir, rtrim (gcos_daemon_stat_$snumb)||".absin",
	     rb, code);				/* set ring brackets */
	if code ^= 0 then
	     do; call com_err_ (code, "gcos_queue_job_", "Error setting ring brackets for ^a>^a.absin",
		abs_data.absentee_dir, gcos_daemon_stat_$snumb);
	     go to RETURN;
	end;

	call ioa_$rsnnl ("^d", char1, j, abs_data.priority_queue);

	if ^a_test_entry				/* regular daemon */
	then heading = gcos_daemon_stat_$snumb;		/* set heading */
	else					/* test user */
	do;					/* query him for a heading */
	     call ioa_$nnl ("Output heading for ^a = :", gcos_daemon_stat_$snumb);
	     call ios_$read_ptr (addr (heading), 24, j);
	     heading = substr (heading, 1, min (j-1, 24));
	     call ioa_$nnl ("Destination for ^a = :", gcos_daemon_stat_$snumb);
	     call ios_$read_ptr (addr (destination), 24, j);
	     destination = substr (destination, 1, min (j-1, 24));
	end;

	call ioa_$rsnnl (				/* fill in "snumb.absin" */
	     ".q"
	   ||"^/set_epilogue_command ""dl [user absin]"""
	   ||"^/cdwd ^a"
	   ||"^/cwd ^a"
	   ||"^/gcos_abs_control
gcos ^a>^a.gcos -id ^a -dpo ""-he """"^a"""" -ds """"^a"""" -dl -q ^a"" -dpno ""-he """"^a"""" -ds """"^a"""" -dl -q ^a""
dp -q ^a -he ""^a"" -ds ""^a"" -dl [user absout]"
	   ||"^/dl ^a>^a.gcos"
	   ||"^/logout -bf^/",
	     absin_mask, absin_char_count,
	     abs_data.home_dir,
	     abs_data.absentee_dir,
	     input_dir,
	     gcos_daemon_stat_$snumb,
	     unique_snumb,
	     heading,
	     destination,
	     char1,
	     heading,
	     destination,
	     char1,
	     char1,
	     heading,
	     destination,
	     input_dir,
	     gcos_daemon_stat_$snumb
	     );

	absin_name = rtrim (gcos_daemon_stat_$snumb)||".absin";	/* make absin file name */

	segment_acl.access_name = abs_data.user_name;	/* prepare for acl call */
	segment_acl.modes = "111"b;
	segment_acl.zero_pad = "0"b;

	call hcs_$add_acl_entries (abs_data.absentee_dir, absin_name, addr (segment_acl), 1, code); /* set user's access */
	if code ^= 0				/* error setting access */
	then do;
	     call com_err_ (code, "gcos_queue_job_", "Error setting access on ^a>^a.absin", abs_data.absentee_dir, gcos_daemon_stat_$snumb);
	     call error_wrap_up;
	     go to RETURN;
	end;

	call adjust_bit_count_ (abs_data.absentee_dir, absin_name, "1"b, bit_count, code); /* set its bit count */
	if code ^= 0				/* error setting bit count on snumb.absin */
	then do;
	     call com_err_ (code, "gcos_queue_job_", "Error setting bit count on ^a>^a.absin",
		abs_data.absentee_dir, gcos_daemon_stat_$snumb);
	     call error_wrap_up;
	     go to RETURN;
	end;

/* QUEUE UP ABSENTEE JOB */

	if a_test_entry
	then do;
	     call command_query_ (addr (query_info), answer, "gcos_queue_job_", "Do you want to submit ^a?", gcos_daemon_stat_$snumb);
	     if substr (answer, 1, 2) = "no"
	     then go to RETURN;
	end;

	priority = max (abs_data.priority_queue, gcos_daemon_stat_$max_priority); /* get effective max queue */
	if priority > abs_data.priority_queue		/* requester's queue too high in priority */
	then call ioa_ ("Request for queue ^d placed in queue ^d", /* tell operator */
	     abs_data.priority_queue, priority);

	call ioa_$rsnnl ("absentee_^d.ms", char32, j, priority); /* construct message segment name */

	call message_segment_$get_message_count_file	/* get present message count */
	     (sysdir, char32, ms_count, code);
	if code ^= 0				/* error getting count */
	then do;
	     call com_err_ (code, "gcos_queue_job_", "Error getting message count from absentee queue ^d",
		abs_data.priority_queue);
	     call error_wrap_up;
	     go to RETURN;
	end;

	call message_segment_$add_file
	     (sysdir, char32, temp_ptr, message_bit_count, message_id, code); /* submit message */
	if code ^= 0				/* error submitting message */
	then do;
	     call com_err_ (code, "gcos_queue_job_", "error queueing job: queue = ^d, SNUMB = ^a",
		abs_data.priority_queue, gcos_daemon_stat_$snumb);
	     call error_wrap_up;
	     go to RETURN;
	end;

	call hcs_$wakeup (whotab.abs_procid, whotab.abs_event, ev_message, code); /* signal absentee */
	if code = 1				/* signal didn't make it */
	then do;
	     call com_err_ (0, "gcos_queue_job_", "Signal to absentee for SNUMB #^a failed.
	     Request will be processed later", gcos_daemon_stat_$snumb);
	     code = 0;				/* no actual error returned */
	end;
	else					/* absentee was signalled, print message */
	call ioa_ ("1 request signalled: ^d already queued", ms_count);
	go to RETURN;

set_priority: entry (a_priority);

	if a_priority <gcos_daemon_stat_$low_priority |	/* illegal priority requested */
	a_priority > gcos_daemon_stat_$high_priority
	then call com_err_ (0, "gcos_queue_job_", "Attempt to set invalid priority: ^d", a_priority);
	else
	gcos_daemon_stat_$max_priority = a_priority;	/* set maximum queue priority */
	return;

RETURN:

	a_code = code;

	return;





error_wrap_up: proc;

	     call hcs_$delentry_seg (absin_ptr, code);	/* delete possible created absin file */

	     call message_segment_$delete_file		/* delete message if sent */
		(sysdir, char32, message_id, code);

	     code = 2;

	     return;

end error_wrap_up;

setup:   proc;

         rb (*) = 5;
         destination = "";
         message_id = "0"b;
         query_info.version = 2;
         query_info.yes_or_no_sw = "1"b;
         query_info.suppress_name_sw = "1"b;
    end setup;

%page;
/* DECLARATIONS */
/* ------------ */

/* fixed bin */

dcl (
     a_priority,					/* maximum allowable queue priority */
     absentee_dir_len,				/* character count of absentee dir name */
     absin_char_count,				/* character count of absin file */
     gcos_daemon_stat_$high_priority ext,		/* highest numerical legal priority */
     gcos_daemon_stat_$input_dir_len ext,		/* length of input directory name */
     gcos_daemon_stat_$low_priority ext,		/* lowest numerical legal priority */
     gcos_daemon_stat_$max_cpu_time ext,		/* maximum cpu time for job */
     gcos_daemon_stat_$max_priority ext,
     gcos_daemon_stat_$sysdir_len ext,			/* length of "sysdir" directory name */
     group_id_len,					/* character count of group id */
     j,						/* random variable */
     message_bit_count,				/* bit count of absentee message */
     ms_count,					/* number of messages in absentee queue */
     priority,					/* priority for which job will be queued */
     snumb_len,					/* character count of snumb */
     unique_snumb_len,				/* character count of snumb||"_"||unique_chars_ */
     user_name_len					/* character count of user name */
     ) fixed bin aligned;

dcl (
     bit_count
     ) fixed bin (24) aligned;

dcl (
     a_code,					/* error code (argument) */
     code						/* error code (internal) */
     ) fixed bin (35) aligned;

dcl  rb (3) fixed bin (3) aligned;			/* ring brackets */


/* bit strings */

dcl (
     a_test_entry,					/* ON if daemon was brought up by user */
     init internal static init ("0"b)			/* ON once per-process initialization is accomplished */
     ) bit (1) aligned;

dcl (
     message_id					/* returned from adding message */
     ) bit (72) aligned;
dcl  authrng (2) bit (72) aligned;


/* character strings */

dcl  char1 char (1) aligned;

dcl (
     answer					/* answer from command query question */
     ) char (4) aligned;

dcl 
     ipc_message int static init ("login   ") char (8);

dcl (
     destination,					/* destination for dprinting and dpunching output */
     heading,					/* heading for dprinting and dpunching output */
     unique_snumb
     ) char (24) aligned;
dcl  gcos_daemon_stat_$snumb ext char (6) aligned;
dcl (
     absin_name,					/* ent name of absentee file */
     char32					/* random string */
     ) char (32) aligned;

dcl (
     gcos_daemon_stat_$input_dir ext,			/* input directory name */
     gcos_daemon_stat_$sysdir ext,			/* "sysdir" directory name */
     input_dir int static,
     sysdir internal static				/* "sysdir" directory name (internal) */
     ) char (168) aligned;


/* pointers */

dcl (
     a_data_ptr,					/* pointer to daemons' absentee data structure (argument) */
     absin_ptr,					/* pointer to created "snumb.absin" segment */
     reqp ptr,					/* pointer to absentee request structure */
     stat_whoptr internal static,			/* static pointer to who table */
     temp_ptr internal static,			/* pointer to temp segment in process dir */
     whoptr					/* pointer to who-table */
     ) ptr aligned;


/* masks */

dcl  absin_mask char (1000) aligned based (absin_ptr);

dcl  ev_message fixed bin (71) aligned based (addr (ipc_message)); /* for sending ascii */


/* structures */

dcl 1 segment_acl aligned,				/* for setting user's access */
    2 access_name char (32) aligned,
    2 modes bit (36) aligned,
    2 zero_pad bit (36) aligned,
    2 status_code fixed bin (35) aligned;

dcl 1 query_info aligned,				/* for command query call */
    2 version fixed bin,
    2 yes_or_no_sw bit (1) unaligned,			/* answer must be yes or no */
    2 suppress_name_sw bit (1) unaligned,		/* don't print prog name with "Please answer ... */
    2 codes (2) fixed bin (35);


/* built in functions */

dcl (
     addr,
     currentsize,
     length,
     max,
     min,
     null,
     rtrim,
     substr
     ) builtin;


/* conditions */

dcl (
     cleanup
     ) condition;


/* include files */

% include abs_message_format;

% include gcos_abs_data;

% include queue_msg_hdr;

% include user_abs_attributes;

% include whotab;


/* external entries */

dcl  adjust_bit_count_ ext entry (char (168) aligned, char (32) aligned, bit (1) aligned,
     fixed bin (24) aligned, fixed bin (35) aligned);

dcl  com_err_ ext entry
     options (variable);

dcl  command_query_ ext entry
     options (variable);

dcl  get_group_id_ ext entry
     returns (char (32) aligned);

dcl  hcs_$add_acl_entries ext entry
    (char (*) aligned, char (*) aligned, ptr aligned, fixed bin aligned, fixed bin (35) aligned);
dcl  hcs_$delentry_seg ext entry
    (ptr aligned, fixed bin (35) aligned);

dcl  hcs_$initiate ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin aligned, fixed bin aligned,
     ptr aligned, fixed bin (35) aligned);

dcl  hcs_$make_seg ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5) aligned, ptr aligned,
     fixed bin (35) aligned);

dcl  hcs_$set_ring_brackets ext entry (char (*) aligned, char (*) aligned, (3) fixed bin (3) aligned,
     fixed bin (35) aligned);

dcl  hcs_$truncate_seg ext entry
    (ptr aligned, fixed bin aligned, fixed bin (35) aligned);

dcl  hcs_$wakeup ext entry (bit (*) aligned, fixed bin (71), fixed bin (71), fixed bin (35) aligned);

dcl  ioa_ ext entry
     options (variable);

dcl  ioa_$nnl ext entry
     options (variable);

dcl  ioa_$rsnnl ext entry
     options (variable);

dcl  ios_$read_ptr ext entry
    (ptr aligned, fixed bin aligned, fixed bin aligned);

dcl  message_segment_$add_file ext entry
    (char (*) aligned, char (*) aligned, ptr, fixed bin aligned, bit (*) aligned, fixed bin (35) aligned);

dcl  message_segment_$delete_file ext entry
    (char (*) aligned, char (*) aligned, bit (72) aligned, fixed bin (35) aligned);

dcl  message_segment_$get_message_count_file ext entry
    (char (*) aligned, char (*) aligned, fixed bin aligned, fixed bin (35) aligned);

dcl  unique_chars_ entry (bit(*)) returns(char(15));
dcl  unique_bits_ entry() returns(bit(70));
dcl  user_info_$authorization_range entry ((2) bit (72) aligned);

end gcos_queue_job_;




		    gcos_read_.pl1                  11/19/82  1409.3rew 11/19/82  0853.2      244656



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

%page;
/*
	WRITTEN BY:	P. Haber		MAR 21 74
	MODIFIED BY:	R.H. Morrison	MAY 22 74
					MAR    75
	MODIFIED BY:	Bob May		JUL 18 78 To allow IMCV tapes to use ***EOF
						cards  instead  of  $ENDJOB cards
						(see  GEIN PLM).  A dummy $ENDJOB
						card   is   written  to  the  JCL
						instead of the ***EOF card.

						Also  to  allow  placement of the
						$IDENT  card  anywhere in the job
						deck.  This change eliminated the
						use  of  the  "first_read" switch
						and    replaced    it   with   an
						"ident_found" switch.

	MODIFIED BY:	Scott C. Akers	MAR 30 82 To  give  operator  the option of
						resolving duplicate SNUMBs.

	MODIFIED BY:	Scott C. Akers	MAR 31 82	To use gcos_daemon_stat_$snumb

*/
%page;
gcos_read_: proc;

cards:	entry (a_urgency, a_input_ptr, a_abs_data_ptr, a_eof_found, a_code);

	reading_cards = "1"b;
	stream_name = "card_input";
	card_no = 1;				/* First card is snumb */

	go to COMMON;


tape:	entry (a_urgency, a_input_ptr, a_abs_data_ptr, a_eof_found, a_code);

	reading_cards = "0"b;
	stream_name = "tape_input";

COMMON:	;

	rh_ptr = addr (record_header);		/* pointer for looking at record header */
	sp = addr (status_stuff);			/* pointer to returned status from ios_ calls */

	on condition (cleanup)			/* establish cleanup condition handler */
	     call end_work;

	if ^initialized				/* first call */
	then do;					/* initialize internal directory info */
	     input_dir = substr (gcos_daemon_stat_$input_dir, 1, gcos_daemon_stat_$input_dir_len);
	     pool_dir = substr (gcos_daemon_stat_$pool_dir, 1, gcos_daemon_stat_$pool_dir_len);
	     root_dir_len = gcos_daemon_stat_$root_dir_len;
	     root_dir = substr (gcos_daemon_stat_$root_dir, 1, root_dir_len);
	     default_home_dir = substr (gcos_daemon_stat_$default_home_dir, 1,
		gcos_daemon_stat_$default_home_dir_len);
	     user_ring = fixed (get_ring_ (), 17);	/* set for effmode calls later */
	     abs_data_len = (fixed (rel (addr (a_abs_data_ptr -> abs_data.end_abs_data)), 17) -
		fixed (rel (addr (a_abs_data_ptr -> abs_data)), 17)) * 36; /* set abs data length */
	     my_name = get_group_id_$tag_star ();	/* remember proc id */
	     initialized = "1"b;
	end;

	abs_data_ptr = a_abs_data_ptr;
	data_blank = "0"b;				/* initialize absentee data */
	code = 0;					/* initialize internal error code */

	segment_name = "";				/* initialize internal variables */
	input_ptr = addr (input);
	ascii_ptr = addr (ascii);
	priority_queue = a_urgency;
	write_ptr = a_input_ptr;			/* first write is of bcd snumb card argument */
	write_size = 14;				/* = 14 36 bit words */

	segment_name = rtrim (gcos_daemon_stat_$snumb)||".*";  /* make star name */

	report_code = "0"b;				/* set record header for first write */
	media_code = "0010"b;			/* bcd image */

	do dir_name = input_dir, pool_dir;		/* check directories for similarly named segment */

	     call check_entry;			/* see if SNUMB is already on system */
	     if code ^= 0				/* error or SNUMB already exists */
	     then go to RETURN;

	end;

	segment_name = rtrim (gcos_daemon_stat_$snumb) || ".gcos"; /* set default segment name */

	call ios_$attach ("segment_output", "file_", segment_name, "w", status_stuff); /* attach segment */
	code = status.code;				/* check error code */
	if code ^= 0				/* error attaching segment */
	then do;
	     call com_err_ (code, "gcos_read_", "Error attaching to segment_output stream");
	     go to RETURN;
	end;
	else					/* no error */
	output_is_attached = "1"b;			/* for condition handler */

	call ios_$setsize ("segment_output", 36, status_stuff); /* set element size for writing */
	code = status.code;				/* check code */
	if code ^= 0				/* error setting size */
	then do;
	     call com_err_ (code, "gcos_read_", "Error setting element size on segment_output stream");
	     go to DETACH;
	end;

	call gcos_gsr_write_$gsr_write_init ("segment_output", code); /* initialize write package */
	if code ^= 0				/* error initializing write routine */
	then do;
	     call com_err_ (code, "gcos_read_",
			"Error in call to gsr_write_init: SNUMB = ^a",
			gcos_daemon_stat_$snumb);
	     go to DETACH;
	end;
	else					/* no error */
	gsr_write_init_called = "1"b;			/* remember it was called */

%page;

WRITE:

	call gcos_gsr_write_ ("segment_output", write_ptr, write_size, record_header, ejb_found, code);
						/* write the binary or bcd image */
	if code ^= 0				/* error writing */
	then do;
	     call com_err_ (code, "gcos_read_", "Error from gsr_write: SNUMB = ^a", gcos_daemon_stat_$snumb);
	     go to DETACH;
	end;

	if ejb_found				/* end of job found */
	then do;
	     gsr_write_init_called = "0"b;		/* ejb switch closed out file */
	     go to DETACH;
	end;

	dollar_card = "0"b;

	if reading_cards
	then do;

	     card_no = card_no + 1;			/* Keep count of cards read */
	     call ios_$read (stream_name, input_ptr, 0, 1, elements_read, status_stuff);
	     code = status.code;			/* check code */
	     if code ^= 0				/* error reading */
	     then do;
		call com_err_ (code, "gcos_read_", "Error reading from ^a:  SNUMB = ^a", stream_name, gcos_daemon_stat_$snumb);
		go to DETACH;
	     end;
	     if status.eof				/* last card and "last batch" button */
	     then do;
		call com_err_ (0, "gcos_read_", "Unexpected end of card input: SNUMB = ^a", gcos_daemon_stat_$snumb);
		code = 2;				/* fatal error */
		go to DETACH;
	     end;

	     write_ptr = input_ptr;			/* set pointer for writing */

	     if substr (input, 10, 3) ^= "101"b		/* check for non-binary card */
	     then do;

		call cv_bin_to_bcd_ (input_ptr, input_ptr, code); /* convert to bcd */
		if code ^= 0
		then do;
		     call com_err_ (0, "gcos_read_", "Error converting card ^i to bcd: SNUMB = ^a",
			card_no, gcos_daemon_stat_$snumb);
		     go to DETACH;
		end;

		write_size = 14;
		media_code = "0010"b;		/* bcd image */
		if substr (input, 1, 6) = "101011"b	/* "$" */
		then dollar_card = "1"b;
	     end;

	     else					/* binary image */
	     do;
		media_code = "0001"b;
		write_size = 27;
	     end;

	     report_code = "0"b;

	end;

	else					/* reading from tape */
	do;

	     if eof_found				/* error, attempt to read past eof */
	     then do;
		call com_err_ (0, "gcos_read_", "Unexpected eof on tape: SNUMB = ^a", gcos_daemon_stat_$snumb);
		code = 2;				/* return fatal error */
		go to DETACH;
	     end;

	     call gcos_gsr_read_ (stream_name, write_ptr, write_size, record_header, eof_found, code);
	     if code ^= 0				/* error reading from tape */
	     then do;
		call com_err_ (code, "gcos_read_", "Error from gcos_gsr_read_, SNUMB = ^a", gcos_daemon_stat_$snumb);
		go to DETACH;
	     end;

/* BCD */
	     if media_code = "0010"b			/* bcd card */

/* $ */
	     then if first_bcd_char = "101011"b		/* = $ */
		then dollar_card = "1"b;

/* ***EOF */
		else if substr (tape_input_record, 1, 36) = "545454254626"b3
		then do;
		     substr (tape_input_record, 1, 252) = (42) "20"b3; /* init bcd string to blanks, in two parts, */
		     substr (tape_input_record, 253, 252) = (42) "20"b3; /* to get around PL/I restriction */
		     substr (tape_input_record, 1, 126) =
			"532020202020202545244146222020545454254626"b3; /* "$      ENDJOB  ***EOF" */
		     ejb_found = "1"b;		/* same as for $ENDJOB */
		     go to WRITE;
		end;


	end;

	if dollar_card				/* image is a $ card image */
	then do;

	     call cv_bcd_to_ascii_ (write_ptr, ascii_ptr); /* convert card image to ascii */

/* SNUMB */
	     if substr (ascii, 8, 5) = "snumb"		/* error, SNUMB card in job stream */
	     then do;
		call com_err_ (0, "gcos_read_", "SNUMB card found in job stream");
		code = 2;				/* return fatal error */
		go to DETACH;
	     end;

/* ENDCOPY */

	     if substr (ascii, 8, 7) = "endcopy"	/* endcopy card */
	     then do;
		card_is_data = "0"b;		/* following cards are not data */
		go to WRITE;
	     end;

/* DATA CHECK */

	     if card_is_data			/* in between data and endcopy card */
	     then go to WRITE;			/* ignore card */

/* ENDJOB */

	     if substr (ascii, 8, 6) = "endjob"		/* end of job card */
	     then do;
		ejb_found = "1"b;
		go to WRITE;
	     end;

/* DATA */

	     if substr (ascii, 8, 4) = "data"		/* data card */
	     then do;
		if substr (ascii, 20, 1) = ","	/* there is a second field on the card image */
		then do;
		     do i = 17 to 70 while (substr (ascii, i, 1) ^= ","); /* check for third field */
		     end;
		     if i < 70			/* third field exists */
		     then if substr (ascii, i+1, 4) = "copy" /* it contains the copy option */
			then card_is_data = "1"b;	/* following cards are data */
		end;
		go to WRITE;
	     end;

/* IDENT */

	     if substr (ascii, 8, 5) = "ident"		/* ident card */
	     then if ^ident_found			/* use first $IDENT card only */
		then do;
		     ident_found = "1"b;		/* checked at end of current job stream */

		     do j = 16 to 80 while (substr (ascii, j, 1) ^= ","); /* look for end of epa number */
		     end;
		     if (j = 16)| (j>79)		/* format error */
		     then do;
			code = 1;			/* return non-fatal error */
			call com_err_ (0, "gcos_read_", "Format error on ident card:  SNUMB = ^a", gcos_daemon_stat_$snumb);
			go to DETACH;
		     end;
		     epa_num = substr (ascii, 16, j-16); /* pick off epa number */

		     call gcos_user_$validate (epa_num, gutep, code);
		     if code ^= 0			/* some error from validate procedure */
		     then do;
			if code < 3		/* password or missing entry error */
			then do;
			     call com_err_ (0, "gcos_read_", "Error in epa number: SNUMB = ^a", gcos_daemon_stat_$snumb);
			     code = 1;		/* non-fatal error */
			     go to DETACH;
			end;
			else			/* some problem with gcos_user table */
			do;
			     call com_err_ (code, "gcos_read_", "***ATTENTION***^/Error in gcos user table: code = ^d", code);
			     code = 2;		/* return fatal error */
			     go to DETACH;
			end;
		     end;

		     if ^epa_found			/* an epa was not yet encountered */
		     then do;

			do j = 22 to 1 by -1 while	/* find last char in multics user name */
				(substr (gutep -> gute_multics_person, j, 1) = " ");
			end;
			do k = 9 to 1 by -1 while	/* find end of multics project name */
				(substr (gutep -> gute_multics_project, k, 1) = " ");
			end;
			user_name = substr (gcos_daemon_stat_$anonymous_user, 1,
			     gcos_daemon_stat_$anonymous_user_len); /*  set absentee user name  */

			absentee_dir,
			     home_dir = substr (gcos_daemon_stat_$home_root_dir, 1, gcos_daemon_stat_$home_root_dir_len)
			     ||">"||substr (gutep -> gute_multics_project, 1, k)||">"
			     ||substr (gutep -> gute_multics_person, 1, j); /* make up new home dir path name */

			dir_name = absentee_dir;	/* prepare for entry check call */
			call check_entry;		/* see if job already exists */
			if code ^= 0		/* job already exists or fatal error */
			then go to DETACH;

			do ac_name = absentee_dir, home_dir; /* check daemon's access to these dirs */
			     call check_access (ac_name, my_name);
			     if code ^= 0		/* error checking access */
			     then go to DETACH;
			end;

			epa_found = "1"b;		/* remember a epa number was found */

		     end;

		     go to WRITE;

		end;

/* MSG3 */

	     if substr (ascii, 8, 4) = "msg3"		/* deferral card */
	     then if ^deferral_switch			/* one was not yet found */
		then do;

		     call gcos_convert_time_ (substr (ascii, 16, 12), deferral, code); /* convert to Multics time */
		     if code ^= 0			/* error converting time */
		     then do;
			call com_err_ (0, "gcos_read_", "Invalid time field on msg3 card:  SNUMB = ^a", gcos_daemon_stat_$snumb);
			go to DETACH;
		     end;

		     deferral_switch = "1"b;		/* fill in absentee information */
		     go to WRITE;

		end;

	end;

	go to WRITE;

%page;

DETACH:

	if ^ident_found
	then do;
NO_IDENT:
	     call com_err_ (0, "gcos_read_", "Missing or invalid ident card: SNUMB = ^a", gcos_daemon_stat_$snumb);
	     code = 1;
	end;

	call end_work;				/* finish processing */

	if code = 0				/* no error occurred */
	then do;

	     input_segment_name = segment_name;
	     if ^epa_found				/* no epa image was encountered */
	     then do;
		absentee_dir = pool_dir;
		home_dir = default_home_dir;
		user_name = "Anonymous.GCOS.*";
	     end;

	     do dir_name = input_dir, absentee_dir, home_dir; /* check users access to these dirs */
		call check_access (dir_name, user_name);
	     end;

	     call hcs_$set_ring_brackets (input_dir, segment_name, rb, code); /* set ring brackets */
	     if code ^= 0 then
		do; call com_err_ (code, "gcos_read_", "Error setting ring brackets for ^a>^a",
		     input_dir, segment_name);
		go to RETURN;
	     end;

	     call hcs_$acl_add1 (input_dir, segment_name, user_name, 01111b, ringbrackets, code); /* set users access */
	     if code ^= 0				/* error setting access */
	     then call com_err_ (code, "gcos_read_", "Error setting access on ^a>^a", input_dir, segment_name);

	end;

RETURN:

	if code ^= 0				/* some error occurred */
	then data_blank = "0"b;			/* zero out absentee data structure */

	a_eof_found = eof_found;			/* return flag */
	a_code = code;				/* return error code */
	return;
%page;
check_access: proc (c_dir_name, c_user_name);

dcl (
     c_user_name
     ) char (32) aligned;

dcl (
     c_dir_name
     ) char (168) aligned;

	     i = index (c_dir_name, " ") - 1;
	     if i = -1
	     then i = 168;

	     call expand_path_ (addr (c_dir_name), i, addr (run_dn), addr (run_en), code);
	     if code ^= 0
	     then do;
		call com_err_ (code, "gcos_read_", "Error expanding ^a", c_dir_name);
		code = 2;				/* fatal error */
		go to RETURN;
	     end;

	     call hcs_$get_user_effmode (run_dn, run_en, c_user_name, user_ring, dir_mode, code); /* check access */
	     if code ^= 0
	     then do;
		call com_err_ (code, "gcos_read", "Error getting access to ^a", c_dir_name);
		go to RETURN;
	     end;

	     if (bit (dir_mode, 5) & "01011"b) ^= "01011"b /* user doesn't have access */
	     then do;
		call com_err_ (error_table_$moderr, "gcos_read_", "^a to ^a", c_user_name, c_dir_name);
		code = 1;				/* error is not fatal */
		go to RETURN;
	     end;

	     return;

	end check_access;
%page;
check_entry: proc;

	call gcos_daemon_temp_$star_ (dir_name, segment_name, 3, null, ecount, null, null, code);
	if   code ^= 0				/* error from gcos_daemon_temp_$star_ */
	then do;
	     call com_err_ (code, "gcos_read_", "Error searching ^a for ^a",
			dir_name, segment_name);

	     if   code = error_table_$noentry	/* not fatal error */
	     then code = 1;			/* return non-fatal error */
	     return;
	     end;

	if   ecount ^= 0				/* SNUMB already on system. */
	then if   ^dup_resolved ()			/* Try to resolve the duplication. */
	     then do;
		code = 1;				/* Set code to non-fatal. */
		call end_work;
	     end;

	     return;

end check_entry;
%page;
dup_resolved: proc () returns (bit (1));

	start_snumb = rtrim (gcos_daemon_stat_$snumb);
	query_info.version = query_info_version_4;
	query_info.switches = "0"b;			/* Standard format. */
	query_info.switches.cp_escape_control = "10"b;	/* No command escape. */
	query_info.status_code = 0;
	query_info.query_code = 0;
	query_info.question_iocbp = null ();		/* Normal I/O switches. */
	query_info.answer_iocbp = null ();
	query_info.repeat_time = 45;			/* Wait 45 seconds to repeat question. */
	call command_query_ (addr (query_info),
			 query_response,
			 "gcos_daemon",
			 "Duplicate SNUMB - ^a.  Abort or resolve (a/r)?",
			 start_snumb);

	bail_out = "0"b;
	if   substr (query_response, 1, 1) = "r"
	then do;
	     start_snumb, temp_snumb = substr (rtrim (start_snumb) || "00000", 1, 5);
	     do   while (^bail_out);
		temp_snumb = next_snumb (temp_snumb);
		temp_segname = rtrim (temp_snumb) || ".*";
		if   temp_snumb = start_snumb		/* If we've come full circle and have */
						/* yet to resolve the duplication. */
		then do;
		     bail_out = "1"b;
		     resolved = "0"b;
		     end;

		else do   temp_dir_name = input_dir, pool_dir
			while (^bail_out);

		     call gcos_daemon_temp_$star_ (temp_dir_name, temp_segname,
					     3, null, ecount, null, null, code);

		     if   code ^= 0
		     then do;
			call com_err_ (code, "gcos_read_",
				     "^/Error while attempting to resolve duplicate SNUMB ^a",
				     gcos_daemon_stat_$snumb);
			resolved = "0"b;
			bail_out = "1"b;
			end;

		     else if   ecount = 0
			then do;
			     call ioa_ ("gcos_daemon: SNUMB #^a entered as #^a",
				      gcos_daemon_stat_$snumb, temp_snumb);

			     snumb_length1 = 5;	/* Gotta set the values so caller
						/* doesn't get all confoozed. */
			     gcos_daemon_stat_$snumb = temp_snumb;
			     bail_out = "1"b;
			     resolved = "1"b;
			     end;
		     end;
		end;
	     end;
	else resolved = "0"b;

	return (resolved);

dcl  bail_out bit (1);
dcl  query_response char (80) varying;
dcl  resolved bit (1);
dcl  (start_snumb, temp_snumb) char (5);
dcl  temp_segname char (32) aligned;
dcl  temp_dir_name char (168) aligned;

end dup_resolved;
%page;
end_work:	proc;

	     if gsr_write_init_called
	     then do;
		call gcos_gsr_write_$gsr_write_close ("segment_output", code2);
		if code2 ^= 0
		then do;
		     call com_err_ (code2, "gcos_read_", "Error from gsr_write_close");
		     if code < 2			/* no fatal error yet */
		     then code = code2;		/* return this one */
		end;
	     end;

	     if output_is_attached			/* output stream is attached */
	     then do;

		call ios_$detach ("segment_output", "file_", "", status_stuff); /* detach the output stream */
		code2 = status.code;		/* check error code */
		if code2 ^= 0			/* error detaching output stream */
		then do;
		     call com_err_ (code2, "gcos_read_", "Unable to detach ^a", segment_name);
		     if code <= 1			/* no previous fatal error */
		     then code = code2;		/* return this one */
		end;
		else
		output_is_attached = "0"b;

	     end;

end end_work;
%page;
next_snumb: proc (in_string) returns (char (5));

dcl  in_string	char (5)	parm;
dcl  in_length	fixed bin;

	conv_block = in_string;			/* Put it where we can work on it. */
	in_length = length (rtrim (conv_block));
	if   in_length ^= 0
	then do;
	     if   conv_ovrl (in_length) = 57
	     then conv_ovrl (in_length) = 97;
	     else if   conv_ovrl (in_length) = 122
		then conv_block = rtrim (next_snumb (substr (in_string, 1, in_length-1))) || "0";
		else conv_ovrl (in_length) = conv_ovrl (in_length) + 1;
	     end;

	return (conv_block);

dcl  conv_block	char (5)	aligned;
dcl  conv_ovrl	(5) fixed bin (9) unsigned unaligned based (addr (conv_block));
dcl  conv_ptr	pointer;
dcl  ret_string	char (5);

end next_snumb;
%page;
/* DECLARATIONS */
/* ------------ */


/* fixed bin */
/* ----- --- */

dcl (
     a_root_dir_len,				/* length of root directory path-name (argument) */
     a_urgency,					/* urgency field from SNUMB card (argument) */
     ecount,					/* number of segments from gcos_daemon_temp_$star_ call */
     elements_read,					/* elements read from ios_$read call */
     elements_written,				/* elements written from ios_$write call */
     gcos_daemon_stat_$default_home_dir_len ext,		/* length of pn */
     gcos_daemon_stat_$home_root_dir_len ext,		/* length of pn */
     gcos_daemon_stat_$input_dir_len ext,		/* character count of input directory */
     gcos_daemon_stat_$pool_dir_len ext,		/* character count of pool directory */
     gcos_daemon_stat_$root_dir_len ext,		/* character count of root directory */
     gcos_daemon_stat_$anonymous_user_len ext,		/* character count of anonymous user */
     i,						/* random variable */
     j,						/* random variable */
     k,						/* random variable */
     root_dir_len int static,				/* length of root directory path-name (internal) */
     snumb_length1,					/* length of SNUMB + 1 */
     user_ring int static,				/* for effmode call */
     card_no,					/* sequence number for reading cards */
     write_size					/* number of elements to write into segment */
     ) fixed bin aligned;

dcl (
     dir_mode					/* access of user to dir_name */
     ) fixed bin (5) aligned;

dcl  ringbrackets (0:2) fixed bin (6) aligned int static init (5, 5, 5);

dcl  rb (3) fixed bin (3) init (5, 5, 5) aligned;		/* ringbrackets for set_ring_brackets call */

dcl (
     a_code,					/* error code (argument) */
     code,					/* error code (internal) */
     code2,					/* error code (internal) */
     error_table_$namedup ext,
     error_table_$moderr ext,
     error_table_$noentry ext
     ) fixed bin (35) aligned;


/* bit strings */
/* --- ------- */

dcl (
     a_eof_found					/* ON if end of read input encountered (argument) */
     ) bit (1) aligned;

dcl (
     record_header					/* record header from tape returned from gsr_read_ */
     ) bit (12) aligned;

dcl (
     card_is_data,					/* ON between data and endcopy cards */
     dollar_card,					/* ON when a $ card is being processed */
     ejb_found,					/* ON when end of job card found */
     eof_found,					/* ON if end of read input encountered (internal) */
     ident_found,					/* ON when at least one IDENT card found in job stream */
     epa_found,					/* ON once epa number is found */
     gsr_write_init_called,				/* ON once gsr_write_init is called */
     initialized int static,				/* ON once this procedure has been called */
     output_is_attached,				/* ON once output has been attached */
     reading_cards					/* ON when cards are being read */
     ) bit (1) aligned init ("0"b);

dcl (
     status_stuff					/* returned from ios_ calls */
     ) bit (72) aligned;

dcl (
     input					/* binary card image */
     ) bit (972) aligned;


/* pointer */
/* ------- */

dcl (
     a_abs_data_ptr,				/* pointer to absentee job info (argument) */
     a_input_ptr,					/* pointer to bcd SNUMB card (argument) */
     ascii_ptr,					/* pointer to ascii card image */
     input_ptr,					/* pointer to binary card image */
     rh_ptr,					/* pointer for looking at record header */
     sp,						/* pointer to returned status from ios_ calls */
     write_ptr					/* points to data to be written */
     ) ptr aligned;


/* character strings */
/* --------- ------- */

dcl (
     gcos_daemon_stat_$snumb ext
     ) char (6) aligned;

dcl (snumb					/* SNUMB (internal) */
     ) char (8) aligned;

dcl (
     epa_num,					/* epa number from ident card */
     stream_name					/* device from which to read (internal) */
     ) char (12) aligned;

dcl (
     my_name int static,				/* id of caller of this proc */
     run_en,					/* for checking dir access */
     segment_name					/* old segment name */
     ) char (32) aligned;

dcl (
     ascii init ("")				/* ascii card image */
     ) char (80) aligned;
dcl (
     ac_name,					/* used in loop call */
     default_home_dir int static,			/* default Anonymous home dir */
     dir_name,					/* for do loop */
     gcos_daemon_stat_$default_home_dir ext,		/* default Anonymous home dir */
     gcos_daemon_stat_$home_root_dir ext,		/* root portion of all GCOS home dirs */
     gcos_daemon_stat_$input_dir ext,			/* input directory */
     gcos_daemon_stat_$pool_dir ext,			/* pool directory */
     gcos_daemon_stat_$root_dir ext,			/* root directory */
     gcos_daemon_stat_$anonymous_user ext,		/* name of default anonymous user */
     input_dir int static,				/* input directory (internal) */
     pool_dir int static,				/* pool directory (internal) */
     root_dir int static,				/* root directory (internal) */
     run_dn					/* for checking dir access */
     ) char (168) aligned;


/* built in */
/* ----- -- */

dcl (
     addr,
     bit,
     fixed,
     index,
     null,
     rel,
     substr
     ) builtin;


/* masks */
/* ----- */

dcl  first_bcd_char bit (6) unaligned based (write_ptr);

dcl  tape_input_record bit (504) aligned based (write_ptr);

dcl 1 record_header_mask aligned based (rh_ptr),
    2 pad bit (2) unaligned,
    2 media_code bit (4) unaligned,
    2 report_code bit (6) unaligned;

dcl 1 status based (sp) aligned,			/* for examining status from ios_ */
    2 code fixed bin (35) aligned,
    2 pad bit (9) unaligned,
    2 eof bit (1) unaligned;

/* conditions */
/* ---------- */

dcl (
     cleanup
     ) condition;


/* external entries */
/* -------- ------- */

dcl  com_err_		entry() options(variable);
dcl  command_query_		entry() options(variable);
dcl  ioa_			entry() options(variable);
dcl  cv_bcd_to_ascii_ ext entry
    (ptr aligned, ptr aligned);

dcl  cv_bin_to_bcd_ ext entry
    (ptr aligned, ptr aligned, fixed bin (35) aligned);

dcl  expand_path_ ext entry
    (ptr aligned, fixed bin aligned, ptr aligned, ptr aligned, fixed bin (35) aligned);

dcl  gcos_convert_time_ ext entry
    (char (16) aligned, fixed bin (71) aligned, fixed bin (35) aligned);

dcl  gcos_daemon_temp_$star_ ext entry
    (char (*) aligned, char (*) aligned, fixed bin (2) aligned, ptr aligned, fixed bin aligned,
     ptr aligned, ptr aligned, fixed bin (35) aligned);

dcl  gcos_user_$validate ext entry
    (char (12) aligned, ptr aligned, fixed bin (35) aligned);

dcl  gcos_gsr_read_ ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_write_ ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_write_$gsr_write_close ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_write_$gsr_write_init ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  get_ring_ ext entry
     returns (fixed bin (6) aligned);

dcl  get_group_id_$tag_star ext entry
     returns (char (32) aligned);

dcl  hcs_$acl_add1 ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5) aligned, (0:2) fixed bin (6) aligned,
     fixed bin (35) aligned);

dcl  hcs_$set_ring_brackets ext entry
    (char (*) aligned, char (*) aligned, (3) fixed bin (3) aligned, fixed bin (35) aligned);

dcl  hcs_$get_user_effmode ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin aligned, fixed bin (5) aligned, fixed bin (35) aligned);

dcl  ios_$attach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$detach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$read ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned);

dcl  ios_$setsize ext entry
    (char (*) aligned, fixed bin aligned, bit (72) aligned);
%page;
% include gcos_abs_data;
%page;
% include gcos_user_table_entry_;
%page;
%include query_info;

end gcos_read_;




		    gcos_read_cards_.pl1            11/19/82  1409.3rew 11/19/82  0853.2       87444



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_read_cards_: proc (a_stream_name, a_test, a_eof_found, a_code);

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */
%page;
/*

MODIFIED: 	Scott C. Akers	31 MAR 82 To   make  use  of  the  snumb
					variable in gcos_daemon_stat_,
					rather   than  pass  it  as  a
					parameter   'twixt   all   and
					sundry.

*/
%page;
	input_ptr = addr (input);			/* pointer to card image */
	output_ptr = addr (ascii);			/* pointer to ascii card image */
	sp = addr (status_stuff);			/* pointer to returned status */

	on condition (cleanup)			/* establish cleanup condition handler */
	     call wrap_up ("1"b);

	stream_name = a_stream_name;			/* copy argument */
	code = 0;					/* initialize error code */

READ:

	call get_snumb;				/* read first card and check for "SNUMB" */
	if code > 1				/* fatal error */
	then go to RETURN;
	if eof_found				/* end of deck found */
	then go to RETURN;
	if code = 0				/* no error occurred */
	then if ^snumb_found			/* the card was not a SNUMB card */
	     then call com_err_ (0, "gcos_read_cards_", "Expected SNUMB card not found");

	if (^snumb_found)| (code = 1)			/* no SNUMB or error in input */
	then do while (^status.eof & ^eof_found);	/* search for another SNUMB card */
	     call get_snumb;
	     if code > 1
	     then go to RETURN;
	     if code = 0
	     then if (snumb_found)
		then go to RETURN;
	end;

RETURN:

	if (code>1)| (eof_found)			/* fatal error or ***eof */
	then call wrap_up ("0"b);
	if ^eof_found				/* no eof card yet */
	then go to READ;				/* try again */

	a_eof_found = eof_found;			/* return argument */
	a_code = code;				/* return error code */

	return;
%page;
/* INTERNAL PROCEDURES */
get_snumb: proc;

	     eof_found,				/* initialize flags */
		eoc_found,
		snumb_found = "0"b;

READ:
	     call ios_$read (stream_name, input_ptr, 0, 1, elements_read, status_stuff); /* read in a card */
	     code = status.code;			/* extract code from status bit string */
	     if code ^= 0				/* error reading */
	     then do;
		call com_err_ (code, "gcos_read_cards_", "Error reading from card reader");
		return;
	     end;
	     if status.eof				/* "last batch button" and eof */
	     then do;
		code = 2;				/* cause return to command level */
		return;
	     end;

	     if substr (input, 10, 2) = "101"b		/* this is a binary card */
	     then return;				/* it can't be a SNUMB card */

	     call cv_bin_to_bcd_ (input_ptr, input_ptr, code); /* convert card image to bcd */
	     if code ^= 0				/* error converting card */
	     then do;
		code = 0;				/* prevents return from external procedure */
		return;
	     end;

	     call cv_bcd_to_ascii_ (input_ptr, output_ptr);

	     if substr (ascii, 1, 1) = "$"		/* check for SNUMB card */
	     then do;
		if substr (ascii, 8, 5) = "snumb"
		then do;

		     snumb_found = "1"b;		/* got it */
		     do i = 16 to 80 while		/* find end of SNUMB */
			     ((substr (ascii, i, 1) ^= " ")&
			     (substr (ascii, i, 1) ^= ","));
		     end;
		     if i = 17			/* error, no SNUMB argument */
		     then do;
			code = 1;			/* return non-fatal error */
			call com_err_ (0, "gcos_read_cards_", "Missing argument on SNUMB card");
			return;
		     end;
		     gcos_daemon_stat_$snumb = substr (ascii, 16, i-16);

		     if substr (ascii, i, 1) = ","	/* card contains urgency field */
		     then do;
			do j = i + 1 to 80 while	/* find end of urgency field */
				(substr (ascii, j, 1) ^= " ");
			end;
			urgency = cv_dec_check_ (substr (ascii, i+1, j-i-1), code); /* pick off urgency field */
			if code ^= 0		/* error converting urgency field */
			then do;
			     call com_err_ (0,
					"gcos_read_cards_",
					"Invalid urgency field:  SNUMB = ^a",
					gcos_daemon_stat_$snumb);
			     return;
			end;
			if (urgency < 1)| (urgency > 63) /* urgency field out of bounds */
			then do;
			     call com_err_ (0,
					"gcos_read_cards_",
					"Urgency field out of bounds:  SNUMB = ^a",
					gcos_daemon_stat_$snumb);
			     return;
			end;
			urgency = divide (63-urgency, 21, 17, 0)+1; /* convert to queue number */
		     end;
		     else				/* no urgency field on card */
		     urgency = 3;			/* set default urgency */

		     if ^eoc_found			/* more input to come */
		     then do;			/* read the job */

			call gcos_read_$cards (urgency, input_ptr,
					   addr (gcos_abs_data), eoc_found,
					   code);
			if code ^= 0		/* error reading job */
			then return;

			call gcos_queue_job_ (addr (gcos_abs_data), a_test, code); /* queue the job */
			if code ^= 0		/* error queueing job */
			then return;

		     end;

		end;
	     end;

	     else					/* not SNUMB card */
	     if substr (ascii, 1, 6) = "***eof"		/* eof card */
	     then eof_found = "1"b;

	     if eoc_found				/* end of input occurred */
	     then do;
		if ^eof_found			/* ***eof card not found */
		then do;
		     call com_err_ (0, "gcos_read_cards_", "Unexpected eof:  SNUMB = ^a", gcos_daemon_stat_$snumb);
		     code = 2;
		end;
		else				/* ***eof card found */
		call ioa_ ("Normal Termination");
	     end;

	     return;

	end get_snumb;
%page;
wrap_up:	proc (cleanup_was_signalled);

dcl  cleanup_was_signalled bit (1) aligned;

	     if cleanup_was_signalled | code > 1	/* abort or fatal error */
	     then do;
		call ios_$resetread (stream_name, status_stuff); /* delete any read-ahead */
		code2 = status.code;
		if code2 ^= 0			/* error deleting read-ahead */
		then do;
		     call com_err_ (code2, "gcos_read_cards_", "Error resetting ^a", stream_name);
		     if code <= 1			/* no fatal error occurred yet */
		     then code = code2;		/* return this one */
		end;
	     end;

	     if (code ^= 0)| (cleanup_was_signalled)	/* error occurred or job was aborted */
	     then do;
		if gcos_daemon_stat_$snumb = ""
		then return;
		call hcs_$delentry_file (get_wdir_ (),
				     rtrim (gcos_daemon_stat_$snumb)||".gcos",
				     code2);
	     end;

	     a_eof_found = eof_found;			/* return argument */

	     return;

	end wrap_up;
%page;
/* DECLARATIONS */
/* ------------ */

/* fixed bin */
/* ----- --- */

dcl (
     elements_read,					/* elements read from ios_ call */
     i,						/* random variable */
     j,						/* ditto */
     urgency					/* priority queues to be used */
     ) fixed bin aligned;

dcl (
     a_code,					/* error code (argument) */
     code,					/* error code (internal) */
     code2					/* secondary internal error code */
     ) fixed bin (35) aligned;


/* bit strings */
/* --- ------- */

dcl (
     a_eof_found,					/* ON when last job card is read */
     a_test,					/* ON when user brings up daemon */
     eoc_found,					/* ON when end of read input encountered */
     eof_found,					/* ON when last card is read */
     snumb_found					/* ON when a SNUMB card is found */
     ) bit (1) aligned;

dcl (
     status_stuff					/* returned status from ios_ calls */
     ) bit (72) aligned;

dcl (
     input					/* card image */
     ) bit (972) aligned;


/* pointers */
/* -------- */

dcl (
     input_ptr,					/* pointer to card image */
     output_ptr,					/* pointer to ascii card image */
     sp						/* pointer to returned status */
     ) pointer aligned;


/* character strings */
/* --------- ------- */

dcl  gcos_daemon_stat_$snumb ext char (6) aligned;
/* dcl  snumb char (8) aligned; */

dcl (
     a_stream_name,					/* stream name on which to read (argument) */
     stream_name					/* same (internal) */
     ) char (12) aligned;

dcl (
     ascii					/* ascii card image */
     ) char (80) aligned;


/* built in */
/* ----- -- */

dcl (
     addr,
     divide,
     index,
     substr
     ) builtin;


/* masks */
/* ----- */

dcl 1 status based (sp) aligned,			/* mask for checking status from ios_ */
    2 code fixed bin aligned,
    2 pad bit (9) unaligned,
    2 eof bit (1) unaligned;


/* include files */
/* ------- ----- */

% include gcos_abs_data;

% include gcos_abs_data_storage;


/* conditions */
/* ---------- */
dcl (
     cleanup
     )condition;


/* external entries */
/* -------- ------- */

dcl  com_err_ ext entry
     options (variable);

dcl  cv_bcd_to_ascii_ ext entry
    (ptr aligned, ptr aligned);

dcl  cv_bin_to_bcd_ ext entry
    (ptr aligned, ptr aligned, fixed bin (35) aligned);

dcl  cv_dec_check_ ext entry
    (char (*) aligned, fixed bin (35) aligned) returns (fixed bin aligned);

dcl  gcos_queue_job_ ext entry
    (ptr aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_read_$cards ext entry
    (fixed bin aligned, ptr aligned, ptr aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  get_wdir_ ext entry
     returns (char (168) aligned);

dcl  hcs_$delentry_file ext entry
    (char (*) aligned, char (*) aligned, fixed bin (35) aligned);

dcl  ioa_ ext entry
     options (variable);

dcl  ios_$read ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned);

dcl  ios_$resetread ext entry
    (char (*) aligned, bit (72) aligned);


end gcos_read_cards_;




		    gcos_read_tape_.pl1             11/19/82  1409.3rew 11/19/82  0853.2      217836



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* ********************************************************************
   *							*
   *	WRITTEN BY:	P. Haber		March 21, 1974	*
   *	MODIFIED BY:	R.H. Morrison	September 19, 1974	*
   *	MODIFIED BY:	R.H. Morrison	September 12, 1975	*
   *							*
   ******************************************************************** */

gcos_read_tape_: proc (a_request, a_request_len, a_test);
%page;
	ap = addr (request);			/* argument pointer */
	ascii_ptr = addr (ascii);			/* pointer to ascii version of card image */
	bcd_ptr = addr (b972);			/* pointer to bcd version of card image */
	rh_ptr = addr (record_header);		/* pointer to returned status from gcos_gsr_read_ */
	request_p = addr (request);			/* pointer to request line */
	sp = addr (status_bits);			/* pointer to status returned from ios calls */

	on condition (cleanup)			/* set up condition handler */
	     call wrap_up ("1"b);

/* check request line */

	request = a_request;			/* copy in arguments */
	request_len = a_request_len;

	call get_arg;				/* fetch the first argument */

	if arg = "imcv7"				/* request to read 7 track tape */
	then do;
	     tape_type = ",7track";
	     i = 6;				/* have parsed 6 characters */
	end;

	else
	if arg = "imcv"				/* 9 track request */
	then do;
	     tape_type = ",9track";
	     i = 5;				/* have parsed 5 characters */
	end;

	else					/* error, unrecognized request */
	do;
	     call com_err_ (0, "gcos_read_tape_", "Invalid tape read command^/^a", request);
	     go to RETURN;
	end;

	call get_arg;
	if code = error_table_$noarg			/* missing argument .. tape label */
	then do;
	     call com_err_ (code, "gcos_read_tape_", "Error in request ^/^a", request);
	     go to RETURN;
	end;
	tape_label = arg||tape_type;

	call get_arg;				/* get argument from command line */
	if code = error_table_$noarg			/* error, missing argument ... keyword */
	then do;
	     call com_err_ (code, "gcos_read_tape_", "Error in request^/^a", request);
	     go to RETURN;
	end;

	else					/* found argument */
	if arg = "all" | arg = "-all"			/* wants to execute all jobs */
	then all_snumbs_wanted = "1"b;

	else
	if arg = "take" | arg = "-take"		/* wants to execute specified SNUMBs */
	then taking_given_snumbs = "1"b;

	else
	if arg = "start" | arg = "-start"		/* wants to execute all SNUMBs after given one */
	then starting_from_given_snumb = "1"b;

	else
	if arg ^= "delete" & arg ^= "-delete"		/* unrecognized request */
	then do;
	     call com_err_ (0, "gcos_read_tape_", "invalid argument ^a", arg);
	     go to RETURN;
	end;

	call get_arg;				/* get next argument */
	if code = 0				/* there is another argument */
	then do;
	     if all_snumbs_wanted			/* error, shouldn't be another argument */
	     then do;
		call com_err_ (0, "gcos_read_tape_", "Too many arguments in ^/^a", request);
		go to RETURN;
	     end;
	end;

	else					/* no more arguments */
	if ^all_snumbs_wanted			/* error, need at least 1 more argument */
	then do;
	     call com_err_ (code, "gcos_read_tape_", "Error in request ^/^a", request);
	     go to RETURN;
	end;

	do while (code = 0);			/* get remaining arguments */

	     if al > 5				/* SNUMB too long */
	     then do;
		call com_err_ (0, "gcos_read_tape_", "SNUMB ^a too long", arg);
		go to RETURN;
	     end;

	     snumb_count = snumb_count + 1;		/* increment SNUMB count */
	     if (snumb_count>5)| (snumb_count>2 & starting_from_given_snumb) /* error, too many SNUMBs */
	     then do;
		call com_err_ (0, "gcos_read_tape_", "Too many SNUMBs specified in ^/^a", request);
		go to RETURN;
	     end;

	     do i = 1 to snumb_count -1;		/* check for SNUMB duplication */
		if snumb_data (i).snumb = arg		/* got one */
		then do;
		     call com_err_ (error_table_$namedup, "gcos_read_tape_", "in ^/^a", request);
		     go to RETURN;
		end;
	     end;

	     snumb_data (snumb_count).snumb = arg;	/* save snumb_data */

	     call get_arg;

	end;
%page;
/* set up gcos_gsr_read_ */

	if ^test_attach				/* tape needs to be attached */
	then do;

	     call ios_$attach ("tape_input", gcos_daemon_stat_$tape_dim, tape_label, "r", status_bits);
	     code = status.code;
	     if code ^= 0				/* error attaching tape */
	     then do;
		call com_err_ (code, "gcos_read_tape_", "Error attaching tape ^a", tape_label);
		go to RETURN;
	     end;
	     tape_is_attached = "1"b;			/* remember tape is attached */

	end;

	call gcos_gsr_read_$gsr_read_init ("tape_input", code); /* initialize read call */
	if code ^= 0				/* error in init call */
	then do;
	     call com_err_ (code, "gcos_read_tape_", "Error in call to gsr_read_init");
	     call wrap_up ("0"b);
	     go to RETURN;
	end;
	else					/* no error */
	gsr_read_init_called = "1"b;			/* remember it was called */

	do i = 1 to 2;				/* skip over tape label, tape mark */

	     call ios_$read ("tape_input", bcd_ptr, 0, 27, elements_read, status_bits);
	     if substr (status_bits, 1, 3) = "100"b	/* hardware status returned */
	     then do;
		if substr (status_bits, 27, 4) ^= "0100"b /* not "tape mark" status */
		then do;
		     call com_err_ (0, "gcos_read_tape_",
			"Unexpected hardware status from nstd_: ^w^w", substr (status_bits, 1, 36),
			substr (status_bits, 37, 36));
		     call wrap_up ("0"b);
		     go to RETURN;
		end;
	     end;

	     else					/* no status returned */
	     if status.code ^= 0			/* error code returned */
	     then do;
		call com_err_ (status.code, "gcos_read_tape_", "Error reading tape ^a", tape_label);
		call wrap_up ("0"b);
		go to RETURN;
	     end;

	end;
%page;
READ:						/* read the tape */

	if fin					/* all needed SNUMBs were found */
	then do;
	     call wrap_up ("0"b);
	     go to RETURN;
	end;

	call read;
	if code ^= 0				/* error in read call */
	then do;
	     call com_err_ (code, "gcos_read_tape_", "Error reading from tape");
	     call wrap_up ("0"b);
	     go to RETURN;
	end;

	if eot_was_found				/* end of tape */
	then do;
	     if ^all_snumbs_wanted			/* specified SNUMBs were being searched for */
	     then call check_snumbs;			/* inform as to SNUMBs not found */
	     call wrap_up ("0"b);
	     go to RETURN;
	end;

	call cv_bcd_to_ascii_ (buf_ptr, ascii_ptr);	/* convert card to ascii */

	if substr (ascii, 1, 6) = "***eof"		/* tapes sometimes have eofs */
	then do;
	     if last_image_was_eof			/* error, 2 eof images in a row */
	     then do;
		call com_err_ (0, "gcos_read_tape_", "Unexpected eof image on tape ^a", tape_label);
		call wrap_up ("0"b);
		go to RETURN;
	     end;
	     last_image_was_eof = "1"b;		/* remember for next read */
	     go to READ;				/* and read another card */
	end;
	else					/* card not "***eof" */
	last_image_was_eof = "0"b;			/* remember */

	if (substr (ascii, 1, 1) ^= "$")		/* not a SNUMB card image */
	| (substr (ascii, 8, 5) ^= "snumb")
	then do;
	     call com_err_ (0, "gcos_read_tape_", "Expected SNUMB not found on tape ^a", tape_label);
	     call find_ejb;
	     if (eot_was_found)| (code ^= 0)		/* error or end of tape */
	     then do;
		if code = 0
		then call check_snumbs;
		call wrap_up ("0"b);
		go to RETURN;
	     end;
	     go to READ;
	end;

	if all_snumbs_wanted			/* all jobs are to be executed */
	then do;
	     call parse_and_check_snumb;		/* parse the SNUMB (no check for "all") */
	     if code ^= 0				/* error parsing SNUMB */
	     then do;
		call find_ejb;
		if code ^= 0			/* error finding eof image */
		then do;
		     call wrap_up ("0"b);
		     go to RETURN;
		end;
		go to READ;
	     end;
	     call read_and_queue;			/* queue up current job */
	     if (code > 1)| (eot_was_found)		/* error or end of tape */
	     then do;
		call wrap_up ("0"b);
		go to RETURN;
	     end;
	     go to READ;				/* get another job */
	end;

	if (taking_given_snumbs)| (starting_from_given_snumb)
	then do;

	     call parse_and_check_snumb;		/* check to see if this is needed SNUMB */
	     if (^snumb_found)| (code ^= 0)		/* SNUMB not in array or already found */
	     then do;
		if ^starting_snumb_found		/* not a start request with first SNUMB found */
		then do;
		     call find_ejb;
		     if (eot_was_found)| (code ^= 0)	/* error or end of tape */
		     then do;
			if code = 0
			then call check_snumbs;
			call wrap_up ("0"b);
			go to RETURN;
		     end;
		     if ^snumb_found		/* no data to update */
		     then go to READ;		/* get another job */
		end;
	     end;

	     if starting_from_given_snumb
	     then do;
		if snumb_count = 1			/* found the only specified SNUMB */
		then do;
		     all_snumbs_wanted = "1"b;	/* execute remaining jobs on tape */
		     starting_from_given_snumb = "0"b;
		end;
		else				/* start and finish SNUMB supplied */
		do;
		     if ^snumb_data (1).found		/* error found finish before start */
		     then do;
			call com_err_ (0, "gcos_read_tape_", "Error in ^/^a^/^a found before ^a",
			     request, snumb_data (2).snumb, snumb_data (1).snumb);
			call wrap_up ("0"b);
			go to RETURN;
		     end;
		     else
		     do;
			if found_count = 2		/* found second */
			then fin = "1"b;		/* finished after processing this one */
			else			/* first of 2 SNUMBs found */
			starting_snumb_found = "1"b;	/* remember */
		     end;
		end;
	     end;

	     else					/* taking specified SNUMBs */
	     if found_count = snumb_count		/* all needed SNUMBs found */
	     then fin = "1"b;			/* done */

	     if code ^= 0				/* some error has occurred */
	     then go to READ;			/* don't queue up job */

	     call read_and_queue;			/* queue up current job */
	     if (code > 1)| (eot_was_found)		/* fatal error or end of tape */
	     then do;
		if code < 2			/* not fatal error */
		then call check_snumbs;
		call wrap_up ("0"b);
		go to RETURN;
	     end;

	     go to READ;				/* get another job */

	end;

	else					/* deleting specified SNUMBs */
	do;

	     call parse_and_check_snumb;

	     if (snumb_found)| (code ^= 0)
	     then do;

		call find_ejb;
		if (code ^= 0)| (eot_was_found)	/* error or end of tape */
		then do;
		     if code = 0
		     then call check_snumbs;
		     call wrap_up ("0"b);
		     go to RETURN;
		end;

		go to READ;

	     end;

	     else					/* job to be executed */
	     do;

		call read_and_queue;
		if (code > 1)| (eot_was_found)	/* fatal error or end of tape */
		then do;
		     if code < 2			/* not fatal error */
		     then call check_snumbs;
		     call wrap_up ("0"b);
		     go to RETURN;
		end;

		go to READ;

	     end;

	end;

RETURN:

	return;
%page;
/* internal procedures */

check_snumbs: proc;

	     do i = 1 to snumb_count;
		if ^snumb_data (i).found		/* SNUMB was not found on tape */
		then call com_err_ (0, "gcos_read_tape_", "SNUMB ^a not found on tape ^a"
		     , snumb_data (i).snumb, tape_label);
	     end;

	     return;

	end check_snumbs;



find_ejb:	proc;

dcl  ejb_was_found bit (1) aligned init ("0"b);

	     do while (^ejb_was_found);
		call read;
		if eot_was_found			/* end of tape */
		then return;
		if code ^= 0
		then do;
		     call com_err_ (code, "gcos_read_tape_", "Error searching for $ endjob");
		     return;
		end;

		if media_code = "0010"b		/* bcd image */
		then if first_bcd_char = "101011"b	/* "$" */
		     then do;
			call cv_bcd_to_ascii_ (buf_ptr, ascii_ptr);
			if substr (ascii, 8, 6) = "endjob" /* end of job card image found */
			then ejb_was_found = "1"b;
		     end;

	     end;

	     return;

	end find_ejb;



get_arg:	proc;

	     do j = j to request_len while		/* find beginning of next argument */
		     ((substr (request, j, 1) = " ")| (substr (request, j, 1) = "	"));
	     end;

	     do k = j to request_len while		/* find end of argument */
		     ((substr (request, k, 1) ^= " ")& (substr (request, k, 1) ^= " "));
	     end;
	     if k ^= request_len			/* not last argument */
	     then k = k - 1;			/* move index back to last char in arg */

	     if k < j				/* no next argument */
	     then do;
		code = error_table_$noarg;
		return;
	     end;

	     code = 0;				/* there is another argument */
	     ap = addr (request_p -> request_mask.char (j)); /* set argument pointer */
	     al = k - j + 1;			/* set argument length */
	     j = k + 1;				/* set beginning of next possible arg */

	     return;

	end get_arg;



parse_and_check_snumb: proc;

dcl (jj, kk, xb, xc, search_val) fixed bin aligned;
dcl  comma_found bit (1) aligned init ("0"b);

	     comma_found,
		snumb_found = "0"b;			/* initialize return argument */

	     xb = index (substr (ascii, 16), " ");	/* locate first blank in variable field */
	     xc = index (substr (ascii, 16), ",");	/* locate first comma in variable f eld */

	     if xb = 1 then
		do; code = 1;			/* return error */
		call com_err_ (0, "gcos_read_tape_", "A SNUMB is zero length on tape ^a", tape_label);
		return;
	     end;

	     if (xc = 0 | xc>xb) then xc = xb;		/* either no comma or not in SNUMB number field */
						/* set comma index to blank index */
	     else comma_found = "1"b;			/* remember */

	     if (xb<10 & xc<7) then snumb = substr (ascii, 16, xc-1);
						/* put SNUMB in fixed location */
	     else
	     do; snumb = substr (ascii, 16, 8);		/* report first 8 characters of SNUMB */
		code = 1;				/* return error */
		call com_err_ (0, "gcos_read_tape_",
		     "SNUMB ^a too long on tape ^a", snumb, tape_label);
		return;
	     end;

	     search_val = search (substr (ascii, 16, xc-1), ",$/:."); /* search for invalid characters */
	     if (search_val ^= 0) | (substr (ascii, 16, xc-1) = substr ("00000", 1, xc-1)) then
		do; code = 1;			/* return error */
		call com_err_ (0, "gcos_read_tape_",
		     "Invalid characters in SNUMB ^a on tape ^a", snumb, tape_label);
		return;
	     end;

	     if comma_found then
		do; urgency = cv_dec_check_ (substr (ascii, xc+16, xb-xc-1), code); /* convert to integer */
		if code ^= 0			/* conversion error */
		then do;
		     call com_err_ (0, "gcos_read_tape_", "Invalid urgency field: SNUMB = ^a, tape ^a",
			snumb, tape_label);
		     code = 1;
		     return;
		end;
		if (urgency < 1)| (urgency > 63)	/* invalid urgency field */
		then do;
		     urgency = 5;			/* set to real gcos default value */
		     call com_err_ (0, "gcos_read_tape_",
			"Out of bounds urgency set to default value: SNUMB = ^a, tape ^a",
			substr (ascii, 16, xb-1), tape_label);
		end;
		urgency = divide (63-urgency, 21, 17, 0) + 1; /* convert to Multics priority */
	     end;
	     else					/* no urgency field */
	     urgency = 3;				/* set default */

	     if ^all_snumbs_wanted			/* specified SNUMBs wanted, check this one */
	     then do jj = 1 to snumb_count while (^snumb_found);
		if snumb = snumb_data (jj).snumb	/* match found */
		then do;
		     snumb_found = "1"b;		/* remember */
		     if snumb_data (jj).found		/* SNUMB was already found */
		     then do;
			call com_err_ (0, "gcos_read_tape_", "SNUMB ^a duplicated on tape ^a", snumb, tape_label);
			code = 2;			/* fatal error */
		     end;
		     else
		     do;
			snumb_data (jj).found = "1"b;
			found_count = found_count + 1; /* increment count of found SNUMBs */
		     end;
		end;

	     end;

	     return;

	end parse_and_check_snumb;



read:	proc;

	     call gcos_gsr_read_ ("tape_input", buf_ptr, elements_read, record_header, eot_was_found, code);

	     return;

	end read;



read_and_queue: proc;
	     gcos_daemon_stat_$snumb = rtrim (snumb);
	     call gcos_read_$tape (urgency, buf_ptr, addr (gcos_abs_data), eot_was_found, code);
	     if code ^= 0				/* error reading rest of job */
	     then do;
		if code ^= 1			/* error was fatal */
		then return;
		if ^eot_was_found			/* not end of tape */
		then do;
		     call find_ejb;			/* find end of current job */
		     if code = 0			/* no error finding ejb */
		     then code = 1;			/* return non-fatal error */
		end;
		return;
	     end;

	     call gcos_queue_job_ (addr (gcos_abs_data), a_test, code);
	     if code = 0 then snumb = " ";

	     return;

end read_and_queue;
%page;
wrap_up:	proc (cleanup_was_signalled);

dcl  cleanup_was_signalled bit (1) aligned;

	     if (tape_is_attached|test_attach)
	     then do;

		if a_test				/* test entry was called */
		then do;				/* check to see if tape should be dismounted */
		     call command_query_ (addr (query_data), answer, "gcos_read_tape_",
			"Should tape ^a be dismounted?  ", tape_label);
		     if substr (answer, 1, 2) = "no"	/* don't dismount */
		     then do;
			call ios_$order ("tape_input", "rewind", null, status_bits);
			if status.code ^= 0
			then call com_err_ (status.code, "gcos_read_tape_",
			     "Error in order call to rewind ^a", tape_label);
			test_attach = "1"b;		/* remember tape was only rewound */
			go to NO_DETACH;
		     end;
		end;

		call ios_$detach ("tape_input", tape_label, "", status_bits); /* detach the tape */
		tape_is_attached = "0"b;
		test_attach = "0"b;			/* allows another attach */
		if status.code ^= 0
		then do;
		     if code < 2			/* no fatal error yet */
		     then code = status.code;
		     call com_err_ (status.code, "gcos_read_tape_", "Error detaching tape ^a", tape_label);
		end;

	     end;

NO_DETACH:

	     if gsr_read_init_called
	     then do;
		call gcos_gsr_read_$gsr_read_close ("tape_input", code);
		gsr_read_init_called = "0"b;
	     end;

	     if (code ^= 0)| (cleanup_was_signalled)	/* an error occurred or job was aborted */
	     then do;
		i = index (snumb, " ") - 1;
		if i < 1
		then return;
		call hcs_$delentry_file (get_wdir_ (), substr (snumb, 1, i)||".gcos", code);
	     end;

	     return;

	end wrap_up;
%page;
/* DECLARATIONS */
/* ------------ */


/* fixed bin */


dcl (
     a_request_len,					/* length of tape command (argument) */
     al,						/* argument length */
     arg_num init (0),				/* argument count from command line */
     elements_read,					/* number of elements read in ios call */
     found_count init (0),				/* count of SNUMBs found on tape */
     i,						/* loop index */
     j init (1),					/* loop index */
     k init (0),					/* loop index */
     request_len,					/* length of tape command (internal) */
     snumb_count init (0),				/* number of SNUMBs in tape command */
     urgency					/* computed urgency from SNUMB image */
     ) fixed bin aligned;

dcl (
     code,					/* error code */
     error_table_$namedup ext,
     error_table_$noarg ext
     ) fixed bin (35) aligned;


/* pointers */

dcl (
     ap,						/* argument pointer */
     ascii_ptr,					/* pointer to ascii version of card image */
     bcd_ptr,					/* pointer to bcd version of card image */
     buf_ptr,					/* pointer to tape record read by gcos_gsr_read_ */
     rh_ptr,					/* pointer to returned status from gcos_gsr_read_ */
     request_p,					/* pointer to request line */
     sp						/* pointer to status returned from ios calls */
     ) pointer aligned;


/* bit strings */

dcl (
     a_test					/* ON when deamon brought up by user */
     ) bit (1) aligned;

dcl (
     all_snumbs_wanted,				/* ON when every job found will be queued */
     eot_was_found,					/* ON when end of tape is encountered */
     fin,						/* ON when all given SNUMBs are found */
     gsr_read_init_called,				/* ON once gcos_gsr_read_$gsr_read_init has been called */
     last_image_was_eof,				/* ON when last card image was "***eof" */
     snumb_found,					/* ON when a SNUMB is found on tape */
     starting_from_given_snumb,			/* ON when start imcv request is made */
     starting_snumb_found,				/* ON when 1st of 2 SNUMBs in "start" found */
     taking_given_snumbs,				/* ON when take imcv request is made */
     tape_is_attached,				/* ON when tape is attached */
     test_attach int static				/* ON when tape is rewound, not detached */
     ) bit (1) aligned init ("0"b);

dcl (
     record_header					/* returned status from gcos_gsr_read_ */
     ) bit (12) aligned;

dcl (
     normal_termination				/* ON until tape terminates abnormally */
     ) bit (1) aligned init ("1"b);

dcl (
     status_bits					/* status returned from ios calls */
     ) bit (72) aligned;

dcl (
     b972						/* image read from tape */
     ) bit (972) aligned;


/* character strings */

dcl (
     answer					/* answer to command_query_ call */
     ) char (4) aligned;

dcl  gcos_daemon_stat_$snumb ext char (6) aligned;

dcl (
     gcos_daemon_stat_$tape_dim ext,			/* variable dim name for easy testing */
     snumb init (""),				/* SNUMB on current card */
     tape_type					/* = ",7track" or ",9track" */
     ) char (8) aligned;

dcl (
     tape_label init ("")				/* name of tape */
     ) char (32) aligned;

dcl (
     ascii					/* ascii version of card */
     ) char (80) aligned;

dcl (
     a_request,					/* imcv command (argument) */
     request					/* imcv command (internal) */
     ) char (120) aligned;


/* built in functions */

dcl (
     addr,
     divide,
     index,
     null,
     substr
     ) builtin;


/* structures */
dcl 1 query_data aligned,				/* structure for command_query_ call */
    2 version fixed bin aligned init (2),
    2 yes_or_no_switch bit (1) aligned init ("1"b),
    2 suppress_name_switch bit (1) aligned init ("1"b),
    2 status_code fixed bin (35) aligned,
    2 query_code fixed bin (35) aligned;

dcl 1 snumb_data (5) aligned,				/* snumb data taken from command */
    2 snumb char (8) aligned,				/* given SNUMB */
    2 found bit (1) aligned init ((5) (1) "0"b);		/* ON once SNUMB is found on tape */


/* masks */

dcl  arg char (al) based (ap) unaligned;		/* argument taken from command line or console */

dcl  first_bcd_char bit (6) unaligned based (buf_ptr);	/* first bcd character on card image */

dcl  input bit (612) unaligned based (buf_ptr);		/* pointer to bcd image */

dcl 1 record_header_mask aligned based (rh_ptr),
    2 pad bit (2) unaligned,
    2 media_code bit (4) unaligned,
    2 report_code bit (6) unaligned;

dcl 1 request_mask aligned based,			/* for looking at request character by character */
    2 char (request_len) char (1) unaligned;

dcl 1 status based (sp) aligned,			/* returned status from ios calls */
    2 code fixed bin (35) aligned,			/* error code */
    2 pad bit (9) unaligned,
    2 eof bit (1) unaligned;


/* conditions */

dcl (
     cleanup
     ) condition;


/* external entries */

dcl  com_err_ ext entry
     options (variable);

dcl  command_query_ ext entry
     options (variable);

dcl  cv_bcd_to_ascii_ ext entry
    (ptr aligned, ptr aligned);

dcl  cv_dec_check_ ext entry
    (char (*) aligned, fixed bin (35) aligned) returns (fixed bin aligned);

dcl  gcos_queue_job_ ext entry
    (ptr aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_read_$tape ext entry
    (fixed bin aligned, ptr aligned, ptr aligned, bit (1)aligned, fixed bin (35)aligned);

dcl  get_wdir_ ext entry
     returns (char (168) aligned);

dcl  gcos_gsr_read_ ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned, bit (1) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_read_$gsr_read_close ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  gcos_gsr_read_$gsr_read_init ext entry
    (char (*) aligned, fixed bin (35) aligned);

dcl  hcs_$delentry_file ext entry
    (char (*) aligned, char (*) aligned, fixed bin (35) aligned);

dcl  ios_$attach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$detach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

dcl  ios_$order ext entry
    (char (*) aligned, char (*) aligned, ptr aligned, bit (72) aligned);

dcl  ios_$read ext entry
    (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned);
%page;
% include gcos_abs_data;
%page;
% include gcos_abs_data_storage;

end gcos_read_tape_;




		    gcos_verify_user_.pl1           11/19/82  1409.3rew 11/19/82  0930.1       20214



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


gcos_verify_user_: proc (a_project, a_password, a_multics_person, a_multics_project, a_code);


/* DECLARATIONS */
/* ------------ */


/* fixed bin */

dcl (
     a_code,					/* error code (argument) */
     code						/* error code (internal) */
     ) fixed bin (35) aligned;


/* character strings */

dcl (
     a_multics_project				/* multics equivalent of gcos project (argument) */
     ) char (9) aligned;

dcl (
     a_password,					/* GCOS password (argument) */
     a_project,					/* GCOS project (argument) */
     password,					/* GCOS password (internal) */
     project					/* gcos project (internal) */
     ) char (12) aligned;

dcl (
     a_multics_person				/* multics equivalent of gcos user (argument) */
     ) char (22) aligned;


/* include files */

% include gcos_user_table_entry_;


/* external entries */

dcl  gcos_user_$validate ext entry
    (char (12) aligned, char (12) aligned, ptr aligned, fixed bin (35) aligned);


/*  */

	a_code = 0;				/* initialize returned code */
	project = a_project;			/* copy in input arguments */
	password = a_password;

	call gcos_user_$validate (project, password, gutep, code); /* validate password */

	if code = 0				/* password is valid */
	then do;
	     a_multics_person = gutep -> gcos_user_table_entry_.gute_multics_person;
	     a_multics_project = gutep -> gcos_user_table_entry_.gute_multics_project;
	end;

	else					/* some error occurred */
	do;
	     a_multics_person,
	     a_multics_project = "";
	     if code < 3				/* error is in project-password combination */
	     then a_code = 1;			/* return non-fatal error */
	     else					/* error is elsewhere */
	     a_code = 2;				/* return fatal error */
	end;

	return;

     end gcos_verify_user_;





		    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
