



		    accounts_overseer_.pl1          08/29/88  0947.9rew 08/29/88  0856.3       74169



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

/* format: style4 */
accounts_overseer_: proc;

/* Special login responder for user accounts */
/* modified July 1972 by J.Phillipps to get ready for v2 pl/1  */
/* iox'ed and cleaned up August 1981 by E. N. Kittlitz */
/* master_ec_error_ added as synonym for program_interrupt, September 1982, E. N. Kittlitz. */


/****^  HISTORY COMMENTS:
  1) change(87-08-25,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-04,Lippard), install(88-08-29,MR12.2-1093):
     Avoid doing iox_$control quit_enable when running as absentee; abs_io_
     does not implement this control so we produce an unnecessary error
     message. (phx16088)
                                                   END HISTORY COMMENTS */


dcl  cl_safe_intermediary entry variable;
dcl  code fixed bin (35);
dcl  command char (32) defined (whole_line) pos (1);
dcl  i fixed bin;
dcl  input_line char (224) defined (whole_line) pos (33);
dcl  k fixed bin;
dcl  ll fixed bin (21);
dcl  m fixed bin;
dcl  ml fixed bin;
dcl  mp ptr;
dcl  path char (168);
dcl  sp ptr;
dcl  whole_line char (256);

dcl  setup_handlers bit (1) int static init ("0"b);
dcl  testmode bit (1) int static init ("0"b);

dcl  change_wdir_ entry (char (168) aligned, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  condition_ entry (char (*), entry);
dcl  condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr);
dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
dcl  cu_$get_cl_intermediary entry (entry);
dcl  cu_$ready_proc entry;
dcl  cu_$set_cl_intermediary entry (entry);
dcl  cu_$stack_frame_ptr entry (ptr);
dcl  debug entry;
dcl  get_system_free_area_ entry (ptr);
dcl  ioa_ entry options (variable);
dcl  ioa_$ioa_switch_nnl entry () options (variable);
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$user_input ptr external static;
dcl  iox_$user_io ptr external static;
dcl  program_interrupt entry;
dcl  trace_stack_ entry (ptr, fixed bin, fixed bin, char (32) aligned);
dcl  user_info_$homedir entry (char (*));
dcl  user_info_$process_type entry returns (fixed bin);

dcl  (addr, index, length, null, search, substr, verify) builtin;

dcl  ncoms fixed bin int static init (36),
     comnam (36) char (32) aligned int static init
	("list", "mail", "status", "listacl", "who",
	"ls", "ml", "st", "la", "",
	"enter_abs_request", "value$set", "value$dump", "getquota", "movequota",
	"ear", "", "", "gq", "mq",
	"logout", "list_abs_requests", "cancel_abs_request", "setacl", "deleteacl",
	"", "lar", "car", "sa", "da",
	"y0", "y1", "y2", "y3", "y4", "y5");

dcl  INTERACTIVE init(1) fixed bin int static options(constant);
dcl  NL char (1) aligned int static init ("
");

dcl  berrm char (ml) based (mp) unaligned;


/* ============================================================================== */


start:
	call cu_$get_cl_intermediary (cl_safe_intermediary);
	call cu_$set_cl_intermediary (quit);
	setup_handlers = "1"b;
	call condition_ ("any_other", ucs);
	call condition_ ("master_ec_error_", pi_h);
	call condition_ ("program_interrupt", pi_h);
	call condition_ ("quit", quit);
	if user_info_$process_type() = INTERACTIVE then do;
	     call iox_$control (iox_$user_io, "quit_enable", null, code);
	     if code ^= 0 then
	          call com_err_ (code, "accounts_overseer_", "");
	     end;					/* don't enable quits in absentee, abs_io_ complains */

	if ^testmode then do;
	     call user_info_$homedir (path);
	     call change_wdir_ ((path), code);
	     if code ^= 0 then do;
		call com_err_ (code, "accounts_overseer_", "Unable to set working directory ^a.", path);
		return;
	     end;
	end;

	command = "exec_com start_up";
	call cu_$cp (addr (command), length (command), code);
	if code ^= 0 then call com_err_ (code, "accounts_overseer_", "");

restart:	call cu_$ready_proc;
restart1:
	call iox_$get_line (iox_$user_input, addr (input_line), length (input_line), ll, code);
	if code ^= 0 then call com_err_ (code, "accounts_overseer_", "");
	if ll <= 1 then go to restart1;
	substr (input_line, ll) = "";
	if index (substr (input_line, 1, ll), ";") ^= 0 then do;
	     call ioa_ ("Illegal syntax");
	     go to restart;
	end;
	i = verify (substr (input_line, 1, ll), " 	"); /* Strip leading blanks and tabs. */
	if i = 0 then go to restart1;			/* If all blanks */
	k = search (substr (input_line, i, ll - i + 1), " 	"); /* Find end of command. */
	if k = 0 then command = substr (input_line, i, ll - i + 1);
	else command = substr (input_line, i, k - 1);
	if command = "" then go to restart1;

	do i = 1 to ncoms;
	     if command = comnam (i) then do;
		call cu_$cp (addr (input_line), ll, code);
		if code ^= 0 then call com_err_ (code, "accounts_overseer_", "");
		go to restart;
	     end;
	end;

	if testmode then do;
	     if (command = "debug" | command = "db") then do;
		call debug;
		go to restart;
	     end;
	     else if command = "quit" | command = "q" | command = "exit" then do;
		if setup_handlers then
		     call cu_$set_cl_intermediary (cl_safe_intermediary);
		return;
	     end;
	end;					/* testmode */

	command = "exec_com master";
	call cu_$cp (addr (command), ll + 32, code);
	if code ^= 0 then call com_err_ (code, "accounts_overseer_", "");

	go to restart;

test: entry;

	testmode = "1"b;
	setup_handlers = "0"b;
	go to restart;

test_with_handlers: entry;

	testmode = "1"b;
	go to start;

/* ============================================================================== */

ucs: proc (mcptr, cname, coptr, infoptr, contin);

dcl  (mcptr, coptr, infoptr, areap) ptr,
     contin bit (1),
     cname char (*);

dcl  k fixed bin,
     i fixed bin;

	if cname = "cleanup" then return;
	if cname = "finish" then return;
	if cname = "mme2" then do; contin = "1"b; return; end;
	if cname = "command_error" then return;
	if cname = "command_query" then return;
	if cname = "command_question" then return;

	call get_system_free_area_ (areap);
	call condition_interpreter_ (areap, mp, ml, 3, mcptr, cname, coptr, infoptr);
	k = 1;
	do i = 1 to ml;
	     if substr (berrm, i, 1) = NL then do;
		if i - k > 0 then call ioa_ ("^a", substr (berrm, k, i - k));
		k = k + i;
	     end;
	end;
	free berrm;


quit: entry;

queep:
	call iox_$control (iox_$user_input, "resetread", null, code);
	if code ^= 0 then call com_err_ (code, "accounts_overseer_", "performing resetread");
	call ioa_$ioa_switch_nnl (iox_$user_io, "^/^B??? ");
	m = 0;
	call iox_$control (iox_$user_io, "start", null, code);
	if code ^= 0 then call com_err_ (code, "accounts_overseer_", "");
	call iox_$get_line (iox_$user_input, addr (input_line), length (input_line), ll, code);
	if code ^= 0 then call com_err_ (code, "accounts_overseer_", "");
	substr (input_line, ll) = "";			/* clear rest of line */
	if substr (input_line, 1, 2) = "db" |
	     substr (input_line, 1, 5) = "debug" then
	     if testmode then call debug;
	     else do;
		call cu_$stack_frame_ptr (sp);
		call trace_stack_ (sp, 1, -1, "error_output");
		go to queep;
	     end;
	else if substr (input_line, 1, 2) = "sr" then go to do_sr;
	else if substr (input_line, 1, 5) = "start" then do;
do_sr:	     return;
	end;
	else if substr (input_line, 1, 2) = "pi" then call program_interrupt; /* the auditor said I could */
	else go to queep;

     end ucs;

pi_h: proc;

	call iox_$control (iox_$user_input, "resetread", null, code);
	if code ^= 0 then call com_err_ (code, "accounts_overseer_", "performing resetread");
	go to restart;

     end pi_h;

     end;




		    admin_util.pl1                  07/13/88  1122.2r w 07/13/88  0940.7       94815



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


/* format: style4 */
admin_util: proc;

/* originally coded by K.Willis  4/5/71  */
/* upgraded for version 2 pl/1 July 1972 by J.Phillipps */
/* Modified by T.H. VanVleck, .... 1974 to include default values for a new project */
/* Modified by T. Casey, Feb 1975 to fix bugs */
/* Modified by T. Casey, September 1977 to allow deletions of uwt table entries. */
/* Modified by E. N. Kittlitz, June 1982 for user_attributes.incl.pl1. */
/* Modified 1984-09-11 BIM for removal of max_users. */
/* Modified 1984-12-14 by EJ Sharpe for addition of default_audit_flags, also
   removed log_control references for Benson */

dcl  bchr char (al) based (ap) unaligned,
     ap ptr,
     (i, j) fixed bin,
     al fixed bin,
     ec fixed bin (35),
     ttt fixed bin init (60),
     dum char (12) aligned,
     (has, hasnt) bit (36),
     uname char (24) aligned,
     key char (32) aligned,
     wt fixed bin,
     sadp ptr,
     (satp, satep) ptr init (null),
     atts char (512) var,
     flags_str char (256),
     datstr char (24) aligned;

dcl  parse_attributes_ entry (char (*) aligned, bit (36), bit (36), fixed bin (35)),
     format_attributes_ entry (ptr, char (*) var),
     date_time_ entry (fixed bin (71), char (*) aligned),
     get_wdir_ entry () returns (char (168) aligned),
     user_info_ entry options (variable),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
	fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     error_table_$lock_wait_time_exceeded fixed bin (35) ext,
     error_table_$badopt fixed bin (35) ext,
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     com_err_ entry options (variable),
     set_lock_$unlock entry (bit (36) aligned, fixed bin (35)),
     set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)),
     cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     signal_ entry (char (*)),
     ioa_ entry options (variable),
     convert_access_audit_flags_$from_string entry (char (*), bit (36) aligned, fixed bin (35)),
     convert_access_audit_flags_$to_string entry (bit (36) aligned, char (*), fixed bin (35));


dcl  (addr, null) builtin;

dcl  1 default_attributes aligned based (addr (sys_admin_data.default_proj_attributes)),
       2 at aligned like user_attributes;

/* ----------------------------------- */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "admin_util", "");
	     return;
	end;
	call hcs_$initiate ((get_wdir_ ()), "sys_admin_data", "", 0, 1, sadp, ec);
	if sadp = null then go to er;
	if bchr = "lock" then do;
	     call cu_$arg_ptr (2, ap, al, ec);
	     if ec ^= 0 then ttt = 60;
	     else do;
		ttt = cv_dec_check_ (bchr, ec);
		if ec ^= 0 then go to badarg;
	     end;
	     call lock_sad;
	end;
	else if bchr = "unlock" then do;
	     call set_lock_$unlock (sadp -> sys_admin_data.lock, ec);
	     if ec ^= 0 then go to er;
	end;
	else if bchr = "print" then do;
	     call ioa_ ("^/SYS ADMIN DATA");
	     if sys_admin_data.lock = (36)"0"b then dum = "-unlocked-"; else dum = "-locked-";
	     call ioa_ ("^/lock:^-^-^a", dum);
	     call ioa_ ("locker:^-^-^a", sys_admin_data.locker);
	     call ioa_ ("");
	     call ioa_ ("user_accts_office:^-^a", sys_admin_data.user_accounts_office);
	     call ioa_ ("user_accts_addr:^-^a", sys_admin_data.user_accounts_addr);
	     call ioa_ ("user_accts_phone:^-^a", sys_admin_data.user_accounts_phone);
	     call ioa_ ("mailing banner:");
	     do i = 1 to 3;
		call ioa_ ("^10xb^d:^-^a", i, sys_admin_data.mailing_banner (i));
	     end;
	     call ioa_ ("^/Default project attributes:");
	     call format_attributes_ (addr (sys_admin_data.default_proj_attributes), atts);
	     call ioa_ ("Attributes:^-^a", atts);
	     call ioa_ ("Init_ring:^-^d", sys_admin_data.default_proj_ring1);
	     call ioa_ ("Max_ring:^-^-^d", sys_admin_data.default_proj_ring2);
	     call ioa_ ("Group:^-^-^a", sys_admin_data.default_proj_group);
	     call ioa_ ("Grace:^-^-^d", sys_admin_data.default_proj_grace);
	     call convert_access_audit_flags_$to_string (sys_admin_data.default_audit_flags, flags_str, ec);
	     if ec ^= 0 then flags_str = "invalid binary flags";
	     call ioa_ ("Audit flags:^-^a", flags_str);
	end;
	else if bchr = "dft" then go to dfts;
	else if bchr = "default" then go to dfts;
	else if bchr = "set" then do;
dfts:	     call cu_$arg_ptr (2, ap, al, ec);
	     if ec ^= 0 then go to er;
	     key = bchr;
	     call cu_$arg_ptr (3, ap, al, ec);
	     if ec ^= 0 then go to er;
	     call lock_sad;
	     if key = "user_accts" then sys_admin_data.user_accounts_office = bchr;
	     else if key = "user_accts_addr" then sys_admin_data.user_accounts_addr = bchr;
	     else if key = "user_accts_phone" then sys_admin_data.user_accounts_phone = bchr;
	     else if key = "user_accts_office" then sys_admin_data.user_accounts_office = bchr;
	     else if key = "b1" then sys_admin_data.mailing_banner (1) = bchr;
	     else if key = "b2" then sys_admin_data.mailing_banner (2) = bchr;
	     else if key = "b3" then sys_admin_data.mailing_banner (3) = bchr;
	     else if key = "attributes" then do;
		call parse_attributes_ ((bchr), has, hasnt, ec);
		if ec ^= 0 then go to badarg1;

/* The meanings of the primary, secondary (standby), and edit_only bits
   in the attributes word are reversed for internal versus external use.
   Internally, a 1-bit means a user is allowed to log in as a primary,
   secondary, or edit_only user. Externally, when an administrator edits attributes, he
   must type the keywords no_primary, no_secondary, or no_edit_only (for historical reasons).
   The parse_attributes_ subroutine returns a 1-bit for no_prime, and a 0-bit for ^no_prime, for example.
   To resolve this incompatibility, we complement the current internal values of these bits,
   so they become compatible with the external input values. Then we make the requested changes.
   Finally, we complement these 3 bits back to their internal values.
*/

		default_attributes.at.pm_ok = ^default_attributes.at.pm_ok;
		default_attributes.at.sb_ok = ^default_attributes.at.sb_ok;
		default_attributes.at.eo_ok = ^default_attributes.at.eo_ok;
		sys_admin_data.default_proj_attributes = sys_admin_data.default_proj_attributes & ^hasnt;
		sys_admin_data.default_proj_attributes = sys_admin_data.default_proj_attributes | has;
		default_attributes.at.pm_ok = ^default_attributes.at.pm_ok;
		default_attributes.at.sb_ok = ^default_attributes.at.sb_ok;
		default_attributes.at.eo_ok = ^default_attributes.at.eo_ok;
	     end;
	     else if key = "init_ring" then do;
		sys_admin_data.default_proj_ring1 = cv_dec_check_ (bchr, ec);
		if ec ^= 0 then go to badarg1;
	     end;
	     else if key = "max_ring" then do;
		sys_admin_data.default_proj_ring2 = cv_dec_check_ (bchr, ec);
		if ec ^= 0 then go to badarg1;
	     end;
	     else if key = "group" then sys_admin_data.default_proj_group = bchr;
	     else if key = "grace" then do;
		sys_admin_data.default_proj_grace = cv_dec_check_ (bchr, ec);
		if ec ^= 0 then go to badarg1;
	     end;
	     else if key = "audit" | key = "audit_flags" then do;
		call convert_access_audit_flags_$from_string (bchr,
		     sys_admin_data.default_audit_flags, ec);
		if ec ^= 0 then go to badarg1;
	     end;
	     else if key = "uwt" then do;
		if bchr = "dl" | bchr = "delete" | bchr = "-dl" | bchr = "-delete"
		then wt = -1;			/* remember to delete it */
		else do;				/* convert weight */
		     wt = cv_dec_check_ (bchr, ec);
		     if ec ^= 0 | wt < 0 then go to badarg1;
		end;
		call cu_$arg_ptr (4, ap, al, ec);
		if ec ^= 0 then do;
		     call com_err_ (ec, "admin_util", "");
		     go to badarg2;
		end;
		call get_sat;
		do i = 1 to sat.uwt_size while (sat.uwt (i).initproc ^= bchr); end;
		if wt = -1 & i > sat.uwt_size then do;	/* if one to be deleted was not found */
		     call com_err_ (0, "admin_util", "^a not in table", bchr);
		     goto badarg2;
		end;
		if i > 24 then do;
		     call com_err_ (0, "admin_util", "UWT overflow. Maximum 24");
		     go to badarg2;
		end;
		if wt = -1 then do;			/* delete this one */
		     do j = i + 1 to sat.uwt_size;	/* move the others up */
			sat.uwt (j - 1).initproc = sat.uwt (j).initproc;
			sat.uwt (j - 1).units = sat.uwt (j).units;
		     end;
		     sat.uwt_size = sat.uwt_size - 1;	/* decrement the count */
		end;
		else do;				/* add this one */
		     sat.uwt_size = max (i, sat.uwt_size);
		     sat.uwt (i).initproc = bchr;
		     sat.uwt (i).units = wt;
		end;
	     end;
	     else if key = "administrator1" then do;
		call get_sat;
		sat.system_admin (1) = bchr;
	     end;
	     else if key = "administrator2" then do;
		call get_sat;
		sat.system_admin (2) = bchr;
	     end;
	     else if key = "max_units" then do;
		call get_sat;
		sat.max_units = cv_dec_check_ (bchr, ec);
		if ec ^= 0 then go to badarg1;
	     end;
	     else do;
badarg1:		call com_err_ (error_table_$badopt, "admin_util", bchr);
	     end;
badarg2:	     call set_lock_$unlock (sys_admin_data.lock, ec);
	     if ec ^= 0 then go to er;
	     if satp ^= null then call hcs_$terminate_noname (satp, ec);
	end;
	else do;
badarg:	     call com_err_ (error_table_$badopt, "admin_util", bchr);
	end;
	call hcs_$terminate_noname (sadp, ec);

/* ----------------------------------------- */

lock_sad: proc;

	call set_lock_$lock (sadp -> sys_admin_data.lock, ttt, ec);
	if ec = error_table_$lock_wait_time_exceeded then do;
	     call com_err_ (ec, "admin_util", "sys_admin_data locked by ^a", locker);
	     call signal_ ("program_interrupt");	/* can't use pl1 signal - default_error_handler_ */
	     return;
	end;
	call user_info_ (uname);
	sys_admin_data.locker = uname;

     end;

get_sat: proc;

	call hcs_$initiate ((get_wdir_ ()), "smf.cur.sat", "", 0, 1, satp, ec);
	if satp = null then go to er;

     end;
%page;
%include sat;
%page;
%include sys_admin_data;
%page;
%include user_attributes;

     end admin_util;




		    authenticate_device.pl1         07/18/86  1501.1rew 07/18/86  1235.1       47448



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




/****^  HISTORY COMMENTS:
  1) change(86-04-10,Fawcett), approve(86-04-10,MCR7383),
     audit(86-05-15,Martinson), install(86-07-18,MR12.0-1098):
     Add the error codes auth_incorrect and auth_unknown problem found when
     implementing subvolumes.
                                                   END HISTORY COMMENTS */


authenticate_device:
     proc;

/*
   This command is used by the operator to authenticate a tape or disk volume.
   It takes two arguments: the device name of the drive on which the volume is
   mounted, and for tapes, the three letter authenticaion code printed on the tape
   label (note that "***" will authenticate any label), or for disks, one of the
   codes "ss", "io", "urd", "urg", or "no" which must match the type of volume
   in the authentication message (note that "no" denies authentication).
   It then calls a gate in RCP to check the authenticaiton code against the user
   specified volume.
*/

/*
   Written by R.J.C. Kissel in September 1977.
   Modified by R.J.C. Kissel 1/79 to handle disk authentication.
   Modified by C. D. Tavares 04/24/79 for new authentication levels.
*/

dcl  device_name char (8);				/* Unique physical device name. */
dcl  authentication_code char (3);			/* Authentication code for the volume. */
dcl  err_msg char (128) varying;			/* Informative message for com_err_ call */
dcl  nargs fixed bin;				/* Number of args this command was called with. */
dcl  dlen fixed bin;				/* Length of the device_name. */
dcl  code fixed bin (35);				/* Error code. */

dcl  arg char (arg_len) based (arg_ptr);
						/* Overlay for the command arguments. */
dcl  arg_len fixed bin;
dcl  arg_ptr ptr;

dcl  rcp_sys_$authenticate_device entry (char (*), char (*), fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);

dcl (error_table_$auth_incorrect,
     error_table_$auth_unknown,
     error_table_$noarg,
     error_table_$too_many_args,
     error_table_$improper_data_format,
     error_table_$action_not_performed) external fixed bin (35);

dcl (substr, verify) builtin;

	call cu_$arg_count (nargs);

	if nargs > 2
	then do;
	     call com_err_ (error_table_$too_many_args, "authenticate_device",
		"Usage is: authenticate_device device_name authentication_code.");
	     return;
	end;

	if nargs <= 1
	then do;
	     call com_err_ (error_table_$noarg, "authenticate_device",
		"Usage is: authenticate_device device_name authentication_code.");
	     return;
	end;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);

	if code ^= 0
	then do;
	     call com_err_ (code, "authenticate_device");
	     return;
	end;

	device_name = arg;
	dlen = arg_len;
	call cu_$arg_ptr (2, arg_ptr, arg_len, code);

	if code ^= 0
	then do;
	     call com_err_ (code, "authenticate_device");
	     return;
	end;

	authentication_code = arg;

/*
   Make a consistency check on the device name.
*/

	if substr (device_name, dlen-2, 1) ^= "_"
	| verify (substr (device_name, dlen-1, 2), "0123456789") ^= 0
	| verify (substr (device_name, 1, dlen-3), "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") ^= 0
	then do;
	     call com_err_ (0, "authenticate_device", "Invalid device name: ^a.", device_name);
	     return;
	end;

/*
   Make a consistency check on the authentication code.
*/

	if verify (authentication_code, " abcdefghijklmnopqrstuvwxyz*") ^= 0
	then do;
	     call com_err_ (0, "authenticate_device", "Invalid authentication code: ^a.", authentication_code);
	     return;
	end;

/*
   For disks make one more check of the authentication code.
*/

	if substr (device_name, 1, 3) = "dsk"
	then do;
	     if authentication_code ^= "ss" & authentication_code ^= "io" & authentication_code ^= "urd"
	     & authentication_code ^= "urg" & authentication_code ^= "no"
	     then do;
		call com_err_ (0, "authenticate_device", "Unknown disk authentication code: ^a.",
		     authentication_code);
		return;
	     end;
	end;

/*
   Everything looks good here.
*/

	call rcp_sys_$authenticate_device (device_name, authentication_code, code);

	if code ^= 0
	then do;

	     if code = error_table_$action_not_performed then do;
		code = 0;
		err_msg = "Device ^a not requesting authentication.";
	     end;
	     else if code = error_table_$improper_data_format then do;
		code = 0;
		err_msg = "Authentication ""***"" not allowed for device ^a.";
	     end;
	     else if code = error_table_$auth_incorrect |
	          code = error_table_$auth_unknown then err_msg = "For device ^a";
	     else err_msg = "Device ^a not found.";

	     call com_err_ (code, "authenticate_device", err_msg, device_name);
	end;

	return;

     end authenticate_device;




		    b_and_w.pl1                     04/09/85  1438.3r w 04/08/85  1133.4       79515



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

/* format: style3 */

b_and_w:
     procedure options (variable);

/* produce "black and white" chart */

/* Modified 1984-08-31 BIM for v3 usage totals */

dcl	dn		char (168),
	en		char (32),
	(l1, l2)		char (120),
	xx		char (1),
	datstr		char (16),
	datstr1		char (16),
	fmts		char (4) init ("from"),
	c4		char (4),
	(i, j, k, l, m, n)	fixed bin,
	time2		fixed bin (71),
	ap		ptr,
	al		fixed bin (21),
	an		fixed bin init (2),
	bchr		char (al) unaligned based (ap),
	ec		fixed bin (35),
	xtotp		ptr;

dcl	(absda, mm, dd, yy, hh, mmm, ss, wkd, xwkd, xmm, xdd, xyy, shf)
			fixed bin;

declare	arg_count		fixed bin;

dcl	(addr, null, substr, index, unspec, length, bit, fixed, divide, mod, abs)
			builtin;

dcl	datebin_$revert	entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71));
dcl	datebin_		entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
			fixed bin, fixed bin, fixed bin);
dcl	system_info_$titles entry options (variable);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	expand_pathname_$add_suffix
			entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl	ioa_		entry options (variable);
dcl	ioa_$rsnnl	entry options (variable);
dcl	date_time_	entry (fixed bin (71), char (*));
dcl	com_err_$suppress_name
			entry () options (variable);
dcl	com_err_		entry options (variable);

dcl	pathname_		entry (character (*), character (*)) returns (character (168));
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	initiate_file_	entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35))
			;
dcl	terminate_file_	entry (pointer, fixed binary (24), bit (*), fixed binary (35));

dcl	error_table_$badopt fixed bin (35) ext;
dcl	error_table_$unimplemented_version
			fixed bin (35) ext;

dcl	linex		char (130) int static init ((130)"-");
dcl	format		char (44) int static init ("|^4a|^16a|^16a|^16a|^16a|^16a|^16a|^16a|^4a|");
dcl	head		char (132) int static
			init (
			" Time Sunday^10x Monday^10x Tuesday^9x Wednesday^7x Thursday^8x Friday^10x Saturday^8x Time"
			);

declare	cleanup		condition;
declare	ME		char (32) init ("b_and_w") int static options (constant);

%page;
%include access_mode_values;
%include terminate_file;
%include use_totals;


	use_totals_ptr = null ();
	on cleanup call clean_up;
	call cu_$arg_count (arg_count, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME);
		return;
	     end;
	if arg_count = 0
	then do;
		call com_err_$suppress_name (0, ME, "Usage: b_and_w USE_TOTALS");
		return;
	     end;
	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_$add_suffix (bchr, "use_totals", dn, en, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "Invalid use totals pathname ^a.", bchr);
		return;
	     end;
	call initiate_file_ (dn, en, R_ACCESS, use_totals_ptr, (0), ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a", pathname_ (dn, en));
		return;
	     end;

	if use_totals.version ^= USE_TOTALS_VERSION_3
	then
UT_VERSION_ERROR:
	     do;
		call com_err_ (error_table_$unimplemented_version, ME, "^a is not version 3.", pathname_ (dn, en));
		go to ERROR;
	     end;

	call datebin_ (use_totals.time_last_sample, absda, mm, dd, yy, hh, mmm, ss, wkd, shf);
	if wkd = 7
	then wkd = 0;

	call datebin_$revert (mm, dd - wkd, yy, 0, 0, 0, time2);
	call date_time_ (time2, datstr1);
	call date_time_ (use_totals.time_last_sample, datstr);

	do an = 2 to arg_count;
	     call cu_$arg_ptr (an, ap, al, (0));
	     if bchr = "-week"
	     then do;
		     call datebin_$revert (mm, dd - wkd - 1, yy, 23, 59, 0, time2);
						/* 2359 saturday */
		     call date_time_ (time2, datstr);	/* Change title to last date. */
		     datstr1 = "last week";
		     fmts = "for";
		     wkd = wkd + 7;
		end;
	     else if index (bchr, "-") = 1
	     then do;
		     call com_err_ (error_table_$badopt, ME, "^a", bchr);
		     go to ERROR;
		end;
	     else do;
		     call expand_pathname_$add_suffix (bchr, "use_totals", dn, en, ec);
		     if ec ^= 0
		     then do;
			     call com_err_ (ec, ME, "Invalid second use totals pathname ^a", bchr);
			     go to ERROR;
			end;
		     call initiate_file_ (dn, en, R_ACCESS, xtotp, (0), ec);
		     if ec ^= 0
		     then do;
			     call com_err_ (ec, ME, "^a", pathname_ (dn, en));
			     go to ERROR;
			end;
		     call datebin_ (xtotp -> use_totals.time_last_sample, absda, xmm, xdd, xyy, hh, mmm, ss, xwkd,
			shf);
		     if xwkd = 7
		     then xwkd = 0;
		     if xtotp -> use_totals.version ^= USE_TOTALS_VERSION_3
		     then goto UT_VERSION_ERROR;
		end;
	end;

	call system_info_$titles (xx, xx, l1, l2);
	call ioa_ ("^|^-^-^a^/^/^-^-^-^a^/", l1, l2);
	call ioa_ ("^-^-Multics availability ^a ^a to ^a^/", fmts, datstr1, datstr);
	call ioa_ (head);
	call ioa_ (linex);
	do i = 0 to 95;
	     c4 = timef (i);
	     if c4 = "0800"
	     then call ioa_ (linex);
	     else if c4 = "1200"
	     then call ioa_ ("^|");
	     else if c4 = "1800"
	     then call ioa_ (linex);
	     call ioa_ (format, c4, block (i, 0), block (i, 1), block (i, 2), block (i, 3), block (i, 4), block (i, 5),
		block (i, 6), c4);
	end;
	call ioa_ (linex);

ERROR:
	call clean_up;
	return;


timef:
     proc (ii) returns (char (4));

dcl	ii		fixed bin;

dcl	t		fixed bin,
	tstr		char (4),
	ti		fixed bin;

	t = divide (ii, 4, 17, 0);
	call ioa_$rsnnl ("^2d00", tstr, ti, t);
	if substr (tstr, 1, 1) = " "
	then substr (tstr, 1, 1) = "0";
	t = mod (ii, 4);
	if t = 0
	then ;
	else if t = 1
	then tstr = "";
	else if t = 2
	then substr (tstr, 3, 2) = "30";
	else if t = 3
	then tstr = "";
	return (tstr);

     end timef;

block:
     proc (qhour, dow) returns (char (16));		/* This procedure returns the data for a particular time */

dcl	(qhour, dow)	fixed bin;		/* INPUT args: quarter-hour and day-of-week */

dcl	answer		char (16);		/* Assembly area for answer */
dcl	(ix, xix)		fixed bin,		/* Indices in this (and last) month's data */
	junk		fixed bin,
	q		fixed bin;		/* One plus quarter-hour */

	q = qhour + 1;
	ix = use_totals.max_day_log + dow - wkd;	/* Get "day number" in use_totals database. */
	if ix > use_totals.max_day_log
	then answer = "";				/* Return blanks for future */
	else if (ix = use_totals.max_day_log) & (q > use_totals.max_qhour)
	then answer = "";
	else if ix <= 1
	then do;					/* First day of month, or before? */
		xix = xtotp -> use_totals.max_day_log + dow - xwkd;
						/* YES. Use last month. */
		if xix > xtotp -> use_totals.max_day_log
		then answer = "";			/* GAP here */
		else if (xix = xtotp -> use_totals.max_day_log) & (q > xtotp -> use_totals.max_qhour)
		then go to zurk;			/* Falls in this month after all. */
		else if xix <= 0
		then answer = "";			/* Shouldn't happen. Off begin of prev month. */
		else if xtotp -> use_totals.daylog (xix).qh (q).dump_number > 0
		then answer = "    " || ltrim (char (xtotp -> use_totals.daylog (xix).qh (q).dump_number));
		else if xtotp -> use_totals.daylog (xix).qh (q).shutdown
		then answer = "    shutdown";
		else if xtotp -> use_totals.daylog (xix).qh (q).cpu = 0
		then answer = "      DOWN";
		else call ioa_$rsnnl ("^6.1f ^1d ^3d", answer, junk,
			xtotp -> use_totals.daylog (xix).qh (q).nunits / 10e0,
			xtotp -> use_totals.daylog (xix).qh (q).cpu, xtotp -> use_totals.daylog (xix).qh (q).kmem);

		return (answer);			/* Found in prev month. */
	     end;					/* .. preceding is genuine bruteforce solution. */
	else /* Must be in this month. */
zurk:
	     if use_totals.daylog (ix).qh (q).dump_number > 0
						/* See if ERF number is set, indicate crash */
	then answer = "    " || ltrim (char (use_totals.daylog (ix).qh (q).dump_number));
	else if use_totals.daylog (ix).qh (q).shutdown
	then answer = "    shutdown";
	else if use_totals.daylog (ix).qh (q).cpu = 0
	then answer = "      DOWN";
	else call ioa_$rsnnl ("^6.1f ^1d ^3d", answer, junk, use_totals.daylog (ix).qh (q).nunits / 10e0,
		use_totals.daylog (ix).qh (q).cpu, use_totals.daylog (ix).qh (q).kmem);

	return (answer);				/* puff puff */

     end block;

clean_up:
     procedure;

	if use_totals_ptr ^= null ()
	then call terminate_file_ (use_totals_ptr, (0), TERM_FILE_TERM, (0));
	if xtotp ^= null ()
	then call terminate_file_ (xtotp, (0), TERM_FILE_TERM, (0));
	return;
     end clean_up;
     end;




		    charge_disk.pl1                 04/26/88  1220.7rew 04/26/88  1214.1      103734



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




/****^  HISTORY COMMENTS:
  1) change(87-10-06,Parisek), approve(88-02-03,MCR7845),
     audit(88-04-18,Lippard), install(88-04-26,MR12.2-1043):
     Implemment multi-segment file application for possible >256K disk_stat
     segment.
                                                   END HISTORY COMMENTS */


charge_disk: proc;

/* procedure to run through the daily disk statistics and store usage values into the projfile.
   Modified by TAC and THVV, April 1976, to charge for directory pages under NSS
   Modified by T. casey, Sept 1977 to charge for all lv's when none specified.
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.
   Modified 1984-07-09 BIM for dir_disk_quota in projfile.
   */

dcl  path char (168),
     acpx fixed bin,
     cpx fixed bin,	   
     dn char (168) init (get_wdir_ ()),
     en char (32) init ("disk_stat"),
     ap ptr, al fixed bin, bchr char (al) based (ap),
     fcbp ptr,
     pp ptr,					/* projfile ptr */
     proj char (32),				/* project id */
     oldx fixed bin,				/* length of proj id */
    (i, j, k, nd, np, nn, ti) fixed bin,		/* indices */
     ec fixed bin (35);				/* error code */

dcl  ioa_ entry options (variable),
     get_wdir_ entry () returns (char (168)),
     com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     hcs_$initiate entry (char (*), char (*), char (*),
     fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     msf_manager_$close entry (ptr),
     msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)),
     msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35));     	   
dcl  search_sat_$rs_number entry (char (*), fixed bin, fixed bin (35));
dcl  search_sat_$clean_up entry;
dcl  system_info_$prices_rs entry (fixed bin,
    (0:7) float bin, (0:7) float bin, (0:7) float bin, (0:7) float bin, float bin, float bin);
dcl  system_info_$max_rs_number entry (fixed bin);
dcl  rs_count fixed bin;
dcl  rs_number fixed bin;
dcl  mdc_$find_lvid entry (char (*), bit (36) aligned, fixed bin (35));
dcl  proj_psec fixed bin (71) init (0);
dcl  lvname char (32);
dcl  lvid (50) bit (36) aligned;			/* more than enough */
dcl (bad_lv_count, lv_count) fixed bin init (0);
dcl  npd fixed bin init (0);
dcl  lv_arg bit (1) aligned init (""b);
dcl  lvi fixed bin;
dcl  cp_array (0:4) ptr;
dcl  dummy (0:7) float bin;
dcl  dummy1 float bin;
dcl  disk_price float bin;
dcl (error_table_$badopt, error_table_$too_many_args, error_table_$noentry) ext fixed bin (35);
dcl last_nd fixed bin;
dcl (addr, hbound, null, substr, rtrim, index) builtin;
dcl sys_info$max_seg_size fixed bin (35) ext static;

%include projfile;

%include disk_stat;

/* ======================================================== */

	ec = 0;
	do i = 1 by 1 while (ec = 0);
	     call cu_$arg_ptr (i, ap, al, ec);
	     if ec = 0 then do;
		if lv_arg then do;			/* all remaining args are lv names */
		     lv_count = lv_count + 1;
		     if lv_count > hbound (lvid, 1) then do;
			ec = error_table_$too_many_args;
arg_err:			call com_err_ (ec, "charge_disk", "^a", bchr);
			return;
		     end;
		     lvname = bchr;
		     call mdc_$find_lvid (lvname, lvid (lv_count), ec);
		     if ec ^= 0 then do;
			call com_err_ (ec, "charge_disk", "^a", bchr);
			lv_count = lv_count - 1;
			bad_lv_count = bad_lv_count + 1;
		     end;
		end;
		else if bchr = "-lv" | bchr = "-logical_volume" then
		     lv_arg = "1"b;			/* all remaining args are lvnames */

		else if substr (bchr, 1, 1) = "-" then do;
		     ec = error_table_$badopt;
		     goto arg_err;
		end;
		else do;
		     call expand_path_ (ap, al, addr (dn), addr (en), ec);
		     if ec ^= 0 then go to arg_err;
		end;
	     end;
	end;

	if bad_lv_count > 0 then
	     call com_err_ (0, "charge_disk",
	     "Error in logical volume specification. Segment page charges may be incorrect.");

	if lv_count = 0 then
	     call com_err_ (0, "charge_disk",
	     "No logical volumes specified. Storage on all logical volumes will be charged for.");

	call msf_manager_$open (dn, en, fcbp, ec);
	if ec ^= 0 then go to init_err;
	acpx, cpx, ti = 0;
cpx_loop:
	call msf_manager_$get_ptr (fcbp, cpx, "0"b, cp_array (cpx), 0, ec);
	if ec = 0 then do;
	     cpx = cpx + 1;
	     goto cpx_loop;
	end;

	call hcs_$initiate ((get_wdir_ ()), "projfile", "", 0, 1, pp, ec); /* initiate projfile */
	if pp = null then do;
	     dn = get_wdir_ ();
	     en = "projfile";
init_err:	     call com_err_ (ec, "charge_disk", "^a>^a", dn, en);
	     return;
	end;

	call system_info_$max_rs_number (rs_count);	/* see if site has multiple rate structures */

	sp = cp_array (0);
	nd = disk_stat.dents;			/* Get number of dirs we have disk statistics on. */
	np = projfile.nproj;			/* Get number of projects we have in projfile. */
	nn = 0;					/* count of dirs with disk statistics stored into projfile */

	do i = 1 to np;				/* clear disk use for project */
	     projfile.projfiletab (i).disk_quota = 0;	/* clear quota for project */
	     projfile.projfiletab (i).dir_disk_quota = 0; /* ditto for dir flavor */
	     projfile.projfiletab (i).disk_use = 0;	/* clear disk use for project */
	     projfile.projfiletab (i).dir_disk_use = 0;
	end;
	oldx = 32;				/* set max lngth of projname */
	proj = (32)"!";				/* set proj to schreek */
	j = 0;					/* initialize projfile entry index */
	
	last_nd = nd;
comp_loop:
	do i = 1 to last_nd;			/* Look at every dir we have disk statistics (quota) on. */
	     if disk_stat.dtab (i).slev < 2 then go to skip;
						/* ignore superstructure */

	     dn = disk_stat.dtab (i).spth;		/* Get directory name. */
	     if substr (dn, 1, 4) ^= ">udd"		/* Ignore those not in >udd */
	     then if substr (dn, 1, 4) ^= ">UDD"	/* ... */
		then if substr (dn, 1, 13) ^= ">user_dir_dir" then go to skip;

	     if lv_count > 0 then			/* if a list of logical volumes to charge for was given */
		do lvi = 1 to lv_count		/* see if this dir's sons lvid is in the list */
		     while (lvid (lvi) ^= disk_stat.dtab (i).slvid);
	     end;					/* if no match, lvi = lv_count+1, which is checked below */
	     else lvi = -1;				/* fool that guy below into charging for this one */
	     substr (dn, 1, 1) = " ";			/* Remove root (>) */
	     k = index (dn, ">");			/* Find beginning of project name. */
	     path = substr (dn, k+1, 168-k);		/* Get directory name. */
	     if substr (path, 1, oldx) = proj & substr (path, oldx+1, 1) = ">" then do;
add_dir_to_project:	nn = nn + 1;			/* Same project as last one. Count. */
		npd = npd + 1;			/* count dirs belonging to this project */
		projfile.projfiletab (j).disk_quota
		     = projfile.projfiletab (j).disk_quota + disk_stat.dtab (i).sqta;
		projfile.projfiletab (j).dir_disk_quota
		     = projfile.projfiletab (j).dir_disk_quota + disk_stat.dtab (i).dqta;
		projfile.projfiletab (j).disk_use
		     = projfile.projfiletab (j).disk_use + disk_stat.dtab (i).suse;
		projfile.projfiletab (j).dir_disk_use
		     = projfile.projfiletab (j).dir_disk_use + disk_stat.dtab (i).duse;

		proj_psec = proj_psec + disk_stat.dtab (i).dtpp; /* charge for all dirs - they are on the RLV */
		if lvi <= lv_count then		/* if we are charging for seg pages on this lvol */
		     proj_psec = proj_psec + disk_stat.dtab (i).stpp; /* do so */

	     end;

	     else do;				/* New project. */

		if npd > 0 then			/* if there were dirs belonging to a previous project */
		     call charge_proj;		/* go record those charges, if they look reasonable */

		if disk_stat.dtab (i).slev > 2 then do; /* This should be a project directory. */
		     call ioa_ ("charge_disk: ^a not at level 2 but shd be project dir", path);
		     go to skip;			/* If not, ignore it. Look for next proj. */
		end;
		proj = rtrim(path);			/* Save project name for comparison. */
		do j = 1 to np while (proj ^= projfile.id (j)); end;
		if j > np then do;
		     call ioa_ ("charge_disk: project ^a not in projfile", proj);
		     proj = " ";			/* Blank proj id */
		end;				/* Ignore missing project. */

		else do;				/* new project looks ok */
		     oldx = index (path, " ") - 1;	/* get length of project name */
		     goto add_dir_to_project;		/* go add figures for this dir into projfile entry */
		end;

	     end;
skip:	     if (lodh + (i+1) * lode) > sys_info$max_seg_size then do;
		ti = ti + i;		
		last_nd = nd - ti;
		acpx = acpx + 1;
		sp = cp_array (acpx);
		goto comp_loop;
	     end;
	end;

	if npd > 0 then				/* if last few dirs belonged to a project */
	     call charge_proj;			/* go record the charges */

	call hcs_$terminate_noname (sp, ec);		/* Terminate stats */
 	call hcs_$terminate_noname (pp, ec);		/* ... and projfile */

	if fcbp ^= null then
	     call msf_manager_$close (fcbp);

	if rs_count > 0 then
	     call search_sat_$clean_up;		/* tidy up */

	call ioa_ ("charge_disk: charged ^d dirs out of ^d to ^d projects", nn, nd, np);

	return;

charge_proj: proc;					/* procedure to check reasonableness of project disk charge, and
						   either record it if it looks ok, or complain if it doesn't */

/* For now, we just check for charge decreasing (impossible unless something has  been clobbered);
   later, checks for unreasonably large increases can be added. */
	     if proj_psec < projfile.projfiletab (j).disk_psec then do;
		if rs_count > 0 then do;		/* if site has multiple rate structures */
		     call search_sat_$rs_number (projfile.projfiletab (j).id, rs_number, ec); /* get rate index */
		     if ec ^= 0 then
			if ec = error_table_$noentry then
			     call com_err_ (ec, "charge_disk",
			     "Trying to locate project ""^a"" in the sat.  Default rates will be used.",
			     projfile.projfiletab (j).id);
			else call com_err_ (ec, "charge_disk", "Accessing the sat.  Default rates will be used");
		end;
		else rs_number = 0;
		call system_info_$prices_rs (rs_number, dummy, dummy, dummy, dummy, disk_price, dummy1);
						/* get disk price, just for printing charge in error messages */
		call ioa_ ("charge_disk: Total tpp of ^a project's directories (^d, $^.2f) is less than the
^-previous value (^d, $^.2f) in projfile; the projfile value has not been modified;",
		     projfile.projfiletab (j).id, proj_psec, (disk_price*proj_psec),
		     projfile.projfiletab (j).disk_psec, (disk_price*projfile.projfiletab (j).disk_psec));
		call ioa_ ("^-whichever value is incorrect must be adjusted before billing is run.");
	     end;

	     else projfile.projfiletab (j).disk_psec = proj_psec;

	     proj_psec = 0;				/* clear the adder so the next project starts at zero */
	     npd = 0;				/* same for the count of dirs charged to the project */

	     return;

	end charge_proj;

     end charge_disk;





		    charge_user_.pl1                08/29/88  0947.9rew 08/29/88  0858.8       77085



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

charge_user_: proc (name, proj, dp, code);

/* CHARGE_USER_ - program to increment a user's usage meters in his PDT entry */

/* modified on 10/22/74 by J. Whitmore to be compatible with the access isolation
   mechanism.  The program assumes that all PDTs are in the same directory and
   hence, all have the same access class.  This allows the process to test for
   needing system privileges only once (unless the debug entry is called.)
   Modified May 1980 by R. McDonald to include printer page charging. 
*/


/****^  HISTORY COMMENTS:
  1) change(87-08-11,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-03,Lippard), install(88-08-29,MR12.2-1093):
     Correct setting of code parm (phx14431).
                                                   END HISTORY COMMENTS */


dcl  name char (*),					/* person name */
     proj char (*),					/* project ID */
     dp ptr,					/* ptr to dummy pdt entry */
     code fixed bin (35);				/* error code returned if not found */

dcl  pdtp ptr,					/* ptr to current pdt */
     pdtep ptr,					/* ptr to current pdt entry */
     pdt_name char (32) aligned,			/* name of pdt */
    (i, j) fixed bin,				/* counters */
     setsw bit (1) aligned init ("0"b),			/* tells which entry */
     ec fixed bin (35),				/* errcode */
    (init, need_priv) bit (1) aligned int static init ("0"b), /* priv control bits */
     access_class bit (72) aligned;			/* access class of data seg..(PDT) */

dcl  error_table_$lock_wait_time_exceeded fixed bin (35) ext static,
     error_table_$moderr fixed bin (35) ext static;

dcl  linkage_error condition;

dcl  sysdir char (168) aligned int static init (">system_control_1>pdt");

dcl  ioa_$rsnnl entry options (variable),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$get_access_class entry (char (*) aligned, char (*) aligned, bit (72) aligned, fixed bin (35)),
     system_privilege_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     get_authorization_ entry () returns (bit (72) aligned),
     read_write_allowed_ entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned),
     clock_ entry () returns (fixed bin (71)),
     set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)),
     set_lock_$unlock entry (bit (36) aligned, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35));

dcl (null, addr) builtin;

%include user_attributes;
%include pdt;

/* ====================================================== */

join:
	call ioa_$rsnnl ("^a.pdt", pdt_name, j, proj);	/* Fabricate name of pdt wanted. */

	if ^init then do;				/* check the access to the PDT */

	     call hcs_$get_access_class (sysdir, pdt_name, access_class, ec);
	     if ec ^= 0 then go to mode_err;		/* hate to, but give up */

	     if read_write_allowed_ (get_authorization_ (), access_class) /* can we read and write? */
	     then need_priv = "0"b;			/* Yes, no privileges needed */
	     else need_priv = "1"b;			/* we need privileges if we are to do anything */

	     init = "1"b;				/* only do this once */

	end;

	on linkage_error go to mode_err;		/* play safe each time this is called */
						/* in case user has no access to system_privilege_ */
	if need_priv then
	     call system_privilege_$initiate (sysdir, pdt_name, "", 0, 1, pdtp, ec);
	else call hcs_$initiate (sysdir, pdt_name, "", 0, 1, pdtp, ec);
	if pdtp = null then do;			/* Look for pdt. */
	     code = ec;				/* Ugh. */
	     return;
	end;

search:	do i = 1 to pdt.current_size;			/* Look up user in pdt. */
	     pdtep = addr (pdt.user (i));		/* Get ptr to entry */
	     if user.state = 1 then			/* Look only at live users. */
		if user.person_id = name then go to found; /* Check name. */
	end;

	code = 1;					/* User is not in pdt. */
	go to terminate;				/* Error. */

found:
	call set_lock_$lock (user.lock, 300, ec);	/* Lock user entry. Wait up to 5 mins. */
	if ec = error_table_$lock_wait_time_exceeded then do;
	     code = ec;				/* tell caller what happened */
	     go to terminate;			/* and cleanup */
	end;

	if setsw then go to force;			/* Where did we come in? */

	user.absolute_spent = user.absolute_spent + dp -> user.absolute_spent;
	user.dollar_charge = user.dollar_charge + dp -> user.dollar_charge;
	user.logins = user.logins + dp -> user.logins;
	user.crashes = user.crashes + dp -> user.crashes;
	do i = 0 to 7;
	     user.interactive (i).charge = user.interactive (i).charge + dp -> user.interactive (i).charge;
	     user.interactive (i).cpu = user.interactive (i).cpu + dp -> user.interactive (i).cpu;
	     user.interactive (i).core = user.interactive (i).core + dp -> user.interactive (i).core;
	     user.interactive (i).connect = user.interactive (i).connect + dp -> user.interactive (i).connect;
	     user.interactive (i).io_ops = user.interactive (i).io_ops + dp -> user.interactive (i).io_ops;
	end;
	do i = 1 to 4;
	     user.absentee (i).charge = user.absentee (i).charge + dp -> user.absentee (i).charge;
	     user.absentee (i).jobs = user.absentee (i).jobs + dp -> user.absentee (i).jobs;
	     user.absentee (i).cpu = user.absentee (i).cpu + dp -> user.absentee (i).cpu;
	     user.absentee (i).memory = user.absentee (i).memory + dp -> user.absentee (i).memory;
	end;
	do i = 1 to 4;
	     user.iod (i).charge = user.iod (i).charge + dp -> user.iod (i).charge;
	     user.iod (i).pieces = user.iod (i).pieces + dp -> user.iod (i).pieces;
	     user.iod (i).pages = user.iod (i).pages + dp -> user.iod (i).pages;
	     user.iod (i).lines = user.iod (i).lines + dp -> user.iod (i).lines;
	end;
	do i = 1 to 16;
	     user.devices (i) = user.devices (i) + dp -> user.devices (i);
	end;

exit:	user.last_update = clock_ ();			/* Indicate when changes done. */

	call set_lock_$unlock (user.lock, ec);		/* Unlock user. */
	code = 0;

terminate:					/* be sure to clean up after ourselves */
	call hcs_$terminate_noname (pdtp, ec);		/* don't bother with the error code */
	return;

mode_err:	code = error_table_$moderr;			/* say that we don't have access */
	return;

/* ======================================================== */

set_user_charge: entry (name, proj, dp, code);

/* CHARGE_USER_$SET_USER_CHARGE - same as above but replaces usage meters instead of adding. */

	setsw = "1"b;				/* Indicate type of processing. */
	go to join;				/* Use common code to find user. */

force:	user.dollar_charge = dp -> user.dollar_charge;	/* Force all variables in pdt to new values. */
	user.absolute_spent = dp -> user.absolute_spent;
	user.logins = dp -> user.logins;
	user.crashes = dp -> user.crashes;
	do i = 0 to 7;
	     user.interactive (i).charge = dp -> user.interactive (i).charge;
	     user.interactive (i).cpu = dp -> user.interactive (i).cpu;
	     user.interactive (i).core = dp -> user.interactive (i).core;
	     user.interactive (i).connect = dp -> user.interactive (i).connect;
	     user.interactive (i).io_ops = dp -> user.interactive (i).io_ops;
	end;
	do i = 1 to 4;
	     user.absentee (i).charge = dp -> user.absentee (i).charge;
	     user.absentee (i).jobs = dp -> user.absentee (i).jobs;
	     user.absentee (i).cpu = dp -> user.absentee (i).cpu;
	     user.absentee (i).memory = dp -> user.absentee (i).memory;
	end;
	do i = 1 to 4;
	     user.iod (i).charge = dp -> user.iod (i).charge;
	     user.iod (i).pieces = dp -> user.iod (i).pieces;
	     user.iod (i).pages = dp -> user.iod (i).pages;
	     user.iod (i).lines = dp -> user.iod (i).lines;
	end;
	do i = 1 to 16;
	     user.devices (i) = dp -> user.devices (i);
	end;

	go to exit;

/* ==================================================== */

debug:	entry (dirn);

dcl  dirn char (*);

	sysdir = dirn;
	init = "0"b;				/* be sure we check access again */
	return;

     end charge_user_;




		    clear_projfile.pl1              09/19/84  0911.6rew 09/18/84  0754.6       25740



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

clear_projfile: proc;

dcl  (path, dn) char (168) aligned,
     en char (32) aligned,
    (i, j, k, l, m, n) fixed bin,
     movelen fixed bin,
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin,
    (p, q, p1, q1, pp, hp) ptr;

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     com_err_ entry options (variable);

dcl  (addr, null, substr) builtin;

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin),
     hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     hcs_$delentry_seg entry (ptr, fixed bin),
     hcs_$truncate_seg entry (ptr, fixed bin, fixed bin);


dcl 1 movetable based aligned,
    2 moveary (movelen) fixed bin (35);

%include projfile;

/* ====================================================== */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
	     path = "projfile";
	     al = 8;
	end;
	else path = bchr;
	call expand_path_ (addr (path), al, addr (dn), addr (en), ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "clear_projfile", path);
	     return;
	end;

	call hcs_$initiate (dn, en, "", 0, 1, pp, ec);
	if pp = null then go to er;

	call hcs_$make_seg ("", "", "", 1011b, p, ec);
	if p = null then go to er;

	movelen = loph;
	p -> movetable = pp -> movetable;

	movelen = lope;

	m = 0;

	do i = 1 to nproj;
	     if off (i) ^= 0 then go to skip;
	     m = m + 1;
	     p1 = addr (projfiletab (i));
	     q1 = addr (p -> projfiletab (m));
	     q1 -> movetable = p1 -> movetable;
skip:	end;

	movelen = loph + m * lope;

	call hcs_$truncate_seg (pp, 0, ec);
	pp -> movetable = p -> movetable;
	nproj = m;
	call hcs_$set_bc(dn,en,movelen*36,ec);

	call hcs_$terminate_noname (pp, ec);
	call hcs_$delentry_seg (p, ec);

     end;




		    clear_reqfile.pl1               09/19/84  0911.6rew 09/18/84  0754.6       25515



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

clear_reqfile: proc;

dcl  (path, dn) char (168) aligned,
     en char (32) aligned,
    (i, j, k, l, m, n) fixed bin,
     movelen fixed bin,
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin,
    (p, q, p1, q1, qp) ptr;

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     com_err_ entry options (variable);

dcl (addr, null, substr) builtin;

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin),
     hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     hcs_$delentry_seg entry (ptr, fixed bin),
     hcs_$truncate_seg entry (ptr, fixed bin, fixed bin);


dcl 1 movetable based aligned,
    2 moveary (movelen) fixed bin (35);

%include reqfile;

/* ====================================================== */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
	     path = "reqfile";
	     al = 7;
	end;
	else path = bchr;
	call expand_path_ (addr (path), al, addr (dn), addr (en), ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "clear_reqfile", path);
	     return;
	end;

	call hcs_$initiate (dn, en, "", 0, 1, qp, ec);
	if qp = null then go to er;

	call hcs_$make_seg ("", "", "", 1011b, p, ec);
	if p = null then go to er;

	movelen = loqh;
	p -> movetable = qp -> movetable;

	movelen = loqe;

	m = 0;
	     do i = 1 to nacts;
	if qdf(i) ^= 0 then go to skip;
	m = m + 1;
		p1 = addr (reqfiletab (i));
		q1 = addr (p -> reqfiletab (m));
		q1 -> movetable = p1 -> movetable;
skip:	     end;

	movelen = loqh + m * loqe;

	call hcs_$truncate_seg (qp, 0, ec);
	qp -> movetable = p -> movetable;
	nacts = m;
	call hcs_$set_bc(dn,en,movelen*36,ec);

	call hcs_$terminate_noname (qp, ec);
	call hcs_$delentry_seg (p, ec);

     end;




		    clear_sat.pl1                   07/13/88  1122.2r w 07/13/88  0941.0       32544



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/**** Program to trim deleted satentries out of the sat.
      To be used on smf.cur.sat at "bill accept" time.
      BIM 1984-09-12 */

/* format: style2 */

clear_sat:
     procedure options (variable);

	declare com_err_		 entry () options (variable);
	declare cu_$arg_count	 entry (fixed bin, fixed bin (35));
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare expand_pathname_	 entry (character (*), character (*), character (*), fixed binary (35));
	declare initiate_file_	 entry (character (*), character (*), bit (*), pointer, fixed binary (24),
				 fixed binary (35));
	declare pathname_		 entry (character (*), character (*)) returns (character (168));
	declare terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));


	declare arg_count		 fixed bin;
	declare ap		 pointer;
	declare al		 fixed bin (21);
	declare argument		 char (al) based (ap);
	declare code		 fixed bin (35);
	declare dir_name		 char (168);
	declare entryname		 char (32);
	declare (satp, satep)	 pointer;		/* live */
	declare satex		 fixed bin;
	declare deleted_satex	 fixed bin;
	declare last_satex		 fixed bin;
	declare new_n_projects	 fixed bin;
	declare deleted_satep	 pointer;

	declare ME		 char (32) init ("clear_sat") int static options (constant);

%include sat;
%include user_attributes;
%include access_mode_values;
%include terminate_file;


	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME);
		return;
	     end;

	if arg_count ^= 1
	then do;
		call com_err_ (0, ME, "Usage: ^a SAT_PATH.sat", ME);
		return;
	     end;

	satp = null ();

	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_ (argument, dir_name, entryname, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", argument);
		return;
	     end;

	call initiate_file_ (dir_name, entryname, RW_ACCESS, satp, (0), code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", pathname_ (dir_name, entryname));
		return;
	     end;

	sat.version = -1;				/* BROKEN */
	deleted_satex = -1;
	last_satex = -1;
	new_n_projects = 0;
	do satex = 1 to sat.current_size;
	     satep = addr (sat.project (satex));
	     if project.state ^= 1			/* deleted or free (not in use) */
	     then if deleted_satex < 0
		then deleted_satex = satex;
		else ;
	     else do;
		     new_n_projects = new_n_projects + 1;
		     if deleted_satex > 0
		     then do;
			     deleted_satep = addr (sat.project (deleted_satex));
			     deleted_satep -> project = satep -> project;
			     last_satex = max (last_satex, deleted_satex);
						/* note highest we have seen */
			     project.state = 0;
			     deleted_satep = addr (sat.project (deleted_satex + 1));
			     if deleted_satep -> project.state ^= 1
			     then deleted_satex = deleted_satex + 1;
			     else deleted_satex = satex;
						/* we are now free */
			end;
		     else last_satex = satex;		/* don't move, but note */
		end;
	end;

	if last_satex ^= new_n_projects
	then call com_err_ (0, ME, "Inconsistency: n_projects ^d but last non-empty project index ^d.", new_n_projects,
		last_satex);

	sat.n_projects = new_n_projects;
	sat.current_size = last_satex;
	sat.version = SAT_version;
	call terminate_file_ (satp, (0), TERM_FILE_TERM, (0));
	return;
     end clear_sat;




		    compute_bill.pl1                07/13/88  1122.2r w 07/13/88  0941.0      114939



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





/****^  HISTORY COMMENTS:
  1) change(86-10-15,Parisek), approve(87-06-17,MCR7570),
     audit(87-06-15,Hirneisen), install(87-08-06,MR12.1-1066):
     Suppress error reporting of non existent pdt for a renamed project.
                                                   END HISTORY COMMENTS */



compute_bill: procedure options (variable);

/* daily billing program.

   This program computes the usage charge for each project and places it in the reqfile.

   inputs:
   .	"sat"		copy of system administrator's table
   .	Proj.pdt		copy of each project's pdt
   .	"reqfile"		per-account requisition info
   .	"projfile"	per-project disk and misc charges and supervisor name
   .	"miscfile"	misc charges detail info for the month
   output:
   .      "reqfile"           per account chg_mo replaced

   When called at the update_pdts_from reqfile entry, it copies each projects
   reqfile entry and projfile entry into its PDT header.


   THVV 11/69 - KAW 6/71
   Modified by T. casey April 1976 to zero projfiletab.dir_disk_use for new projfile entry.
   Modified by John Gintell  May 1977 to add update_pdts_from_reqfile.
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.
   Mdified 1984-07-11 BIM for versions in projfile and reqfile.
*/

dcl  dn char (168) aligned,				/* segment names */
     en char (32) aligned,				/* ... */
     pdtdir char (168) aligned,
     wdir char (168) aligned,
     pdtename char (32) aligned,
     uproj char (12) aligned,
     ec fixed bin (17),				/* file-system error code */
     ap ptr,
     al fixed bin,
     arg char (al) based (ap),
    (sati, pdti, proji, j, reqi) fixed bin (17),		/* counters */
    (req_notfound, proj_notfound) bit (1),
     dum (0: 7) float bin,				/* Dummy. Don't need these prices */
     u1 float bin,
     compute bit (1) init ("1"b),			/* on for compute_bill , off for update_pdts_from reqfile */
     command_name char (32),
     satp ptr,					/* ptr to sat */
     satep ptr,					/* ptr to sat entry */
     satstuff based bit (52*36) aligned,		/* mess of stuff based to copy from sat entry */
     pdtp ptr,					/* ptr to pdt */
     pdtep ptr,					/* ptr to pdt entry for user */
     pp ptr,					/* ptr to "projfile" */
     miscfilep ptr,					/* ptr to "miscfile" */
     qp ptr,					/* ptr to "reqfile" */
     nproj fixed bin (17),				/* number of projects */
     nreq fixed bin (17),				/* number of accounts */
     proj_usage float bin (63);
dcl (addr, clock, hbound, null, rtrim, unspec, abs) builtin;
dcl  crank_cant_run condition;
dcl 1 pdp (1000) based (pdp_ptr),			/* temporary to hold disk prices */
    2 disk_price float bin,
    2 price_set bit (1);				/* off when allocated; on if disk_price has been set */
						/*  need price_set as a disk_price of "0" is valid */
dcl  pdp_ptr ptr;
dcl  rs_number fixed bin;
dcl  rs_name char (32);
dcl 1 prices (0:9),					/* holds all possible prices */
    2 disk_price float bin,
    2 reg_price float bin;

/* procedures called by this program */

dcl  ioa_ ext entry options (variable),			/* output routine */
     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin),
     expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin),
     absolute_pathname_ entry (char (*), char (*) aligned, fixed bin),
     system_info_$rs_name entry (fixed bin, char (*), fixed bin),
     system_info_$prices_rs ext entry (fixed bin,
    (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, float bin, float bin),

     get_wdir_ entry () returns (char (168) aligned),
     com_err_ entry options (variable),
     hcs_$terminate_noname entry (ptr, fixed bin),
     hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin);

%include user_attributes;
%include sat;
%include pdt;
%include projfile;
%include reqfile;
%include miscfile;

	command_name = "compute_bill";
	go to START;

update_pdts_from_reqfile: entry;

	command_name = "update_pdts_from_reqfile";
	compute = ""b;
START:
	call cu_$arg_ptr (1, ap, al, ec);		/* First arg is pathname of SAT */
	if ec ^= 0 then do;
ER1:	     call com_err_ (ec, command_name, "");
	     return;
	end;
	call expand_pathname_ (arg, dn, en, ec);
	if ec ^= 0 then do;
ER2:	     call com_err_ (ec, command_name, arg);
	     return;
	end;
	call hcs_$initiate (dn, en, "", 0, 1, satp, ec);	/* Initiate sat. */
	if satp = null then do;
ERR:	     call com_err_ (ec, command_name, en);
	     return;
	end;

	call cu_$arg_ptr (2, ap, al, ec);		/* second arg is pathname of PDT dir */
	if ec ^= 0 then go to ER1;
	call absolute_pathname_ (arg, pdtdir, ec);
	if ec ^= 0 then go to ER2;

	en = "reqfile";				/* Now get requisition file. */
	wdir = get_wdir_ ();
	call hcs_$initiate (wdir, en, "", 0, 1, qp, ec);	/* Initiate reqfile. */
	if qp = null then go to ERR;
	nreq = reqfile.nacts;			/* ... */
	if nreq = 0 then do;
ABORT:	     call ioa_ ("^a: ^a is empty. FATAL ERROR", command_name, en);
	     signal condition (crank_cant_run);
	end;

	en = "projfile";				/* Now get project file. */
	call hcs_$initiate (wdir, en, "", 0, 1, pp, ec);	/* Initiate projfile. */
	if pp = null then go to ERR;
	nproj = projfile.nproj;			/* Get number of entries. */
	if nproj = 0 then do;
	     go to ABORT;
	end;

	if compute then do;
	     en = "miscfile";			/* Now get misc charges journal */
	     call hcs_$initiate (wdir, en, "", 0, 1, miscfilep, ec);
	     if miscfilep = null then go to ERR;

	     en = "[pd]>proj_prices";
	     call hcs_$make_seg ("", "proj_prices", "", 1010b, pdp_ptr, ec); /* get a temporary seg */
	     if pdp_ptr = null then goto ERR;
	     do rs_number = 0 to hbound (prices, 1);	/* now get all the prices */
		call system_info_$rs_name (rs_number, rs_name, ec); /* is this a valid number? */
		if ec ^= 0 then prices (rs_number) = prices (0);
		else call system_info_$prices_rs (rs_number, dum, dum, dum, dum, prices (rs_number).disk_price,
		     prices (rs_number).reg_price);
	     end;

	     do reqi = 1 to nreq;			/* clear charges this month in reqfile */
		reqfile.chg_mo (reqi) = 0e0;
		reqfile.procssd (reqi) = 0;
	     end;
	end;


/* Loop through SAT to find all current projects. */

	do sati = 1 to sat.current_size;
	     satep = addr (sat.project (sati));
	     if project.state = 0 | project.state = 3 then go to SKIP_PROJ;
						/* skip renamed projects so com_err_ isn't called */
	     pdtename = rtrim (project.project_id) || ".pdt";
	     call hcs_$initiate (pdtdir, pdtename, "", 0, 1, pdtp, ec);
	     if pdtp = null then do;
		call com_err_ (ec, command_name, "^a", pdtename);
		go to SKIP_PROJ;
	     end;

	     call findreq;

	     if compute then do;
		pdp (reqi).disk_price = prices (project.rs_number).disk_price; /* save what we know when we know it */
		pdp (reqi).price_set = "1"b;		/*     and mark it as being saved */
		proj_usage = 0e0;

		do pdti = 1 to pdt.current_size;
		     pdtep = addr (pdt.user (pdti));
		     if user.state ^= 0 then
			proj_usage = proj_usage + user.dollar_charge + prices (project.rs_number).reg_price;
		end;

/* End of loop on users in project. Place total into reqfile */


		if reqfile.mitacct (reqi) ^= "nonbill" then /* Check for non-billable account. */
		     reqfile.chg_mo (reqi) = reqfile.chg_mo (reqi) + proj_usage; /* add project charge into reqfile */
	     end;
	     else do;
		uproj = project.project_id;		/* implicit argument to findproj */
		pdt.date_reqfile_copied = clock ();
		call findproj;
		if proj_notfound then projfile_version = 0;
		else do;
		     pdt.projfile_version = projfile.version;
		     pdt.projentry = unspec (projfiletab (proji));
		end;
		if req_notfound then reqfile_version = 0;
		else do;
		     pdt.reqfile_version = reqfile.version;
		     pdt.reqentry = unspec (reqfiletab (reqi));
		end;
		if sat.version ^= SAT_version then pdt.sat_version = -1;
		else do;
		     pdt.sat_version = sat.version;
		     pdt.satentry = addr (project.at) -> satstuff; /* sorry about this */
		end;
		pdt.rs_number = project.rs_number;	/* guarantee rs_number is up-to-date */
	     end;

/* On to next project. */

	     call hcs_$terminate_noname (pdtp, ec);
SKIP_PROJ: end;

	call hcs_$terminate_noname (satp, ec);

/* Loop through reqfile updating disk charges from projfile */

	if compute then do;
	     do reqi = 1 to nreq;
		if reqfile.acctid (reqi) = "" then go to SKIP_REQ;
		uproj = reqfile.acctid (reqi);
		proj_usage = 0e0;
		call findproj;

/* charge for disk usage-disk_psec should only be until termination */

		if pdp (reqi).price_set then proj_usage = proj_usage
		     +pdp (reqi).disk_price * projfile.disk_psec (proji); /* the price saved above */
		else proj_usage = proj_usage+prices (0).disk_price * projfile.disk_psec (proji); /* use default */

		if projfile.n_misc (proji) > 0 then do; /* any misc charges? */
		     u1 = 0;			/* Yes. */
		     do j = 1 to misc_ents;		/* search journal */
			if mproj (j) = uproj then do;
			     u1 = u1 + mamt (j);	/* add amount of all misc charges */
			end;
		     end;
		     if abs (u1 - projfile.misc_charges (proji)) > .01e0 then /* file consistency check. */
			call ioa_ ("^a: ^a misc charges ^.2f in projfile, ^.2f in miscfile", command_name,
			uproj, projfile.misc_charges (proji), u1);
		     proj_usage = proj_usage + u1;	/* increase proj total by misc chgs */
		end;

		if reqfile.mitacct (reqi) ^= "nonbill"	/* charges should not be added to nonbill accts */
		then reqfile.chg_mo (reqi) = reqfile.chg_mo (reqi)+proj_usage; /* add disk and misc charges to reqfile */
SKIP_REQ:	     end;

	     projfile.nproj = nproj;			/* May have added dummy project. */
	end;
	call hcs_$terminate_noname (pp, ec);		/* Terminate projfile. */
	if compute then do;
	     reqfile.nacts = nreq;			/* May have added dummy req. */
	     call hcs_$terminate_noname (miscfilep, ec);	/* terminate miscfile */
	     call hcs_$terminate_noname (pdp_ptr, ec);	/* terminate disk prices seg */
	end;
	call hcs_$terminate_noname (qp, ec);		/* Terminate reqfile. */

/* Internal procedures to look up entries in reqfile and projfile */
/* findreq finds reqfile entry corresponding to project.project_id
   findproj finds projfile entry corresponding to uproj */

findreq:	proc;

	     do reqi = 1 to nreq while (project.project_id ^= reqfile.acctid (reqi));end; /* look up account in file */
	     req_notfound = ""b;
	     if reqi = nreq + 1 then do;		/* not found, add it */
		if ^compute then do;
		     req_notfound = "1"b;
		     return;
		end;
		call ioa_ ("^a: reqfile entry for ^a missing. Dummy created.", command_name, project.project_id);
		nreq = reqi;			/* not in "reqfile", add */
		reqi = nreq;

		reqfile.acctid (reqi) = project.project_id; /* Fill in new entry. */
		reqfile.mitacct (reqi), reqfile.reqno (reqi),
		     reqfile.billing_name (reqi), reqfile.billing_addr (reqi) = "(unknown)";
		reqfile.chg_tr (reqi), reqfile.req_amt (reqi), reqfile.chg_mo (reqi) = 0e0;
		reqfile.cutoff (reqi) = 0;
		reqfile.qdf (reqi) = 0;
		reqfile.qdn (reqi) = clock ();
	     end;
	end findreq;

findproj:	proc;
	     do proji = 1 to nproj while (uproj ^= projfile.id (proji)); end; /* find project entry in "projfile" */
	     proj_notfound = ""b;
	     if proji = nproj + 1 then do;		/* missing, add it */
		if ^compute then do;
		     proj_notfound = "1"b;
		     return;
		end;
		nproj = proji;
		call ioa_ ("^a: projfile entry for ^a missing. Dummy created.", command_name, uproj);
		projfile.id (proji) = uproj;		/* initialize entry */
		projfile.title (proji), projfile.inv (proji), projfile.sup (proji), projfile.inv_addr (proji),
		     projfile.sup_addr (proji), projfile.sup_phone (proji) = "(unknown)";
		projfile.misc_charges (proji) = 0e0;
		projfile.disk_quota (proji), projfile.disk_use (proji), projfile.dir_disk_use (proji) = 0;
		projfile.disk_psec (proji) = 0;
		projfile.off (proji) = 0;
		projfile.on (proji) = clock ();
		projfile.n_misc (proji) = 0;
	     end;
	end findproj;
     end compute_bill;




		    copy_as_meters.pl1              11/12/82  1412.9rew 11/12/82  1108.9       23544



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


copy_as_meters: proc;

/* This program copies the contents of "stat_seg"
   from where the answering service program as_meter_
   has created it into a file in the user area, and
   resets the stat_seg pointer to start again at the bottom.

   THVV 2/72 */
/* Modofied June 1979 by C. Hornig to copy wholw stat_seg. */

dcl  dn char (168) aligned,
     en char (32) aligned,
     statp ptr,
     movelen fixed bin,
     ap ptr,
     al fixed bin,
     ec fixed bin,
     p ptr;

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     ioa_ entry options (variable),
     com_err_ entry options (variable);

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin);

dcl (addr, null) builtin;

declare  sys_info$max_seg_size fixed bin (19) external static;

dcl 1 movetable based aligned,
    2 moveary (movelen) fixed bin (35);

%include stat_seg;

/* ------------------------------------------------------- */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "copy_as_meters", "");
	     return;
	end;
	call expand_path_ (ap, al, addr (dn), addr (en), ec);
	if ec ^= 0 then go to er;

	call hcs_$make_seg (dn, en, "", 1011b, p, ec);
	if p = null then go to er;

	call hcs_$initiate (">system_control_dir", "stat_seg", "", 0, 1, statp, ec);
	if statp = null then go to er;

	if statistics.wrapped ^= 0			/* is it has wrapped */
	then movelen = sys_info$max_seg_size;		/* copy the whole segment */
	else movelen = STAT_header_lth + statistics.index * STAT_entry_lth; /* otherwise copy the used part */

	p -> movetable = statp -> movetable;

	statp -> statistics.index = 0;
	statp -> statistics.wrapped = 0;

	if p -> statistics.wrapped ^= 0 then call ioa_ ("wrapped");

	call hcs_$terminate_noname (p, ec);
	call hcs_$terminate_noname (statp, ec);

     end;




		    create_pnt.pl1                  12/05/84  1446.9r w 12/05/84  0856.9       30438



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* CREATE_PNT:  Program to create an empty PNT.  Used by acct_start_up.ec
   when setting up the answering service environment for the first time. */

/* format: style2 */
/* Written 1984-07-26 by E. Swenson */
/* Modified 1984-09-20 by E. Swenson to use pnt_manager_. */

create_pnt:
     procedure options (variable);

/* Automatic */

	dcl     argument_idx	 fixed bin (17);
	dcl     argument_lth	 fixed bin (21);
	dcl     argument_ptr	 ptr;
	dcl     code		 fixed bin (35);
	dcl     dirname		 char (168);
	dcl     entryname		 char (32);
	dcl     n_arguments		 fixed bin (17);
	dcl     size		 fixed bin (17);

/* External Entries */

	dcl     com_err_		 entry () options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     expand_pathname_$add_suffix
				 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     pnt_manager_$create	 entry (char (*), char (*), fixed bin (17), fixed bin (35));

/* External Static */

	dcl     error_table_$noarg	 fixed bin (35) external static;
	dcl     error_table_$bad_arg	 fixed bin (35) external static;
	dcl     error_table_$badopt	 fixed bin (35) external static;

/* Based */

	dcl     argument		 char (argument_lth) based (argument_ptr);

/* Constant */

	dcl     ME		 char (32) initial ("create_pnt") internal static options (constant);
	dcl     SIZE_DEFAULT	 fixed bin (17) initial (100) internal static options (constant);

%page;
	call cu_$arg_count (n_arguments, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME);
		return;
	     end;

	if n_arguments = 0
	then do;
		call com_err_ (0, ME, "Usage: ^a pathname_of_new_pnt -control_args", ME);
		return;
	     end;

	call cu_$arg_ptr (1, argument_ptr, argument_lth, (0));
	call expand_pathname_$add_suffix (argument, "pnt", dirname, entryname, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", argument);
		return;
	     end;

	size = SIZE_DEFAULT;			/* Initialize default size of PNT */

	do argument_idx = 2 to n_arguments;
	     call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, (0));
	     if argument = "-size"
	     then do;
		     if argument_idx = n_arguments
		     then do;
			     call com_err_ (error_table_$noarg, ME, "-size");
			     return;
			end;
		     argument_idx = argument_idx + 1;
		     call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, (0));
		     size = cv_dec_check_ (argument, code);
		     if code ^= 0
		     then do;
			     call com_err_ (error_table_$bad_arg, ME, "-size ^a", argument);
			     return;
			end;
		end;
	     else do;
		     call com_err_ (error_table_$badopt, ME, "^a", argument);
		     return;
		end;
	end;

	call pnt_manager_$create (dirname, entryname, size, code);
	if code ^= 0
	then call com_err_ (code, ME, "Creating PNT ^a.", pathname_ (dirname, entryname));
	return;

     end create_pnt;




		    create_projfile.pl1             04/09/85  1438.3r w 04/08/85  1133.4       30339



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* create_projfile.pl1 -- minimal program to invent an empty projfile. */
/* format: style2 */
/* BIM 1984-08-25 */
create_projfile:
     procedure options (variable);

	declare com_err_		 entry () options (variable);
	declare command_query_$yes_no	 entry () options (variable);
	declare cu_$arg_count	 entry (fixed bin, fixed bin (35));
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare expand_pathname_	 entry (character (*), character (*), character (*), fixed binary (35));
	declare get_group_id_	 entry () returns (char (32));
	declare get_wdir_		 entry() returns(character (168));
	declare initiate_file_$create	 entry (character (*), character (*), bit (*), pointer, bit (1) aligned,
				 fixed binary (24), fixed binary (35));
	declare pathname_		 entry (character (*), character (*)) returns (character (168));
	declare terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));

	declare error_table_$namedup	 fixed bin (35) ext static;

	declare arg_count		 fixed bin;
	declare ap		 pointer;
	declare al		 fixed bin (21);
	declare argument		 char (al) based (ap);
	declare code		 fixed bin (35);
	declare created		 bit (1) aligned;
	declare dir_name		 char (168);
	declare entryname		 char (32);
	declare pp		 pointer;
	declare yes_sw		 bit (1) aligned;

	declare ME		 char (32) init ("create_projfile") int static options (constant);

%include projfile;
%include access_mode_values;
%include terminate_file;


	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME);
		return;
	     end;

	if arg_count ^= 1
	then do;
		call com_err_ (0, ME, "Usage: ^a NEW_PROJFILE_PN", ME);
		return;
	     end;

	pp = null ();

	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_ (argument, dir_name, entryname, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", argument);
		return;
	     end;

	call initiate_file_$create (dir_name, entryname, RW_ACCESS, pp, created, (0), code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", pathname_ (dir_name, entryname));
		return;
	     end;

	if ^created
	then do;
		call command_query_$yes_no (yes_sw, error_table_$namedup, ME,
		     "The create_projfile command will discard all information in an existing projfile.^/ Answer ""no"" unless you are sure that you want to discard the information in this segment."
		     , "projfile ""^a"" already exists. Do you wish to overwrite it.?", pathname_ (dir_name, entryname));
		if ^yes_sw
		then do;
			call terminate_file_ (pp, (0), TERM_FILE_TERM, (0));
			return;
		     end;
	     end;

	projfile.nproj = 0;
	projfile.projfilexx0 = ""b;
	projfile.projfiletab (*).id = "";
	projfile.projfiletab (*).title = "";
	projfile.projfiletab (*).inv = "";
	projfile.projfiletab (*).inv_addr = "";	     
	projfile.projfiletab (*).sup = "";
	projfile.projfiletab (*).sup_addr = "";
	projfile.projfiletab (*).sup_phone = "";
	projfile.version = PROJFILE_VERSION;
	call terminate_file_ (pp, 0, TERM_FILE_TERM, (0));
	return;
     end create_projfile;




		    create_reqfile.pl1              04/09/85  1438.3r w 04/08/85  1133.4       29043



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* create_reqfile.pl1 -- minimal program to invent an empty reqfile. */
/* format: style2 */
/* BIM 1984-08-25 */
create_reqfile:
     procedure options (variable);

	declare com_err_		 entry () options (variable);
	declare command_query_$yes_no	 entry () options (variable);
	declare cu_$arg_count	 entry (fixed bin, fixed bin (35));
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare expand_pathname_	 entry (character (*), character (*), character (*), fixed binary (35));
	declare get_group_id_	 entry () returns (char (32));
	declare get_wdir_		 entry() returns(character (168));
	declare initiate_file_$create	 entry (character (*), character (*), bit (*), pointer, bit (1) aligned,
				 fixed binary (24), fixed binary (35));
	declare pathname_		 entry (character (*), character (*)) returns (character (168));
	declare terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));

	declare error_table_$namedup	 fixed bin (35) ext static;

	declare arg_count		 fixed bin;
	declare ap		 pointer;
	declare al		 fixed bin (21);
	declare argument		 char (al) based (ap);
	declare code		 fixed bin (35);
	declare created		 bit (1) aligned;
	declare dir_name		 char (168);
	declare entryname		 char (32);
	declare qp		 pointer;
	declare yes_sw		 bit (1) aligned;

	declare ME		 char (32) init ("create_reqfile") int static options (constant);

%include reqfile;
%include access_mode_values;
%include terminate_file;


	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME);
		return;
	     end;

	if arg_count ^= 1
	then do;
		call com_err_ (0, ME, "Usage: ^a NEW_REQFILE_PN", ME);
		return;
	     end;

	qp = null ();

	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_ (argument, dir_name, entryname, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", argument);
		return;
	     end;

	call initiate_file_$create (dir_name, entryname, RW_ACCESS, qp, created, (0), code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", pathname_ (dir_name, entryname));
		return;
	     end;

	if ^created
	then do;
		call command_query_$yes_no (yes_sw, error_table_$namedup, ME,
		     "The create_reqfile command will discard all information in an existing reqfile.^/ Answer ""no"" unless you are sure that you want to discard the information in this segment."
		     , "reqfile ""^a"" already exists. Do you wish to overwrite it.?", pathname_ (dir_name, entryname));
		if ^yes_sw
		then do;
			call terminate_file_ (qp, (0), TERM_FILE_TERM, (0));
			return;
		     end;
	     end;

	reqfile.nacts = 0;
	reqfile.pad = ""b;
	reqfile.reqfiletab (*).acctid = "";
	reqfile.reqfiletab (*).reqno = "";
	reqfile.reqfiletab (*).mitacct = "";
	reqfile.reqfiletab (*).qflag = "";	     
	reqfile.version = REQFILE_VERSION;
	call terminate_file_ (qp, 0, TERM_FILE_TERM, (0));
	return;
     end create_reqfile;




		    create_sat.pl1                  07/13/88  1122.2r w 07/13/88  0941.0       34056



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* create_sat.pl1 -- minimal program to invent an empty sat. */
/* This replaces cv_smf, since we no longer manipulate smf's */
/* format: style2 */
/* BIM 1984-07-05 */
/* Modified 1984-10-11 by E. Swenson to fix sat.current_size initializaton. */

create_sat:
     procedure options (variable);

	declare com_err_		 entry () options (variable);
	declare command_query_$yes_no	 entry () options (variable);
	declare cu_$arg_count	 entry (fixed bin, fixed bin (35));
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare expand_pathname_	 entry (character (*), character (*), character (*), fixed binary (35));
	declare get_group_id_	 entry () returns (char (32));
	declare get_wdir_		 entry() returns(character (168));
	declare initiate_file_$create	 entry (character (*), character (*), bit (*), pointer, bit (1) aligned,
				 fixed binary (24), fixed binary (35));
	declare pathname_		 entry (character (*), character (*)) returns (character (168));
	declare terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));

	declare error_table_$namedup	 fixed bin (35) ext static;

	declare arg_count		 fixed bin;
	declare ap		 pointer;
	declare al		 fixed bin (21);
	declare argument		 char (al) based (ap);
	declare code		 fixed bin (35);
	declare created		 bit (1) aligned;
	declare dir_name		 char (168);
	declare entryname		 char (32);
	declare (satp, satep)	 pointer;
	declare yes_sw		 bit (1) aligned;

	declare ME		 char (32) init ("create_sat") int static options (constant);

%include sat;
%include user_attributes;
%include access_mode_values;
%include terminate_file;


	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME);
		return;
	     end;

	if arg_count ^= 1
	then do;
		call com_err_ (0, ME, "Usage: ^a NEW_SAT_PN.sat", ME);
		return;
	     end;

	satp = null ();

	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_ (argument, dir_name, entryname, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", argument);
		return;
	     end;

	call initiate_file_$create (dir_name, entryname, RW_ACCESS, satp, created, (0), code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", pathname_ (dir_name, entryname));
		return;
	     end;

	if ^created
	then do;
		call command_query_$yes_no (yes_sw, error_table_$namedup, ME,
		     "The create_sat command will discard all information in an existing SAT.^/ Answer ""no"" unless you are sure that you want to discard the information in this segment."
		     , "SAT ^a already exists. Do you wish to overwrite it.?", pathname_ (dir_name, entryname));
		if ^yes_sw
		then do;
			call terminate_file_ (satp, (0), TERM_FILE_TERM, (0));
			return;
		     end;
	     end;
	sat.version = -1;				/* BROKEN */
	sat.author.proc_group_id = get_group_id_ ();
	sat.author.lock = ""b;
	sat.author.update_attributes, sat.author.update_authorization, sat.author.deferral_notified = "0"b;
	sat.last_install_time = 0;
	sat.table = "SAT";
	sat.w_dir = get_wdir_ ();

	sat.max_size = hbound (sat.project, 1);
	sat.current_size = 0;
	sat.freep = 1;
	sat.n_projects = 0;
	sat.max_units = 0;
	sat.uwt_size = 0;
	sat.uwt (*).initproc = "";
	sat.uwt (*).units = 0;
	sat.system_admin (*) = "";
	sat.pad1 = 0;
	sat.project (1) = 0;			/* zero first project */
	sat.version = SAT_version;
	call terminate_file_ (satp, wordno (addr (sat.project (2))), TERM_FILE_BC | TERM_FILE_TERM, (0));
	return;
     end create_sat;




		    create_urf.pl1                  12/05/84  1447.1r w 12/05/84  0857.0       32526



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* CREATE_URF:  Program to create an empty URF.  Used by acct_start_up.ec
   when setting up the answering service environment for the first time. */

/* format: style2 */
/* Created 1984-08-28 by E. Swenson */

create_urf:
     procedure options (variable);

/* Automatic */

	dcl     argument_idx	 fixed bin (17);
	dcl     argument_lth	 fixed bin (21);
	dcl     argument_ptr	 ptr;
	dcl     code		 fixed bin (35);
	dcl     dirname		 char (168);
	dcl     entryname		 char (32);
	dcl     n_arguments		 fixed bin (17);
	dcl     size		 fixed bin (17);

	dcl     1 mti		 aligned like ms_table_info automatic;

/* External Entries */

	dcl     com_err_		 entry () options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     ms_table_mgr_$create	 entry (char (*), char (*), ptr, fixed bin (35));

/* External Static */

	dcl     error_table_$noarg	 fixed bin (35) external static;
	dcl     error_table_$bad_arg	 fixed bin (35) external static;
	dcl     error_table_$badopt	 fixed bin (35) external static;

/* Based */

	dcl     argument		 char (argument_lth) based (argument_ptr);

/* Constant */

	dcl     ME		 char (32) initial ("create_urf") internal static options (constant);
	dcl     SIZE_DEFAULT	 fixed bin (17) initial (100) internal static options (constant);

%page;
	call cu_$arg_count (n_arguments, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME);
		return;
	     end;

	if n_arguments = 0
	then do;
		call com_err_ (0, ME, "Usage: ^a pathname_of_new_urf -control_args", ME);
		return;
	     end;

	call cu_$arg_ptr (1, argument_ptr, argument_lth, (0));
	call expand_pathname_ (argument, dirname, entryname, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", argument);
		return;
	     end;

	size = SIZE_DEFAULT;			/* Initialize default size of URF */

	do argument_idx = 2 to n_arguments;
	     call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, (0));
	     if argument = "-size"
	     then do;
		     if argument_idx = n_arguments
		     then do;
			     call com_err_ (error_table_$noarg, ME, "-size");
			     return;
			end;
		     argument_idx = argument_idx + 1;
		     call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, (0));
		     size = cv_dec_check_ (argument, code);
		     if code ^= 0
		     then do;
			     call com_err_ (error_table_$bad_arg, ME, "-size ^a", argument);
			     return;
			end;
		end;
	     else do;
		     call com_err_ (error_table_$badopt, ME, "^a", argument);
		     return;
		end;
	end;

	mti.version = MS_TABLE_INFO_VERSION_3;
	mti.type = "URF";
	mti.header_size = 0;
	mti.entry_size = 48;
	mti.max_entries = size;
	mti.max_size = 65536;			/* Maximum size of each component */
	mti.keep_meters = "0"b;

	call ms_table_mgr_$create (dirname, entryname, addr (mti), code);
	if code ^= 0
	then call com_err_ (code, ME, "Creating URF ^a.", pathname_ (dirname, entryname));
	return;

/* format: off */
%page; %include ms_table_info;
/* format: on */

     end create_urf;




		    cv_.pl1                         11/12/82  1338.8rew 11/12/82  0949.3       53667



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


cv_: proc;

/* Utility routine for converting numbers & time calculations.
   THVV 10/69 */

hrmin:	entry (sec, hf, mf);

/* Time conversion procedure.
   call cv_$hrmin (seconds, hf, mf);
   call ioa_ ("^5d:^2a", hf, mf);
   */

dcl  sec fixed bin,					/* input: time in seconds */
     hf fixed bin,					/* output: hours */
     mf char (*);					/* output: mm */

dcl  temp char (4) aligned,				/* temporary */
     cv_bin_$dec entry (fixed bin, char (12)),
     ans char (12),					/* answer from cv_bin */
    (t0, t1, t2, t3) fixed bin;			/* temporaries */

	t0 = sec + 59;				/* round up. */
	t1 = divide (t0, 3600, 17, 0);		/* t1 is hours */
	t3 = t0 - t1*3600;				/* t3 is leftover seconds */
	t2 = divide (t3, 60, 17, 0);			/* t2 is minutes */

	hf = t1;					/* return hours */
	call cv_bin_$dec (t2, ans);			/* convert minutes to char */
	temp = " ";				/* blank out temp */
	substr (temp, 1, 2) = substr (ans, 11, 2);	/* get minutes */
	if temp = " " then temp = "00";		/* if zero, return 00 */
	else if substr (temp, 1, 1) = " " then substr (temp, 1, 1) = "0";
	mf = temp;				/* return minutes */
	return;					/* Zoom. */

/* - - - - - - - - - - - - - - - - */

absdat:	entry (mm, dd, yy, xabs);

dcl (mm, dd, yy, xabs) fixed bin;

dcl  datebin_ entry (fixed bin (71),
     fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin);
dcl  datebin_$revert entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71));
dcl  datebin_$shift entry (fixed bin (71), fixed bin);

dcl  time fixed bin (71);

	call datebin_$revert (mm, dd, yy, 0, 0, 0, time);
	call datebin_ (time, xabs, t0, t0, t0, t0, t0, t0, t0, t0);
	return;

/* - - - - - - - - - - - - - - - - */

shift:	entry (mm, dd, yy, hh, shno);

dcl (hh, shno) fixed bin;

	call datebin_$revert (mm, dd, yy, hh, 0, 0, time);
	call datebin_$shift (time, shno);
	return;

/* - - - - - - - - - - - - - - - - */

mwvf:	entry (flo) returns (char (15));

/* entry to do mwvf15.2 conversion */

dcl  fvl char (15) aligned init (" xxx,xxx,xxx.xx"),	/* location of commas & decimal */
     flo float bin,					/* input arg */
     ft1 float bin,					/* temp */
     i fixed bin, j fixed bin;			/* indices */

dcl  k (11) fixed bin int static init (15, 14, 12, 11, 10, 8, 7, 6, 4, 3, 2);

	if flo = 0.0e0 then return (" ");		/* w modifier means blank if all zero */
	if abs (flo) > 3.4359735e8 then go to woops;	/* determined by experiment.. */
	ft1 = flo;				/* pick up input arg */
	if ft1 < 0 then ft1 = - ft1;			/* handle negative */
	t0 = (ft1+0.005e0) * 100.0e0;			/* round up and convert to pennies */
	j = 1;
	do i = 1 to 11;				/* loop on digits */
	     t1 = mod (t0, 10);			/* get remainder */
	     t0 = divide (t0, 10, 35, 0);		/* throw away digit */
	     substr (fvl, k (i), 1) = substr ("0123456789", t1+1, 1);
	     if t1 ^= 0 then j = i;			/* Remember loc of nonzero digit. */
	end;
	if t0 > 0 | (flo < 0 & k (j) = 2) then do;	/* oflo? */
woops:	     fvl = "$***,***,***.**";			/* Overflowed. Put out junk. */
	     return (fvl);
	end;
	j = k (j);
	if j > 13 then j = 13;			/* tiny number is $.00 */
	substr (fvl, 1, j-1) = " ";			/* blank out j-1unk */
	if flo < 0
	then do;
	     substr (fvl, j-1, 1) = "-";
	     substr (fvl, j-2, 1) = "$";
	end;
	else substr (fvl, j-1, 1) = "$";
ex:	return (fvl);


/* - - - - - - - - - - - - - - - - */

cdate:	entry (dt) returns (fixed bin (71));

/* this program converts a character-string date into a system time */

dcl  dt char (*);					/* argument is a date */

dcl  chr char (1) aligned,				/* single character of date */
     wdate (3) fixed bin init (0, 0, 0),		/* month, day, yezr */
     s2 bit (1) init ("0"b),				/* switch, ON if two digits */
     clock_ entry returns (fixed bin (71));		/* system clock */

	t1 = 0;					/* accumulator for numbers */
	j = 1;					/* j is index in "wdate" */
	if dt = "*" then return ((clock_));		/* date of "*" is now */
	if dt = "P" then return (2169522000000000);	/* 10/1/69 - date Multics went public */

	t3 = index (dt, " ");			/* find loc of first blank */
	if t3 = 0 then t3 = length (dt)+1;		/* .. or length of string. */
	if t3 < 4 then return (0);			/* if not enough chars, illegal date. */

	do i = 1 to t3-1;				/* look at all chars */
	     chr = substr (dt, i, 1);			/* get one chr */
	     t0 = index ("0123456789", chr);
	     if t0 > 0 then do;			/* digit? */
		t1 = 10 * t1 + (t0 - 1);		/* yes, add it in */
		if s2 then go to store;		/* is this the second digit? */
		else s2 = "1"b;			/* no, wait for another. */
	     end;
	     else if chr = "/" then do;		/* is this a slash? */
		if t1 ^= 0 then do;			/* yes. is there anything in ac? */
store:		     wdate (j) = t1;		/* yes. save it in date */
		     t1 = 0;			/* reset ac */
		     j = j + 1;			/* index in date */
		     if j = 4 then j = 3;		/* skip "19" on year */
		     s2 = "0"b;			/* reset switch */
		end;
	     end;
	     else return (0);			/* some garbage character, die */
	end;
	if s2 then wdate (j) = t1;			/* do we have any digits leftover? */
	if wdate (1) = 0 then return (0);		/* check month for legal form. */
	if wdate (1) > 12 then return (0);		/* .. */
	if wdate (2) = 0 then return (0);		/* check day. */
	if wdate (2) > 31 then return (0);		/* .. */
	if wdate (3) = 0 then wdate (3) = 70;		/* 1970 if not specified */

compute:	call datebin_$revert (wdate (1), wdate (2), wdate (3), 0, 0, 0, time);
	return (time);

     end cv_;




		    daily_summary.pl1               07/13/88  1122.2r w 07/13/88  0941.0      114696



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

daily_summary: proc;

/* daily summary program.

   This program produces a daily billing and overspent account summary.
   It also inserts cutoff codes into the sat to prevent overspent accounts from logging in.

   inputs:
   .	"reqfile"		per-account requisition info

   outputs:
   .	"sumry"		one line per requisition showing status & charges
   .      "sat"		new cutoff code for every project in sat
   .      "cutrpt"		list of user cutoff information

   THVV 11/69 - KAW 6/71

   Modified by T. Casey, May 1976, to put account balance figures into SAT entry.
   */

dcl  dn char (168) aligned,				/* segment names */
     en char (32) aligned,				/* ... */
     ec fixed bin,					/* file-system error code */
     al fixed bin,
    (i, j, m) fixed bin,				/* counters */
     dtemp char (8) aligned,				/* ... */
    (rv, rb) char (15) aligned,			/* ... */
    (total_month, total_amt, total_req, total_balance) float bin init (0e0),
     open char (15) aligned internal static init ("           open"),
     warn_amt float bin int static init (10e0),
     warn_pct float bin int static init (0.10e0),		/* percentage */
     oneday fixed bin (71) int static init (86400000000),	/* one day's worth of microseconds */
     warn_days fixed bin int static init (10),		/* number of days to wait before warning */
     today fixed bin (71),
     isat fixed bin,
     cutoff_code char (1) aligned init (" "),
     satp ptr,
     satep ptr,
    (coxx, dpxx) char (4) aligned,
     date_string char (24) aligned,
     cut_count fixed bin init (0),
     warn_count fixed bin init (0),
     p ptr,
     ap ptr,
     qp ptr;					/* ptr to "reqfile" */

dcl  argu char (al) based (ap) unaligned,
     arg char (8) aligned,
     nargs fixed bin,
     balance float bin (63),
     warn bit (1) init ("0"b),
     sum bit (1) init ("1"b),
     projord bit (1) aligned init ("1"b),
     cutr bit (1) init ("1"b),
     satlist bit (1) init ("1"b);

dcl (days_to_cutoff, pct_balance) fixed bin;

dcl (addr, divide, fixed, mod, null, float, substr) builtin;

dcl  sumry char (32) int static aligned init ("sumry");	/* stream names */
dcl  cutrpt char (32) aligned int static init ("cutrpt");

dcl  error_table_$badopt fixed bin ext;

/* format statements */

dcl  l1 char (120) aligned,
     l2 char (120) aligned,
     l3 char (48) aligned int static init
    ("^-^-^-Multics ^a for the date of ^a^/"),
     l4 char (60) aligned int static init
    ("^-^-^-Table of cutoff codes"),
     l5 char (60) aligned int static init
    ("^-^-^-X - Project is out of funds and no logins permitted"),
     l6 char (60) aligned int static init
    ("^-^-^-Y - Project is out of funds but logins permitted"),
     l7 char (70) aligned int static init
    ("^-^-^-T - Project has past termination date and no logins permitted "),
     l8 char (70) aligned int static init
    ("^-^-^-S - Project has past termination date but logins permitted "),
     l9 char (70) aligned int static init
    ("^-^-^-W - Project is almost out of funds and logins permitted "),
     l10 char (70) aligned int static init
    ("^-^-^-R - Project is almost past termination date and logins permitted"),
     l11 char (90) aligned int static init
    ("^/^2xAcctid^8xAcctno^8xReq. no.^6xBilling Name^22xBilling Address^19xCutoff Code"),
     dashx1 char (90) aligned int static init
    ("  ------^8x-------^7x--------^6x------------^22x---------------^19x-----------"),
     xl2a char (98) aligned int static init
    ("^-^-^4xRequisition^8xCharge^10xRequisition^8xCharge^9xRequisition  Termination  Cutoff"),
     xl2b char (93) aligned int static init
    ("^-^14a  or PO no.^8xthis month^6xAmount^13xthis req.^6xBalance^6xDate^9xCode"),
     xl3 char (72) aligned int static init
    ("^9a ^12a  ^12a  ^15a  ^15a  ^15a  ^15a  ^8a     ^1a"),
     dashx char (120) aligned int static init
    ("^/^-------------  ------------^3x--------------^3x--------------^3x--------------^3x--------------  --------     -----");

/* procedures called by this program */

dcl  ioa_ entry options (variable),			/* output routine */
     ioa_$ioa_stream entry options (variable),		/* output on file */
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     idsort_ entry ((*) char (32) aligned, (*) fixed bin, fixed bin),
     system_info_$titles entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned),
     get_wdir_ entry () returns (char (168) aligned),
     date_time_ entry (fixed bin (71), char (*) aligned),
     clock_ entry () returns (fixed bin (71)),
     cv_$mwvf entry (float bin) returns (char (15) aligned), /* dollar converter */
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     com_err_ entry options (variable);


%include user_attributes;
%include reqfile;
%include sat;

/* - - - - - - */

	nargs = 1;
getarg:	call cu_$arg_ptr (nargs, ap, al, ec);

/* five optional arguments are permitted
   .	-warn  -  use only warning codes for projects which should be cutoff
   .	-nosat  - don't put cutoff codes in the sat
   .	-nosum  - don't print a sumry report
   .	-nocutr  - don't print a cutrpt
   .	-noproj - output is sorted by account number instead of project id
   */
	if ec = 0 then do;
	     nargs = nargs+1;
	     arg = argu;
	     if arg = "-warn" then warn = "1"b;
	     else if arg = "-nosat" then satlist = "0"b;
	     else if arg = "-nosum" then sum = "0"b;
	     else if arg = "-nocutr" then cutr = "0"b;
	     else if arg = "-noproj" then projord = "0"b;
	     else call com_err_ (error_table_$badopt, "daily_summary", """^a""", arg);
	     go to getarg;
	end;
	today = clock_ ();				/* get date to put on reports */
	call date_time_ (today, date_string);
	call system_info_$titles (coxx, dpxx, l1, l2);	/* get installation id */
	dn = get_wdir_ ();				/* get working directory */
	en = "reqfile";				/* Now get requisition file. */
	call hcs_$initiate (dn, en, "", 0, 1, qp, ec);	/* Initiate reqfile. */
	if qp = null then do;
err:	     call com_err_ (ec, "daily_summary", en);
	     return;
	end;

	if satlist then do;				/* initiate sat unless "nosat" arg given */
	     en = "smf.cur.sat";
	     call hcs_$initiate (dn, en, "", 0, 1, satp, ec);
	     if satp = null then go to err;
	end;

	if sum then do;				/* print heading on sumry unless "nosum" arg given */
	     call ioa_$ioa_stream (sumry, "^|^-^-^a^/", l1); /* heading on summary */
	     call ioa_$ioa_stream (sumry, "^-^-^-^a^/", l2);
	     call ioa_$ioa_stream (sumry, l3, "billing summary", date_string);
	     call ioa_$ioa_stream (sumry, xl2a);
	     call ioa_$ioa_stream (sumry, xl2b, "Account no.");
	     call ioa_$ioa_stream (sumry, dashx);
	end;
	if cutr then do;				/* print heading on cutrpt unless "nocutr" arg given */

	     call ioa_$ioa_stream (cutrpt, "^|^-^-^a^/", l1);
	     call ioa_$ioa_stream (cutrpt, "^-^-^-^a^/", l2);
	     call ioa_$ioa_stream (cutrpt, l3, "overspent account summary", date_string);
	     call ioa_$ioa_stream (cutrpt, l4);
	     call ioa_$ioa_stream (cutrpt, l5);
	     call ioa_$ioa_stream (cutrpt, l6);
	     call ioa_$ioa_stream (cutrpt, l7);
	     call ioa_$ioa_stream (cutrpt, l8);
	     call ioa_$ioa_stream (cutrpt, l9);
	     call ioa_$ioa_stream (cutrpt, l10);
	     call ioa_$ioa_stream (cutrpt, l11);
	     call ioa_$ioa_stream (cutrpt, dashx1);
	end;

	m = reqfile.nacts;
	begin;


dcl  strings (m) char (32) aligned,
     indices (m) fixed bin;

	     do i = 1 to m;
		indices (i) = i;
		strings (i) = reqfile.reqfiletab (i).acctid;
	     end;
	     if projord then call idsort_ (strings, indices, m);
	     do j = 1 to m;
		i = indices (j);
		if acctid (i) = " " then go to skipb;
		cutoff_code = " ";
		balance = 0e0;
		pct_balance = 100;			/* pct_balance=100 means req_amt=0 and there is no dollar limit */
		days_to_cutoff = 131071;
		if mitacct (i) = "nonbill" then goto setsat; /* be sure users on nonbill projects
						   do not get cutoff warning messages */
		if reqfiletab.cutoff (i) < today then cutoff_code = "T"; /* has project past termination date */
		else if reqfiletab.cutoff (i) < today + (warn_days*oneday) then cutoff_code = "R";

		days_to_cutoff = 1 + divide (reqfiletab.cutoff (i) - today, oneday, 17, 0); /* truncate to next lower
						   whole day, and then add 1;
						   the message says "less than N days" */
		if req_amt (i) > 0e0 then do;		/* there is no limit for req_amt=0 */
		     balance = req_amt (i) - chg_tr (i) - chg_mo (i); /* get current balance for project */
		     if balance < 0e0 then cutoff_code = "X"; /* account is overspent */
		     else if balance < warn_amt then if cutoff_code ^= "T" then cutoff_code = "W";
			else;
		     else if balance < warn_pct * req_amt (i) then if cutoff_code ^= "T" then cutoff_code = "W";

		     pct_balance = (balance*100e0) / req_amt (i); /* floating divide, then fix */

		end;
		if warn then do;			/* if "warn" arg given change severe codes to warn codes */
		     if cutoff_code = "T" then cutoff_code = "S";
		     else if cutoff_code = "X" then cutoff_code = "Y";
		end;
		if cutoff_code = "X" then cut_count = cut_count + 1;
		else if cutoff_code = "T" then cut_count = cut_count + 1;
		else if cutoff_code ^= " " then warn_count = warn_count + 1;

		if chg_mo (i) = 0e0 then go to skipp;	/* ignore if zero charge */
		if sum then do;			/* print sumry total unless "nosum" arg given */
		     if req_amt (i) = 0e0 then do;	/* Check for OPEN */
			rv, rb = open;
		     end;
		     else do;			/* ... no */
			rv = cv_$mwvf (float (req_amt (i)));
			rb = cv_$mwvf (float (balance));
		     end;
		     call date_time_ (reqfile.cutoff (i), dtemp);
		     call ioa_$ioa_stream (sumry, xl3, acctid (i), mitacct (i), reqno (i),
			cv_$mwvf (float (chg_mo (i))), rv,
			cv_$mwvf (float (chg_mo (i) + chg_tr (i))), rb, dtemp, cutoff_code);
		end;

skipp:		total_month = total_month + chg_mo (i);
		total_amt = total_amt + req_amt (i);
		total_req = total_req + chg_mo (i) + chg_tr (i);
		total_balance = total_balance + balance;

setsat:		if satlist then do;			/* put cutoff_code in sat unless "nosat" arg given */
		     do isat = 1 to satp -> sat.current_size; /* locate corresponding sat entry */
			satep = addr (satp -> sat.project (isat));
			if project.state = 1 then if project.project_id = acctid (i) then do;
				project.cutoff = cutoff_code;
						/* copy figures used for printing of cutoff warning messages */
				project.days_to_cutoff = days_to_cutoff; /* into the sat entry for the project */
				project.dollars_to_cutoff = balance;
				project.pct_balance = pct_balance;

				go to print_cut;	/* we found the project; now get out of the loop */
			     end;
		     end;
		     if chg_mo (i) ^= 0e0 then	/* error unless proj is dead */
			if qdf (i) = 0 then
			     call ioa_ ("daily_summary: project ""^a"" not in sat but req has charge $^.2f",
			     acctid (i), chg_mo (i));
		end;
print_cut:	if cutr then do;			/* print nonblank cutoff_codes unless "nocutr" arg given */
		     if cutoff_code ^= " " then	/* */
			if qdf (i) = 0 then		/* only active projects */
			     call ioa_$ioa_stream (cutrpt, "^/^2x^12a  ^12a  ^12a  ^32a  ^32a  ^1a",
			     acctid (i), mitacct (i), reqno (i), billing_name (i), billing_addr (i), cutoff_code);
		end;
skipb:	     end;
	end;
	if sum then do;				/* print totals unles "nosum" arg given */
	     call ioa_$ioa_stream (sumry, dashx);
	     call ioa_$ioa_stream (sumry, xl3, "", "", "", cv_$mwvf (total_month), cv_$mwvf (total_amt),
		cv_$mwvf (total_req), cv_$mwvf (total_balance), "", "");
	end;

/* close all files */

	call ioa_ ("daily_summary: cut ^d, warned ^d, total $^.2f", cut_count, warn_count, total_month);

	if satlist then call hcs_$terminate_noname (satp, ec);
	call hcs_$terminate_noname (qp, ec);		/* Terminate reqfile. */
	return;

     end daily_summary;




		    delete_proj.pl1                 07/13/88  1122.2r w 07/13/88  0941.0       53424



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


delete_proj: proc;

/* DELETE_PROJ - Program used by user accounts to delete a project.

   THVV */

dcl  dn char (168) aligned,
     en char (32) aligned,
    (i, j, k, l, m, n) fixed bin,
     mylock bit (1) init ("0"b),
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin (35);

dcl (new_pdt, old_pdt) char (32) aligned;

dcl  udd char (64) aligned int static init (">user_dir_dir"),
     sc1_pdt char (64) aligned int static init (">system_control_1>pdt"),
     sc1 char (64) aligned int static init (">system_control_1");
dcl  pp ptr,					/* ptr to projfile */
     qp ptr,					/* ptr to reqfile */
     satp ptr,					/* ptr to sat */
     sadp ptr,					/* ptr to sys_admin_data */
     satep ptr,					/* ptr to sat entry. */
     p ptr,					/* ptr to new table entry */
     q ptr;					/* ptr to dummy entry */

dcl  set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)),
     set_lock_$unlock entry (bit (36) aligned, fixed bin (35)),
     error_table_$locked_by_this_process fixed bin (35) ext,
     error_table_$invalid_lock_reset fixed bin (35) ext;

dcl (addr, null, substr, index, verify, search, reverse, length, bit, fixed, divide, mod) builtin;

dcl  clock_ entry () returns (fixed bin (71)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     get_wdir_ entry () returns (char (168) aligned),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     com_err_ entry options (variable);


dcl  hcs_$chname_file entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));
dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2),
     ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));


%include user_attributes;
%include sys_admin_data;
%include projfile;
%include reqfile;
%include sat;

dcl 1 Nsate aligned like project;

/* ======================================================== */

	dn = get_wdir_ ();
	en = "sys_admin_data";
	call hcs_$initiate (dn, en, "", 0, 1, sadp, ec);
	if sadp = null then go to er;
	call set_lock_$lock (sys_admin_data.lock, 60, ec);
	if ec ^= 0 then
	     if ec = error_table_$locked_by_this_process then mylock = "1"b;
	     else if ec ^= error_table_$invalid_lock_reset then do;
		call com_err_ (ec, "delete_proj", "Sys_admin_data is locked by ^a", sys_admin_data.locker);
		go to exit1;
	     end;

	en = "smf.cur.sat";
	call hcs_$initiate (dn, en, "", 0, 1, satp, ec);
	if satp = null then do;
er:	     call com_err_ (ec, "delete_proj", en);
	     go to abend;
	end;
	en = "projfile";
	call hcs_$initiate (dn, en, "", 0, 1, pp, ec);
	if pp = null then go to er;
	en = "reqfile";
	call hcs_$initiate (dn, en, "", 0, 1, qp, ec);
	if qp = null then go to er;

	en = "";
	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then go to er;
	Nsate.project_id = bchr;

	do i = 1 to sat.current_size;
	     satep = addr (sat.project (i));
	     if Nsate.project_id = project.project_id then
		if project.state = 1 then do;
		     project.state = 2;		/* Flag proj as deleted. */
		     go to check_req;
		end;
		else if project.state = 2 then do;
		     call com_err_ (0, "delete_proj", "Project ""^a"" has already been deleted.",
			Nsate.project_id);
		     go to abend;
		end;
	end;
	call com_err_ (0, "delete_proj", "Project ""^a"" not found in SAT", Nsate.project_id);
	go to abend;

check_req: do i = 1 to reqfile.nacts while (Nsate.project_id ^= reqfile.acctid (i)); end;
	if i <= reqfile.nacts then
	     if reqfile.qdf (i) ^= 0 then do;
		call com_err_ (0, "delete_proj", "Project ""^a"" is deleted from reqfile.", Nsate.project_id);
		go to abend;
	     end;
	     else reqfile.qdf (i) = clock_ ();		/* Delete him */
	else do;
	     call com_err_ (0, "delete_proj", "Project ""^a"" not found in reqfile.",
		Nsate.project_id);
	     go to abend;
	end;

	do i = 1 to projfile.nproj while (Nsate.project_id ^= projfile.id (i)); end;
	if i <= projfile.nproj then
	     if projfile.off (i) ^= 0 then do;
		call com_err_ (0, "delete_proj", "Project ""^a"" is deleted from projfile.", Nsate.project_id);
		go to abend;
	     end;
	     else projfile.off (i) = clock_ ();
	else do;
	     call com_err_ (0, "delete_proj", "Project ""^a"" not found in projfile.",
		Nsate.project_id);
	     go to abend;
	end;

	call ioa_$rsnnl ("^a.pdt", old_pdt, i, Nsate.project_id);
	call ioa_$rsnnl ("delete.^a.pdt", new_pdt, i, Nsate.project_id);
	call hcs_$chname_file (sc1_pdt, old_pdt, "", new_pdt, ec);
	if ec ^= 0 then call com_err_ (ec, "delete_proj", "Cannot add name ^a to ^a>^a",
	     new_pdt, sc1_pdt, old_pdt);

/* Could delete project dir here.. Might interfere with installation policy tho. */
/* Note that we cannot necessarily remove project admins. */
/* ..aha: we can if they have a project ID of this project. */
/* .. do that later */

/* Terminate all segments. */

abend:	call hcs_$terminate_noname (pp, ec);
	call hcs_$terminate_noname (qp, ec);
	call hcs_$terminate_noname (satp, ec);
exit1:	if ^mylock then call set_lock_$unlock (sys_admin_data.lock, ec);
	call hcs_$terminate_noname (sadp, ec);
	return;

/* -------------------------------------------------------- */

test:	entry (asc1, audd);
dcl (asc1, audd) char (*);

	sc1 = asc1;
	udd = audd;
	call ioa_ ("udd = ^a^/sc1 = ^a", udd, sc1);
	call ioa_$rsnnl ("^a>pdt", sc1_pdt, j, sc1);
	return;

     end;




		    disk_left_.pl1                  07/20/88  1247.8r w 07/19/88  1533.3       23733



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


disk_left_: proc (avail, left);

dcl (avail, left) fixed bin (35);			/* Return arguments. */

/* DISK_LEFT_ - This program is called by system_total to find out the current disk occupancy.

   Method stolen from the device_meters command written by NIM.

   THVV 
   Modified March, 1982, J. Bongiovanni, for new PVTE and considerable clean-up
*/

dcl  j fixed bin;					/* Counter. */
dcl  ec fixed bin (35);				/* error code from ring0_get_ */
dcl  pvt_size fixed bin (19);
dcl  pvt_lth fixed bin;

dcl  MYNAME char (10) int static options (constant) init ("disk_left_");

dcl  com_err_ entry options (variable);
dcl  get_temp_segment_ entry (char(*), ptr, fixed bin(35));
dcl  release_temp_segment_ entry (char(*), ptr, fixed bin(35));
dcl  ring_zero_peek_$get_max_length entry (char(*), fixed bin(19), fixed bin(35));
dcl  ring_zero_peek_$by_name entry (char(*), fixed bin(18), ptr, fixed bin(19), fixed bin(35));


dcl (addr, addrel, baseno, bin, null, size) builtin;

dcl  cleanup condition;
	  

/* ======================================================= */

	avail, left = 0;				/* Clear arguments. */

	pvtp = null ();
	on cleanup call clean_out;
	
	call get_temp_segment_ (MYNAME, pvtp, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, MYNAME, "Getting temp segment.");
	     return;
	end;
	
	call ring_zero_peek_$get_max_length ("pvt", pvt_size, ec);
	if ec ^= 0 then do;
CANNOT_GET_PVT:
	     call com_err_ (ec, MYNAME, "pvt");
	     return;
	end;
	call ring_zero_peek_$by_name ("pvt", 0, pvtp, pvt_size, ec);
	if ec ^= 0 then goto CANNOT_GET_PVT;
	
	pvt_arrayp = addr (pvt.array);
	do j = 1 to pvt.n_entries;
	     pvtep = addr (pvt_array (j));
	     if pvte.used then do;
		left = left + pvte.nleft;	/* Obtain records left. */
		avail = avail + pvte.totrec;
						/* Close enough for now.. shd use true value someday */
	     end;
	end;

	call clean_out;
	return;
	
clean_out:
	proc;
	
	if pvtp ^= null ()
	     then call release_temp_segment_ (MYNAME, pvtp, ec);
	pvtp = null ();
	
end clean_out;


%page; %include pvt;
%page; %include pvte;
       

     end disk_left_;




		    disk_stat_print.pl1             07/13/88  1122.2r w 07/13/88  0941.0      198036



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




/****^  HISTORY COMMENTS:
  1) change(87-10-06,Parisek), approve(88-02-03,MCR7845),
     audit(88-04-18,Lippard), install(88-04-26,MR12.2-1043):
     Implement multi-segment file application for possible >256K disk_stat
     segment.
                                                   END HISTORY COMMENTS */


/* format: style4 */
disk_stat_print: dsp: proc;

/*
   Completely rewritten by TAC, April 1976
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.
   Modified June 1982 by E. N. Kittlitz to set rs_number if search_sat_ complains.
*/

/* This procedure prints the disk_stat file that is created by sweep.
   The segment "disk_stat" in the working directory is used, unless a pathname is given.
   Optional control arguments allow the user to specify:
   1 - printing of just the totals figures;
   2 - printing only those directories at or above a specified level,
   -   with the usage figures of the entire subtree below that directory being
   -   included in the figures printed for that directory;
   3 - printing of per-level subtotals each time level decreases;
   4 - printing of a per-logical-volume summary of disk usage, following the totals lines.

   Usage: dsp -path- -total (-tt) -logical_volume (-lv) -subtotal (-stt) -level (-lev) N

*/

/* Declarations */

/* Ext Entries */

dcl  com_err_ entry options (variable);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_$mwvf entry (float bin) returns (char (15));	/* library routines */
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  get_wdir_ entry () returns (char (168));
dcl  search_sat_$rs_number entry (char (*), fixed bin, fixed bin (35));
dcl  search_sat_$clean_up entry;
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  mdc_$find_lvname entry (bit (36) aligned, char (*) aligned, fixed bin (35));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35));
dcl  user_info_$rs_number entry (fixed bin);
dcl  user_info_$rs_name entry (char (*));
dcl  system_info_$rs_name entry (fixed bin, char (*), fixed bin (35));
dcl  system_info_$prices_rs entry (fixed bin,
	(0:7) float bin, (0:7) float bin, (0:7) float bin, (0:7) float bin, float bin, float bin);
dcl  system_info_$max_rs_number entry (fixed bin);
dcl  system_info_$titles entry (char (*), char (*));

/* Bit */

dcl  (msf, no_sat, subtot_sw, total_sw, volume_sw) bit (1) aligned init ("0"b);

/* Fixed bin */

dcl  ttemp fixed bin (71);				/* clock value */
dcl  (code, bad_lvid_code) fixed bin (35) init (0);

dcl  (acpx, al, an, cpx, dlev, i, j, k, lvl, nxtlev, ti) fixed bin;
						/* misc counters */
dcl  n_bad_lvids fixed bin init (0);
dcl  (lvix, nlv, root_lvix) fixed bin;			/* indices in lv_totals structure */
dcl  fmt_ix fixed bin init (1);			/* which formats to use */
dcl  maxlev fixed bin init (16);			/* print all levels, by default */
dcl  ROOT fixed bin;				/* level of first dir in disk_stat (normally 0 for root) */
dcl  rs_name char (32);
dcl  rs_number fixed bin;
dcl  rs_count fixed bin;
dcl  last_dent fixed bin;
		  
/* Float bin */

dcl  dummy (0:7) float bin;
dcl  dummy1 float bin;
dcl  disk_price (0:9) float bin;

/* Char */

dcl  path char (168);				/* for printing pathname from disk_stat entry */
dcl  dn char (168) init (get_wdir_ ());			/* both for getting disk stat file and printing its entries */
dcl  (coxx, dpxx) char (64);				/* company and department names, for heading */
dcl  en char (32) init ("disk_stat");
dcl  old_project_entry char (32) init ("");
dcl  (ttmp1, ttmp2) char (24);			/* from-date and to-date for heading */
dcl  errmsg char (64) varying;			/* error info */

/* Automatic Structure */

dcl  1 subtot (0:16),
       2 (dquota, dused, squota, sused, dvolx, dsix) fixed bin,
       2 (dcharge, scharge) float bin;

dcl  cp_array (0:4) ptr;
		  

/* Format strings for ioa_ */

dcl  dir_formats (2) char (36) int static init (
	"^7d ^7d^15a ^7d ^7d^15a ^5d ^s^a",
	"^7d ^7d^15a ^7d ^7d^15a ^5d ^4d ^a");

dcl  heading_dashes (2) char (99) int static init (
	"------- ------- -------------- ------- ------- -------------- ----- ------------------------^/",
	"------- ------- -------------- ------- ------- -------------- ----- ---- ------------------------^/");

dcl  heading_words (2) char (72) int static init (
	"^/^2xs-qta^3xs-use^7xs-charge^3xd-qta^3xd-use^7xd-charge^3xlev path",
	"^/^2xs-qta^3xs-use^7xs-charge^3xd-qta^3xd-use^7xd-charge^3xlev lvix path");

dcl  sub_total_formats (2) char (32) int static init (
	"^7d ^7d^15a ^7d ^7d^15a^7x^a",
	"^7d ^7d^15a ^7d ^7d^15a^12x^a");

dcl  total_formats (2) char (24) int static init (
	"^/^31x^7d ^7d^15a^7x^a",
	"^/^31x^7d ^7d^15a^12x^a");

dcl  vol_format char (26) int static init (
	"^31x^7d ^7d^15a ^5x ^4d ^a");

/* Ptr */

dcl  (ap, fcbp, lvtp, pdtep, pdtp) ptr;

/* Based */


dcl  bchr char (al) based (ap);

dcl  1 lv_totals (-1:nlv) aligned based (lvtp),
       2 lv_name char (32),
       2 lv_tpp float bin,
       2 lv_id bit (36),
       2 lv_quota fixed bin,
       2 lv_used fixed bin;

/* Builtin */

dcl  (addr, after, before, hbound, null, substr) builtin;

/* Ext */

dcl  (error_table_$badopt, error_table_$bad_arg, error_table_$noentry) ext fixed bin (35);
dcl  sys_info$max_seg_size fixed bin (35) ext static;

/* Procedure */

	call system_info_$max_rs_number (rs_count);	/* see if site has multiple rate structures */

	code = 0;
	sp = null;
	fcbp = null;

	do an = 1 by 1 while (code = 0);		/* go thru all arguments */

	     call cu_$arg_ptr (an, ap, al, code);

	     if code = 0 then do;			/* if there is an argument */

		if substr (bchr, 1, 1) = "-" then do;	/* control argument */

		     if bchr = "-tt" | bchr = "-total" then
			total_sw = "1"b;

		     else if bchr = "-stt" | bchr = "-subtotal" then
			subtot_sw = "1"b;

		     else if bchr = "-lv" | bchr = "-vol" | bchr = "-volume"
			     | bchr = "-lvol" | bchr = "-logical_volume" then do;
			volume_sw = "1"b;
			fmt_ix = 2;		/* use formats with place for lvix column */
		     end;

		     else if bchr = "-lev" | bchr = "-level" then do;
			an = an + 1;
			call cu_$arg_ptr (an, ap, al, code);
			if code ^= 0 then do;	/* must be error_table_$noarg */
			     en = "after -level";
			     goto er;
			end;

			maxlev = cv_dec_check_ (bchr, code);
			if code ^= 0 then do;
			     code = 0;		/* not an error_table_ code */
			     en = "illegal decimal number: " || bchr;
			     goto er;
			end;

			if maxlev < 0 | maxlev > 16 then do;
			     en = "level must be >= 0 and <= 16";
			     goto er;
			end;
		     end;				/* end -level do group */

		     else do;			/* unrecognized control arg */
			code = error_table_$badopt;
			en = bchr;
			goto er;
		     end;

		end;				/* end control arg do group */

		else if sp = null then do;		/* must be pathname of disk_stat file */
		     call expand_path_ (ap, al, addr (dn), addr (en), code);
		     if code ^= 0 then go to er;
		end;

		else do;
		     code = error_table_$bad_arg;
		     en = bchr;
		     goto er;
		end;

	     end;					/* end there-is-an-arg do group */
	end;					/* end arg loop */

	call msf_manager_$open (dn, en, fcbp, code);
	if code ^= 0 then do;
	     call com_err_ (code, "disk_stat_print", "Cannot obtain MSF control block pointer.");
	     return;
	end;
	acpx, cpx, ti = 0;
cpx_loop: call msf_manager_$get_ptr (fcbp, cpx, "0"b, cp_array (cpx), 0, code);
	if code = 0 then do;
	     cpx = cpx + 1;
	     goto cpx_loop;
	end;
	if cp_array (0) = null () then do;
er:	     call com_err_ (code, "disk_stat_print", en);
	     return;
	end;

	sp = cp_array (0);

	do rs_number = 0 to hbound (disk_price, 1);	/* get all the rates */
	     call system_info_$rs_name (rs_number, rs_name, code); /* this here to check for a valid rate */
	     if code ^= 0 then disk_price (rs_number) = disk_price (0); /* assumes default will not give an error */
	     else call system_info_$prices_rs (rs_number, dummy, dummy, dummy, dummy, disk_price (rs_number), dummy1);
	end;

	if volume_sw then do;			/* initialize for presenting per-logical-volume data */
	     call hcs_$make_seg ("", "lv_totals", "", 1010b, lvtp, code);
	     if lvtp = null then do;
lv_er:		en = "[pd]>lv_totals";
		goto er;
	     end;

	     call hcs_$truncate_seg (lvtp, 0, code);	/* make sure there is no junk in it */
	     if code ^= 0 then goto lv_er;

	     lv_totals (-1).lv_name = "Unknown volumes";
						/* slot zero is unused, for convenience of implementation */
	     lv_totals (1).lv_name = "root";		/* reserve slot for rlv, so we will know */
	     root_lvix = 1;				/* where to record directory page use */
	     nlv = 1;
	end;

	if ^total_sw then do;			/* print heading, unless just printing totals */
	     call system_info_$titles (coxx, dpxx);
	     call ioa_ ("^|^a^/^/^a", coxx, dpxx);
	     ttemp = dtime;
	     call date_time_ (ttemp, ttmp2);
	     ttemp = dreset;
	     call date_time_ (ttemp, ttmp1);
	     call ioa_ ("^/Disk usage for ^a to ^a", ttmp1, ttmp2);

	     dn = "";				/* initialize for later pathname printing */
	end;					/* end print-heading do group */

/* print one line heading even if printing totals only */
	call ioa_ (heading_words (fmt_ix));

	if ^total_sw then				/* if not being terse */
	     call ioa_ (heading_dashes (fmt_ix));

	ROOT = disk_stat.slev (1);			/* get level of first dir in disk_stat */
	dlev = ROOT - 1;				/* initialize dlev to facilitate detection of
						   decreasing level number, for printing subtotals */

/* Start main loop */

	last_dent = dents;
begin:	
	do i = 1 to last_dent + 1;			/* go thru all dirs in disk_stat, plus one more time
						   to print the last line or subtree */

	     if i = last_dent + 1 then			/* if this is that one more time */
		nxtlev = ROOT;			/* pretend there is another root at the end of disk_stat */
	     else nxtlev = disk_stat.slev (i);		/* else get level of next dir */
print_lev:					/* need to know where to come if MSF */
	     if ^total_sw				/* if we are printing directory lines */
		& i > 1				/* and there is a previous directory */
		& dlev <= maxlev			/* and it is in the range of levels being printed */
		& nxtlev <= maxlev then		/* and next dir is not part of a non-printing subtree under it */
		call print_dir_line (dlev);		/* then print a line for the previous dir now */

/* If the next dir is not at a higher level number than the previous one,
   this loop gets executed one or more times, to free the subtotal array entry
   in which we want to store the figures for the next dir */

	     do lvl = dlev by -1 to nxtlev		/* back up thru levels, from last dir's to this one's */
		while (lvl > ROOT);			/* but stop one level sooner if nxtlev=ROOT */

		call add_up_subtot (lvl - 1, lvl);	/* add inferior subtree's figures to its superior */

		if lvl - 1 <= maxlev & ^total_sw then do; /* if printing is wanted for level just added to */
		     if lvl - 1 = maxlev		/* if superior is a subtree waiting to be printed */
			& nxtlev <= maxlev then	/* and next dir is not part of it */
			call print_dir_line (lvl - 1);/* print a line for the subtree */

		     else				/* but if superior is not a subtree waiting to be printed */
			if subtot_sw then		/* and user wants subtotals */
			if nxtlev <= lvl - 1 then	/* and next dir is equal to or superior to the superior */
			     call print_subtot_line (lvl - 1); /* print a subtotal line for the superior */
		end;				/* end printing-wanted-for-level do group */

	     end;					/* end loop backing up through the levels */
	     if msf then goto next_component;

/* Now, level nxtlev in the subtot array is free to be stored into */

	     dlev = nxtlev;				/* now, next dir becomes this dir */

	     if i <= last_dent then do;		/* if this dir is real, and not the imaginary
						   root at the end of disk_stat, store its figures
						   into the appropriate subtotal array entry */

		if dlev < 1 | rs_count = 0 then rs_number = 0; /* if ^project dir or site has no rate structures */
		else call set_disk_price_index (i, rs_number); /* find the correct price */
		subtot (dlev).dquota = disk_stat.dqta (i);
		subtot (dlev).squota = disk_stat.sqta (i);
		subtot (dlev).dused = disk_stat.duse (i);
		subtot (dlev).sused = disk_stat.suse (i);
		subtot (dlev).dcharge = disk_stat.dtpp (i) * disk_price (rs_number);
		subtot (dlev).scharge = disk_stat.stpp (i) * disk_price (rs_number);
		subtot (dlev).dsix = i;		/* so we can find pathname of dir where subtree starts */

		if volume_sw then do;		/* if we are supposed to save per-volume information */
		     do lvix = 1 to nlv		/* look up this directory's logical volume */
			while (lv_totals (lvix).lv_id ^= disk_stat.slvid (i));
		     end;

		     if lvix = nlv + 1 then do;	/* if this volume is not in our list yet */
			call mdc_$find_lvname (disk_stat.slvid (i), lv_totals (lvix).lv_name, code);
			if code ^= 0 then do;	/* if mdc_ does not recognize the lvid */
			     lvix = -1;		/* use the "Unknown volumes" entry */
			     n_bad_lvids = n_bad_lvids + 1; /* count these, for one error message at end */
			     if bad_lvid_code = 0 then/* remember the code, too */
				bad_lvid_code = code;
			end;

			else if lv_totals (lvix).lv_name = "root" then /* root logical volume */
			     lvix = 1;		/* slot 1 is reserved for it */

			else nlv = lvix;		/* otherwise, we have a new logical volume */

			lv_totals (lvix).lv_id = disk_stat.slvid (i); /* save the lvid */

		     end;				/* end volume-not-in-list do group */

/* segment data gets added to the lvid entry */
		     lv_totals (lvix).lv_tpp = lv_totals (lvix).lv_tpp + disk_stat.stpp (i) * disk_price (rs_number);
		     lv_totals (lvix).lv_quota = lv_totals (lvix).lv_quota + disk_stat.sqta (i);
		     lv_totals (lvix).lv_used = lv_totals (lvix).lv_used + disk_stat.suse (i);

/* but directory data gets added to the rlv's entry */
		     lv_totals (root_lvix).lv_tpp = lv_totals (root_lvix).lv_tpp + disk_stat.dtpp (i) * disk_price (rs_number);
		     lv_totals (root_lvix).lv_quota = lv_totals (root_lvix).lv_quota + disk_stat.dqta (i);
		     lv_totals (root_lvix).lv_used = lv_totals (root_lvix).lv_used + disk_stat.duse (i);

		     subtot (dlev).dvolx = lvix;	/* remember lvix of dir that starts this subtree */

		end;				/* end save-per-volume-information do group */

	     end;					/* end this-is-a-real-dir do group */
	     if (lodh + (i+1) * lode) > sys_info$max_seg_size then do;
		msf = "1"b;
		goto print_lev;
next_component:	msf = "0"b;
		ti = ti + i;
		last_dent = dents - ti;
		acpx = acpx + 1;
		sp = cp_array (acpx);
		goto begin;
	     end;
	end;					/* end main loop thru disk_stat */

/* Now, print totals and volume summary, if user wants it */

	if n_bad_lvids > 0 then
	     call com_err_ (bad_lvid_code, "disk_stat_print", "There were ^d directories with unknown lvid's", n_bad_lvids);

	if ^total_sw then
	     call ioa_ (heading_dashes (fmt_ix));

	call ioa_ (sub_total_formats (fmt_ix),
	     subtot (ROOT).squota, subtot (ROOT).sused, cv_$mwvf (subtot (ROOT).scharge),
	     subtot (ROOT).dquota, subtot (ROOT).dused, cv_$mwvf (subtot (ROOT).dcharge),
	     "SUBTOTALS");

	call ioa_ (total_formats (fmt_ix),
	     subtot (ROOT).squota + subtot (ROOT).dquota,
	     subtot (ROOT).sused + subtot (ROOT).dused,
	     cv_$mwvf (subtot (ROOT).scharge + subtot (ROOT).dcharge),
	     "TOTALS (SEGMENTS + DIRECTORIES)");

	if ^total_sw then call ioa_;			/* skip a line if not being terse */

	if volume_sw then				/* if user so requested,   */
	     do i = -1 to nlv;			/* print per-logical-volume data */
	     if i >= 1 |				/* if this is a real volume, or */
		lv_totals (i).lv_quota > 0 then	/* the dummy entry has some data in it */
		call ioa_ (vol_format,
		     lv_totals (i).lv_quota, lv_totals (i).lv_used,
		     cv_$mwvf (lv_totals (i).lv_tpp),
		     i, lv_totals (i).lv_name);
	end;


finish:	
	if fcbp ^= null then
	     call msf_manager_$close (fcbp);
	if volume_sw then do;			/* clean up temp seg if we had one */
	     call hcs_$truncate_seg (lvtp, 0, code);
	     call hcs_$terminate_noname (lvtp, code);
	end;
	if rs_count > 0 then call search_sat_$clean_up;	/* tidy up */

	return;
err_finish:
	call com_err_ (0, "disk_stat_print", errmsg);
	goto finish;

add_up_subtot: proc (l, ll);				/* procedure to add level ll subtotals to level l subtotals */

dcl  (l, ll) fixed bin;				/* ll is usually l+1, to add, for example,
						   a user's figures to the project's subtotal */

	subtot (l).dquota = subtot (l).dquota + subtot (ll).dquota;
	subtot (l).dused = subtot (l).dused + subtot (ll).dused;
	subtot (l).squota = subtot (l).squota + subtot (ll).squota;
	subtot (l).sused = subtot (l).sused + subtot (ll).sused;
	subtot (l).dcharge = subtot (l).dcharge + subtot (ll).dcharge;
	subtot (l).scharge = subtot (l).scharge + subtot (ll).scharge;

/*             subtot(l).dsix is not modified after being set; it lets us find path of dir that begins this subtree */

	if subtot (l).dvolx ^= subtot (ll).dvolx then	/* if level l and level ll dirs not on same lvol */
	     subtot (l).dvolx = 0;			/* say "more than one volume" */

	return;

     end add_up_subtot;


print_dir_line: proc (l);				/* procedure to print line for single dir or subtree */

dcl  l fixed bin;

	path = disk_stat.spth (subtot (l).dsix);	/* get full path of this dir */

	path = spth (subtot (l).dsix);		/* decide how much of the pathname to print */
	k = 0;
	do j = 2 to 168;				/* find leading components that are same as in previous one */
	     if substr (path, j, 1) = ">" then do;
		if substr (path, 1, j) = substr (dn, 1, j) then k = j;
	     end;
	end;
	substr (path, 1, k) = "";			/* blank out portion of path that is same as previous one */

	dn = spth (subtot (l).dsix);			/* then save this one's complete pathname,
						   for use in deciding how much of the next pathname to print */

	call ioa_ (dir_formats (fmt_ix),
	     subtot (l).squota, subtot (l).sused, cv_$mwvf (subtot (l).scharge),
	     subtot (l).dquota, subtot (l).dused, cv_$mwvf (subtot (l).dcharge),
	     l, subtot (l).dvolx, path);

	return;

     end print_dir_line;


print_subtot_line: proc (l);				/* procedure to print subtotal for a subtree */

dcl  l fixed bin;

	call ioa_ (heading_dashes (fmt_ix));		/* draw line under dirs to be subtotaled */
	call ioa_ (dir_formats (fmt_ix),
	     subtot (l).squota, subtot (l).sused, cv_$mwvf (subtot (l).scharge),
	     subtot (l).dquota, subtot (l).dused, cv_$mwvf (subtot (l).dcharge),
	     l, subtot (l).dvolx, disk_stat.spth (subtot (l).dsix)); /* print full pathname for subtotals */
	call ioa_ (heading_dashes (fmt_ix));		/* surround subtotal with lines */
	call ioa_;				/* skip one line */

	return;

     end print_subtot_line;

set_disk_price_index: proc (i, rs_number);		/* determines the correct rate to use */

dcl  rs_number fixed bin;
dcl  i fixed bin;
dcl  project_entry char (32);
dcl  path char (168);
dcl  ec fixed bin (35);

	path = after (disk_stat.spth (i), ">");		/* get rid of root */
	project_entry = before (path, ">");		/* and grab 1st level directory */
	if project_entry ^= "udd" then
	     if project_entry ^= "UDD" then
		if project_entry ^= "user_dir_dir" then do; /* doesn't belong to a project */
		     rs_number = 0;			/* use default */
		     old_project_entry = "";
		     return;
		end;
	path = after (path, ">");
	project_entry = before (path, ">");		/* finally - the project name (one of them) */
	if project_entry = old_project_entry then return; /* avoid some work */
	old_project_entry = project_entry;
	if ^no_sat then call search_sat_$rs_number (project_entry, rs_number, code); /* get rate index */
	if no_sat | code ^= 0 then do;
	     rs_number = 0;				/* assume the worst */
	     if code = error_table_$noentry then
		call com_err_ (code, "disk_stat_print",
		     "Trying to locate project ""^a"" in the sat.  Default rates will be used.",
		     project_entry);
	     else do;
		project_entry = before (project_entry, " ") || ".pdt";
		call hcs_$initiate (">sc1>pdt", project_entry, "", 0, 1, pdtp, ec); /* get the pdt */
		if pdtp ^= null then rs_number = pdt.rs_number;
		else do;				/* last effort is to use the pit.rs_number */
		     call user_info_$rs_number (rs_number);
		     call user_info_$rs_name (rs_name);
		     if no_sat then call com_err_ (0, "disk_stat_print",
			     "Insufficient access for >sc1>pdt>^a.", project_entry);
		     else call com_err_ (ec, "disk_stat_print", "Cannot access the sat or >sc1>pdt>^a.^/Using rate structure ""^a"" defined for this process.",
			     project_entry, rs_name);
		end;
		no_sat = "1"b; ;			/* indicate cannot get the sat */
	     end;
	end;
	return;

     end set_disk_price_index;
%page;
%include disk_stat;
%page;
%include pdt;
%page;
%include user_attributes;

     end disk_stat_print;




		    disklow.pl1                     09/19/84  0911.6rew 09/18/84  0755.8       54018



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


disklow: proc;

/* This program prints out a listing of projects
   whose disk usage is near their limits,
   from the disk usage figures in "projfile"
   which were placed there by "charge_disk".

   It is based on the program print_disk, and it
   prints the same information, but only for projects
   selected by the arguments (or the defaults).

   The arguments are number_left and percent_full.
   The defaults are 20 pages and 90%, respectively.

   THVV 4/70
   Modified June 1979 by C. Hornig to make it legal PL/1.
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.
   */

dcl (hp, pp) ptr,					/* pointer to input */
     dummy (0: 7) float bin,
     dummy1 float bin,
     disk_price (0:9) float bin,
     ap pointer,					/* argument pointer */
     al fixed bin,					/* argument length */
     bchr char (al) based (ap) unal,
     cs char (16) aligned,
     tid char (9) aligned,
     PERCENT_FULL float bin init (0.90e0),
     NUMBER_LEFT fixed bin init (20),
     nlow fixed bin init (0),
     rs_number fixed bin,
     rs_name char (32),
     rs_count fixed bin,
     temp fixed bin (71),				/* temp for disk use */
     dols float bin,				/* dollar charge */
     tdols float bin init (0.0e0),			/* total charge */
     tqta fixed bin (35) init (0),			/* total quota */
     tuse fixed bin (35) init (0),			/* total use */
     qta fixed bin (35),				/* project quota */
     use fixed bin (35),				/* project use */
    (i, np) fixed bin;				/* misc */
dcl  ec fixed bin (35);

dcl  system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)),
     system_info_$prices_rs entry (fixed bin,
    (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, float bin, float bin),
     system_info_$max_rs_number entry (fixed bin),
     search_sat_$rs_number entry (char (*), fixed bin, fixed bin (35)),
     search_sat_$clean_up entry,
     get_wdir_ entry () returns (char (168)),
     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     ioa_ ext entry options (variable),			/* output printing procedure */
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, fixed bin, ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),	/* file system */
     com_err_ ext entry options (variable);		/* error reporter */
dcl  error_table_$noentry external fixed bin (35);

dcl (addr, hbound, null) builtin;

dcl  format char (24) int static aligned options (constant) init /* output formats */
    ("^9a^4x^6d^4x^6d^4x^15.2f");

%include projfile;

/* - - - - */

	call system_info_$max_rs_number (rs_count);	/* see if site has multiple rate structures */
	ap = addr (ap);				/* initialize ap to dummy address */

	call cu_$arg_ptr (1, ap, al, ec);		/* get arg 1 */
	if ec = 0 then do;
	     i = cv_dec_check_ (bchr, ec);		/* number? */
	     if ec ^= 0 then do;
dec_err:		call com_err_ (0, "disklow", "^a is non-numeric.", bchr);
		return;
	     end;
	     NUMBER_LEFT = i;
	     call cu_$arg_ptr (2, ap, al, ec);		/* get arg 2 */
	     if ec = 0 then do;
		i = cv_dec_check_ (bchr, ec);
		if ec ^= 0 then go to dec_err;
		PERCENT_FULL = i/100.0e0;
	     end;
	end;

	cs = "projfile";
	call hcs_$initiate ((get_wdir_ ()), cs, "", 0, 1, pp, ec);
	if pp = null then do;
err:	     call com_err_ (ec, "disklow", cs);		/* complain */
	     return;
	end;

	do rs_number = 0 to hbound (disk_price, 1);	/* get all the prices */
	     call system_info_$rs_name (rs_number, rs_name, ec); /* this is just used to find if the rs exists */
	     if ec ^= 0 then disk_price (rs_number) = disk_price (0); /* assumes default will be defined aok */
	     else call system_info_$prices_rs (rs_number, dummy, dummy, dummy, dummy, disk_price (rs_number), dummy1);
	end;

	np = projfile.nproj;			/* get number of projects */

	call ioa_ ("Project       quota      used      dollar charge");
	do i = 1 to np;				/* loop on all projects */
	     if id (i) = "" then go to skip;
	     if off (i) ^= 0 then if disk_psec (i) = 0 then go to skip;
		else tid = "*" || id (i);
	     else tid = id (i);
	     qta = disk_quota (i);			/* extract project quota */
	     use = disk_use (i);			/* use */
	     temp = disk_psec (i);			/* page-seconds */
	     if rs_count > 0 then do;			/* only if site has multiple rate structures */
		call search_sat_$rs_number ((id (i)), rs_number, ec); /* get rate index */
		if ec ^= 0 then
		     if ec = error_table_$noentry then
			call com_err_ (ec, "disklow",
			"Trying to locate project ""^a"".  Default rates will be used.",
			id (i));
		     else call com_err_ (ec, "disklow", "Accessing the sat.  Default rates will be used");
	     end;
	     else rs_number = 0;
	     dols = temp * disk_price (rs_number);	/* compute charge */
	     tdols = tdols + dols;			/* accumulate totals */
	     tqta = tqta + qta;
	     tuse = tuse + use;
	     if use = 0 then go to skip;		/* should we print record */
	     if qta - use < NUMBER_LEFT then go to p1;
	     if (1.0e0 * use) / qta > PERCENT_FULL then go to p1;
	     go to skip;
p1:	     call ioa_ (format, tid, qta, use, dols);
	     nlow = nlow + 1;
skip:	end;
	if nlow = 0 then call ioa_ ("All projects OK.");
	call ioa_ ("");
	call ioa_ (format, "TOTAL", tqta, tuse, tdols);
	call hcs_$terminate_noname (pp, ec);		/* terminate input */
	if rs_count > 0 then call search_sat_$clean_up;	/* tidy up */

     end disklow;




		    edit_proj.pl1                   10/21/92  1138.8rew 10/21/92  1136.8      244611



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




/****^  HISTORY COMMENTS:
  1) change(92-09-23,Zimmerman), approve(92-09-23,MCR8268), audit(92-10-13,Vu),
     install(92-10-21,MR12.5-1034):
     edit_proj changed to allow deletion of project alias from SAT (phx21304)
                                                   END HISTORY COMMENTS */


/* format: style2 */
edit_proj:
     procedure options (variable);


/* EDIT_PROJ - This program is used by User Accounts to  modify projects.

   Written by T. H. VanVleck in 1973
   Modified June 1975 by T. Casey to add groups
   Modified August 1977 by T. Casey to add min_ring and max_ring
   Modified May 1978 by T. Casey to add pdir_quota.
   Modified November 1978 by T. Casey for MR7.0 to add new absentee control parameters.
   Modified April 1979 by T. Casey for MR7.0a to fix bug in $change_all entry point.
   Modified October 1979 by T. Casey for MR8.0 to fix another bug in $change_all entry point.
   Modified November 1979 by T. Casey to add -long ctl arg and change default to not -long.
   Modified June 1980 by J.N. R. Barnecut to support multiple rate structure feature.
   Modified March 1982 by E. N. Kittlitz to eliminate proj_admin_seg. 
   Modified 1984-07-09 BIM to restructure, add B2 things, dir quota.
   Modified 1984-09-14 BIM to go to V3 edit_proj_args and pass the mgtp.
   Modified 1984-09-20 BIM to correct acl determination on delegation.
   Modified 1985-02-15 E. Swenson: Since Benson was just kidding, above, I
   really corrected acl determination on delegation.
   Modified 1985-04-25 EJ Sharpe: fixed bad subscript in CHANGE_ACLS
*/

	dcl     argx		 fixed bin;
	dcl     arg_count		 fixed bin;
	dcl     ap		 pointer;
	dcl     al		 fixed bin (21);
	dcl     argument		 char (al) based (ap);
	dcl     change_all_match_all	 bit (1) aligned;
	dcl     changed		 bit (1) aligned;
	dcl     changed_count	 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     debug_switch	 bit (1) aligned init ("0"b);
	dcl     dir_priv_code	 fixed bin (35) init (-1);
	dcl     error		 bit (1) aligned;
	dcl     me		 char (32);
	dcl     mylock		 bit (1) aligned init ("0"b);
	dcl     project_name	 char (32);
	dcl     projfile_index	 fixed bin init (-1);
	dcl     reqfile_index	 fixed bin init (-1);
	dcl     satx		 fixed bin;
	dcl     (pp, qp, sadp, satp, satep, mgtp)
				 pointer;		/* to famous data segments */
	dcl     1 EPA		 aligned like edit_proj_arg;
	dcl     uid		 char (32);

/* static (or nearly) */

	dcl     USER_RING		 fixed bin (3) init (4);

	dcl     udd		 char (168) int static init (">user_dir_dir");
	dcl     sc1_pdt		 char (168) int static init (">system_control_1>pdt");
	dcl     sc1		 char (168) int static init (">system_control_1");


/* Entrypoints */

	dcl     absolute_pathname_	 entry (character (*), character (*), fixed binary (35));
	dcl     aim_check_$greater	 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	dcl     com_err_		 entry () options (variable);
	dcl     command_query_$yes_no	 entry () options (variable);
	dcl     continue_to_signal_	 entry (fixed binary (35));
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     edit_proj_$check	 entry (pointer);
	dcl     edit_proj_		 entry (pointer);
	dcl     expand_pathname_	 entry (character (*), character (*), character (*), fixed binary (35));
	dcl     find_condition_info_	 entry (pointer, pointer, fixed binary (35));
	dcl     get_group_id_	 entry () returns (char (32));
	dcl     get_wdir_		 entry () returns (character (168));
	dcl     hcs_$add_acl_entries	 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$add_dir_acl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$add_dir_inacl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
	dcl     hcs_$delete_acl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$delete_dir_acl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$delete_dir_inacl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
	dcl     hcs_$chname_file	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$get_access_class	 entry (char (*), char (*), bit (72) aligned, fixed bin (35));
	dcl     (
	        hcs_$quota_move,
	        hcs_$dir_quota_move
	        )			 entry (char (*), char (*), fixed bin (18), fixed bin (35));
	dcl     hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     initiate_file_	 entry (character (*), character (*), bit (*), pointer, fixed binary (24),
				 fixed binary (35));
	dcl     mdc_$set_mdir_quota	 entry (char (*), char (*), bit (1) aligned, fixed bin (18), fixed bin (35));
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed binary, fixed binary (35));
	dcl     set_lock_$unlock	 entry (bit (36) aligned, fixed binary (35));
	dcl     sub_err_		 entry () options (variable);
	dcl     system_privilege_$dir_priv_on
				 entry (fixed bin (35));
	dcl     system_privilege_$dir_priv_off
				 entry (fixed bin (35));
	dcl     terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));

	declare error_table_$too_many_args
				 fixed bin (35) ext static;
	declare error_table_$badopt	 fixed bin (35) ext static;
	declare error_table_$noentry	 fixed bin (35) ext static;
	declare error_table_$locked_by_this_process
				 fixed bin (35) ext static;
	declare error_table_$invalid_lock_reset
				 fixed bin (35) ext static;
%page;
%include user_attributes;
%include sys_admin_data;
%include projfile;
%include reqfile;
%include sat;
%include condition_info;
%include condition_info_header;
%include sub_error_info;
%include status_structures;
%include access_mode_values;
%include terminate_file;
%include edit_proj_arguments_;
%include acl_structures;
%include edit_proj_keywords_;
%include sub_err_flags;

	dcl     1 Nsate		 aligned like project;
	dcl     1 Nprojfile		 aligned like projfile.projfiletab;
	dcl     1 Nreqfile		 aligned like reqfile.reqfiletab;
          dcl     (addr, hbound, index, null, rtrim, unspec) builtin;
	dcl     (cleanup, sub_error_)	 condition;


/**** Normal call:
      edit_proj Project                                      prompts for all.
      edit_proj Project keyword			 prompts for one.
      edit_proj Project keyword new_value		 sets key to value
      edit_proj Project keyword new_value -long		 sets key to value and reports result.
      edit_proj Project match_keyword old_value {new_value} {-long}
						looks up old_value in set of values for match_keyword and optionally replaces. 
*/

	me = "edit_proj";
	call command_setup;

	if arg_count < 1
	then
USAGE:
	     do;
		call com_err_ (0, me, "Usage: edit_proj Project {key} {old_value} {new_value}");
		return;
	     end;

	project_name = "";

	do argx = 1 to arg_count;
	     call cu_$arg_ptr (argx, ap, al, (0));
	     if index (argument, "-") ^= 1
	     then do;				/* non-control */
		     if project_name = ""
		     then project_name = argument;
		     else if EPA.value_index = -1
		     then call lookup_keyword ();
		     else if matching_keyword ()
		     then if EPA.match_value.ptr = null ()
			then do;
				EPA.match = "1"b;
				EPA.match_value.ptr = ap;
				EPA.match_value.length = al;
			     end;
			else if EPA.new_value.ptr = null ()
			then do;
				EPA.new_value.ptr = ap;
				EPA.new_value.length = al;
			     end;
			else do;
				call com_err_ (error_table_$too_many_args, me,
				     "Usage: edit_proj Project ^a old_value {new_value} {-control_args}.",
				     PROJ_KEY_NAMES (EPA.value_index));
				go to return;
			     end;
		     else /* not matching form */
			if EPA.new_value.ptr = null ()
		     then do;
			     EPA.new_value.ptr = ap;
			     EPA.new_value.length = al;
			end;
		     else do;
			     call com_err_ (error_table_$too_many_args, me,
				"Usage: edit_proj Project ^a {new_value} {-control_args}.",
				PROJ_KEY_NAMES (EPA.value_index));
			     go to return;
			end;
		end;
	     else if argument = "-long" | argument = "-lg"
	     then EPA.long = "1"b;
	     else if argument = "-brief" | argument = "-bf"
	     then EPA.long = "0"b;
	     else if argument = "-debug"
	     then debug_switch = "1"b;
	     else do;
		     call com_err_ (error_table_$badopt, me, """^a"".", argument);
		     go to return;
		end;
	end;

	if project_name = ""			/* cannot abide without that */
	then go to USAGE;

	mgtp, sadp, pp, qp, satp = null ();
	dir_priv_code = -1;				/* priv disabled */
	on cleanup call cleanup_segments;		/* and priv */
	on sub_error_ call sub_error_handler;

	call initiate_segments;			/* and other misc setup */
	EPA.mgtp = mgtp;				/* use the version we found */

/**** Now, look for the specified project */

	do satx = 1 to sat.current_size;
	     satep = addr (sat.project (satx));
	     if project.state = 1
	     then if project.project_id = project_name
		then go to GOT_PROJECT;
	end;

	call com_err_ (error_table_$noentry, me, "Project ""^a"" not defined in SAT.", project_name);
	call cleanup_segments;
	go to return;

GOT_PROJECT:
	Nsate = project;				/* Now we have temporary copy */

/**** However, we have to turn up the matching reqfile and projfile entries */

	call find_and_copy_other_tables (project_name, reqfile_index, projfile_index, error);

	if error
	then do;					/* message already printed */
		call cleanup_segments;
		go to return;
	     end;

	if EPA.value_index = -1
	then EPA.all = "1"b;			/* all of them */

	EPA.satep = addr (Nsate);
	EPA.projfile_ep = addr (Nprojfile);
	EPA.reqfile_ep = addr (Nreqfile);

/**** At this point, EPA is completely filled in. */

	if ^EPA.all
	then call edit_proj_$check (addr (EPA));
	call edit_one_project (("0"b));		/* ignore changed flag */
	if EPA.match
	then if ^EPA.changes.anything
	     then call com_err_ (0, me, "No match for ^a ^a.", PROJ_KEY_NAMES (EPA.value_index), match_value_string);

	call cleanup_segments;
	return;


change_all:
     entry options (variable);

/**** edit_proj$change_all keyword new_value {-long}
      edit_proj$change_all match_keyword old_value new_value {-long}
*/

	me = "edit_proj$change_all";
	call command_setup;
	EPA.brief_match = "1"b;			/* never complain about this in the all case, very few will match */
	EPA.report_project_name = "1"b;

	if arg_count < 2
	then
CA_USAGE:
	     do;
		call com_err_ (0, me, "Usage: new_prog$change_all Keyword {old_value} {new_value} {-long}");
		go to return;
	     end;

	change_all_match_all = "0"b;
	do argx = 1 to arg_count;
	     call cu_$arg_ptr (argx, ap, al, (0));
	     if index (argument, "-") ^= 1
	     then do;				/* non-control */
		     if EPA.value_index = -1
		     then call lookup_keyword ();
		     else if EPA.match_value.ptr = null ()
		     then do;
			     EPA.match = "1"b;
			     EPA.match_value.ptr = ap;
			     EPA.match_value.length = al;
			end;
		     else if EPA.new_value.ptr = null ()
		     then do;
			     EPA.new_value.ptr = ap;
			     EPA.new_value.length = al;
			end;
		     else do;
			     call com_err_ (error_table_$too_many_args, me,
				"Usage: edit_proj$change_all ^a {old_value} {new_value} {-control_args}.",
				PROJ_KEY_NAMES (EPA.value_index));
			     go to return;
			end;
		end;
	     else if argument = "-all"
	     then change_all_match_all = "1"b;
	     else if argument = "-long" | argument = "-lg"
	     then EPA.long = "1"b;
	     else if argument = "-brief" | argument = "-bf"
	     then EPA.long = "0"b;
	     else if argument = "-debug"
	     then debug_switch = "1"b;
	     else do;
		     call com_err_ (error_table_$badopt, me, """^a"".", argument);
		     go to return;
		end;
	end;

	if EPA.value_index = -1			/* Must know what keyword */
	then go to CA_USAGE;

	if change_all_match_all
	then do;
		if EPA.new_value.ptr ^= null ()
		then do;
			call com_err_ (0, me,
			     "-all may not be specified with a match value, since it matches all values of the field."
			     );
			go to return;
		     end;
		EPA.new_value.ptr = EPA.match_value.ptr;
		EPA.new_value.length = EPA.match_value.length;
		EPA.match_value.ptr = null ();
		EPA.match_value.length = 0;
		EPA.match = "0"b;			/* no match required, just do it. */
	     end;

	if ^EPA.match & EPA.new_value.ptr ^= null ()	/* set all, unconditionally? */
	then do;
		call command_query_$yes_no (error, 0, me,
		     "If you answer ""yes"" to this query, ALL PROJECT will be changed.",
		     "Do you wish to change the ^a field of ALL projects on the system to ""^a""?",
		     PROJ_KEY_NAMES (EPA.value_index), new_value_string);
		if ^error
		then go to return;
	     end;

/**** Okay, we have arguments (we have arguments, earther.) */
/**** However, we want to validate the new value BEFORE we go tearing
   off through the SAT. */

	call edit_proj_$check (addr (EPA));		/* signals sub_error_ if it is displeasing */

/**** We have a valid new value and match, to the extent that we know how. */
/**** Now to loop through the SAT (with the greatest of ease.) */

	sadp, pp, qp, satp = null ();
	dir_priv_code = -1;				/* priv disabled */
	on cleanup call cleanup_segments;		/* and priv */
	on sub_error_ call sub_error_handler;

	call initiate_segments;			/* assuming, of course, that the crucial goodies are to be had. */

	changed_count = 0;
	do satx = 1 to sat.current_size;
	     satep = addr (sat.project (satx));
	     if project.state = 1			/* in business? */
	     then do;
		     Nsate = project;
		     project_name = Nsate.project_id;
		     call find_and_copy_other_tables (project_name, reqfile_index, projfile_index, error);
		     if ^error
		     then do;
			     EPA.changes = "0"b;	/* expunge leftovers */
			     EPA.satep = addr (Nsate);
			     EPA.projfile_ep = addr (Nprojfile);
			     EPA.reqfile_ep = addr (Nreqfile);
			     call edit_one_project (changed);
						/* do the work */
			     if changed
			     then changed_count = changed_count + 1;
			end;
		end;				/* all done! */
	end;

	if changed_count = 0
	then call ioa_ ("^a: No projects were changed.", me);
	else call ioa_ ("^a: ^d projects changed.", me, changed_count);
	call cleanup_segments;
	return;


edit_one_project:
     procedure (changed);

	declare changed		 bit (1) aligned;

/**** call edit_proj_ to do make changes in N*.
      It leaves us notes when things change that require FS adjustments. */

	changed = "0"b;
	call edit_proj_ (addr (EPA));			/* no errors save sub errors */
	if ^EPA.changes.anything
	then return;				/* dull! */

	changed = "1"b;

	if EPA.changes.acls
	then call CHANGE_ACLS;
	if EPA.changes.alias & Nsate.alias ^= ""  /* If null then alias deleted from SAT */
	then call CHANGE_ALIAS;
	if EPA.changes.seg_quota
	then call CHANGE_SEG_QUOTA;
	if EPA.changes.dir_quota
	then call CHANGE_DIR_QUOTA;

	project = Nsate;				/* ZOOM */
	projfile.projfiletab (projfile_index) = Nprojfile;
	reqfile.reqfiletab (reqfile_index) = Nreqfile;
	return;
%page;
CHANGE_ACLS:
     procedure;

	declare delete_me		 (4) char (32);
	declare add_me		 (4) char (32);
	declare add_idx		 fixed bin;
	declare delete_idx		 fixed bin;
	declare oldx		 fixed bin;
	declare newx		 fixed bin;
	declare x			 fixed bin;
	declare 1 seg_acl_array	 (4) aligned like segment_acl_entry;
	declare 1 dir_acl_array	 (4) aligned like directory_acl_entry;
	declare 1 dl_acl_array	 (4) aligned like delete_acl_entry;

	delete_me (*) = project.admin (*).userid;
	add_me (*) = Nsate.admin (*).userid;
	do oldx = 1 to 4;
	     if delete_me (oldx) ^= ""
	     then do newx = 1 to 4;
		     if delete_me (oldx) = add_me (newx)
		     then delete_me (oldx), add_me (newx) = "";
		end;
	end;

/**** Now, delete_me is a possibly sparse array of entries to remove,
      and add_me is a possibly sparse array of entries to add. */

	delete_idx, add_idx = 0;

	do x = 1 to 4;
	     if delete_me (x) ^= ""
	     then do;
		     delete_idx = delete_idx + 1;
		     dl_acl_array (delete_idx).access_name = rtrim (delete_me (x)) || ".*";
		     dl_acl_array (delete_idx).status_code = 0;
		end;
	     if add_me (x) ^= ""
	     then do;
		     add_idx = add_idx + 1;
		     seg_acl_array (add_idx).access_name, dir_acl_array (add_idx).access_name =
			rtrim (add_me (x)) || ".*";
		     seg_acl_array (add_idx).mode = R_ACCESS;
						/* >sc1>pdt>PDT */
		     seg_acl_array (add_idx).extended_mode = ""b;
		     dir_acl_array (add_idx).mode = SMA_ACCESS;
						/* project dir */
		     seg_acl_array (add_idx).status_code, dir_acl_array (add_idx).status_code = 0;
		end;
	end;

/**** Now, we know we have something to do, and we have the arrays */

	if add_idx = 0 & delete_idx = 0
	then return;				/* nothing to do */

	call SET_DIR_PRIVILEGE_AS_NEEDED;

	if delete_idx > 0
	then do;
		call hcs_$delete_acl_entries (sc1_pdt, rtrim (Nsate.project_id) || ".pdt", addr (dl_acl_array),
		     delete_idx, code);
		if code ^= 0
		then call com_err_ (code, me,
			"Warning: Could not delete acl entries for removed administrators from ^a>^a.pdt", sc1_pdt,
			Nsate.project_id);
		call hcs_$delete_dir_acl_entries (udd, (Nsate.project_id), addr (dl_acl_array), delete_idx, code);
		if code ^= 0
		then call com_err_ (code, me,
			"Warning: Could not delete acl entries for removed administrators from ^a>^a.", udd,
			Nsate.project_id);
		call hcs_$delete_dir_inacl_entries (udd, (Nsate.project_id), addr (dl_acl_array), delete_idx,
		     USER_RING, code);
		if code ^= 0
		then call com_err_ (code, me,
			"Warning: Could not delete initial acl entries for removed administrators from ^a>^a.", udd,
			Nsate.project_id);
	     end;

	if add_idx > 0
	then do;
		call hcs_$add_acl_entries (sc1_pdt, rtrim (Nsate.project_id) || ".pdt", addr (seg_acl_array), add_idx,
		     code);
		if code ^= 0
		then call com_err_ (code, me,
			"Warning: Could not add acl entries for added administrators to ^a>^a.pdt", sc1_pdt,
			Nsate.project_id);
		call hcs_$add_dir_inacl_entries (udd, (Nsate.project_id), addr (dir_acl_array), add_idx, USER_RING,
		     code);
		if code ^= 0
		then call com_err_ (code, me,
			"Warning: Could not add initial acl entries for added administrators to ^a>^a.", udd,
			Nsate.project_id);
		call hcs_$add_dir_acl_entries (udd, (Nsate.project_id), addr (dir_acl_array), add_idx, code);
		if code ^= 0
		then call com_err_ (code, me, "Warning: Could not add acl entries for added administrators to ^a>^a.",
			udd, Nsate.project_id);

		dir_acl_array (*).mode = A_ACCESS;	/* prepare to fool with >sc1>update */
		call hcs_$add_dir_acl_entries (sc1, "update", addr (dir_acl_array), add_idx, code);
		if code ^= 0
		then call com_err_ (code, me,
			"Warning: Could not add append access to ^a>update for added administrators.", sc1);
		return;
	     end;
     end CHANGE_ACLS;

CHANGE_ALIAS:
     procedure;

/* Fix the alias if it changed. */
	
	call SET_DIR_PRIVILEGE_AS_NEEDED;

	call hcs_$chname_file (udd, (Nsate.project_id), "", (Nsate.alias), code);
						/* don't remove old one, people may be used to it! */
	if code ^= 0
	then call com_err_ (code, me, "Warning: Could not add new name ^a to ^a>^a.", Nsate.alias, udd,
		Nsate.project_id);

	return;
     end CHANGE_ALIAS;


CHANGE_SEG_QUOTA:
     procedure;

	declare 1 SL		 aligned like status_branch;
	declare q_delta		 fixed bin (18);

	q_delta = Nprojfile.disk_quota - projfile.projfiletab (projfile_index).disk_quota;

	call hcs_$status_long (udd, (Nsate.project_id), (1), addr (SL), null (), code);
	if code ^= 0
	then do;
		call com_err_ (code, me, "Warning: Could not retrieve LVID of ^a>^a. Segment quota not changed.", udd,
		     Nsate.project_id);
		return;
	     end;

	call SET_DIR_PRIVILEGE_AS_NEEDED;

	if SL.mdir_switch
	then call mdc_$set_mdir_quota (udd, (Nsate.project_id), "1"b, q_delta, code);
	else call hcs_$quota_move (udd, (Nsate.project_id), q_delta, code);
	if code ^= 0
	then call com_err_ (code, me, "Warning: could not move segment quota ^d for ^a>^a", q_delta, udd,
		Nsate.project_id);
	return;
     end CHANGE_SEG_QUOTA;



CHANGE_DIR_QUOTA:
     procedure;

	declare q_delta		 fixed bin (18);

	q_delta = Nprojfile.dir_disk_quota - projfile.projfiletab (projfile_index).dir_disk_quota;

	call SET_DIR_PRIVILEGE_AS_NEEDED;

	call hcs_$dir_quota_move (udd, (Nsate.project_id), q_delta, code);
	if code ^= 0
	then call com_err_ (code, me, "Warning: could not move directory quota ^d for ^a>^a", q_delta, udd,
		Nsate.project_id);
	return;
     end CHANGE_DIR_QUOTA;
     end edit_one_project;


test:
     entry (asc1, audd);
	dcl     (asc1, audd)	 char (*);

	call absolute_pathname_ (asc1, sc1, (0));
	call absolute_pathname_ (audd, udd, (0));

	sc1_pdt = rtrim (sc1) || ">pdt";
	call ioa_ ("sc1 = ^a, udd = ^a.", sc1, udd);
	return;


SET_DIR_PRIVILEGE_AS_NEEDED:
     procedure;

	declare udd_acc		 bit (72) aligned;
	declare pj_acc		 bit (72) aligned;
	declare uddd		 char (168);
	declare udde		 char (32);

	if dir_priv_code = 0
	then return;				/* already on */
	call expand_pathname_ (udd, uddd, udde, code);
	if code ^= 0
	then call sub_err_ (code, me, ACTION_CANT_RESTART, null (), (0), "Could not expand pathname of ^a.", udd);
	call hcs_$get_access_class (uddd, udde, udd_acc, code);
	if code ^= 0
	then call sub_err_ (code, me, ACTION_CANT_RESTART, null (), (0), "Could not get access class of ^a.", udd);
	call hcs_$get_access_class (udd, (Nsate.project_id), pj_acc, code);
	if code ^= 0
	then call sub_err_ (code, me, ACTION_CANT_RESTART, null (), (0), "Could not get access class of ^a>^a.", udd,
		Nsate.project_id);
	if ^aim_check_$greater (pj_acc, udd_acc)
	then return;
	call system_privilege_$dir_priv_on (dir_priv_code);
						/* atomic over code setting */
	return;
     end SET_DIR_PRIVILEGE_AS_NEEDED;

command_setup:
     procedure;					/* has to be quick ... */

	unspec (EPA) = ""b;
	edit_proj_arg_ptr = addr (EPA);
	EPA.seg_pointers = null ();
	EPA.new_value.ptr = null ();
	EPA.match_value.ptr = null ();
	EPA.value_index = -1;
	EPA.version = EDIT_PROJ_ARGS_V_2;
	EPA.caller = me;

	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, me);
		go to return;
	     end;
	return;
     end command_setup;

lookup_keyword:
     procedure;
	declare kx		 fixed bin;

	do kx = 1 to hbound (PROJ_KEY_NAMES, 1);
	     if argument = PROJ_KEY_NAMES (kx)
	     then do;
		     EPA.value_index = PROJ_KEY_VALUES (kx);
		     return;
		end;
	end;

	call com_err_ (0, me, "Invalid keyword ""^a"".", argument);
	go to return;
     end lookup_keyword;

matching_keyword:
     procedure returns (bit (1) aligned);

	declare kx		 fixed bin;

	do kx = 1 to hbound (PROJ_KEYS_MATCH, 1);
	     if EPA.value_index = PROJ_KEYS_MATCH (kx)
	     then return ("1"b);
	end;
	return ("0"b);
     end matching_keyword;

sub_error_handler:
     procedure;

	declare 1 CI		 aligned like condition_info;
	if debug_switch
	then call continue_to_signal_ ((0));
	else do;
		CI.version = condition_info_version_1;
		call find_condition_info_ (null (), addr (CI), (0));
		sub_error_info_ptr = CI.info_ptr;
		call com_err_ (sub_error_info.status_code, me, "^a", sub_error_info.info_string);
		go to ERROR_EXIT;
	     end;
     end sub_error_handler;

initiate_segments:
     procedure;

	declare dn		 char (168);
	declare en		 char (32);

	dn = get_wdir_ ();
	en = "sys_admin_data";
	call initiate_file_ (dn, en, R_ACCESS, sadp, (0), code);
	if code ^= 0
	then go to segment_error;
	call set_lock_$lock (sys_admin_data.lock, 60, code);
	if code ^= 0
	then if code = error_table_$locked_by_this_process
	     then mylock = "1"b;
	     else if code ^= error_table_$invalid_lock_reset
	     then do;
		     call com_err_ (code, "edit_proj", "Sys_admin_data is locked by ^a", sys_admin_data.locker);
		     call terminate_file_ (sadp, (0), TERM_FILE_TERM, (0));
		     go to return;
		end;

	uid = get_group_id_ ();

	en = "smf.cur.sat";
	call initiate_file_ (dn, en, RW_ACCESS, satp, (0), code);
	if code ^= 0
	then go to segment_error;

	en = "projfile";
	call initiate_file_ (dn, en, RW_ACCESS, pp, (0), code);
	if code ^= 0
	then go to segment_error;
	en = "reqfile";
	call initiate_file_ (dn, en, RW_ACCESS, qp, (0), code);
	if code ^= 0
	then go to segment_error;
	dn = sc1;
	en = "mgt";
	call initiate_file_ (dn, en, R_ACCESS, mgtp, (0), code);
	if code ^= 0
	then go to segment_error;
	return;

segment_error:
	call com_err_ (code, "edit_proj", "^a>^a", dn, en);
	call cleanup_segments;
	go to return;
     end initiate_segments;


find_and_copy_other_tables:
     procedure (project_name, reqfile_index, projfile_index, error);

	declare error		 bit (1) aligned;
	declare project_name	 char (*);
	declare reqfile_index	 fixed bin;
	declare projfile_index	 fixed bin;
	declare tx		 fixed bin;

	error = "0"b;
	reqfile_index, projfile_index = -1;

	do tx = 1 to reqfile.nacts while (project_name ^= reqfile.acctid (tx));
	end;
	if tx > reqfile.nacts
	then do;
		call com_err_ (0, me, "Project ^a not in reqfile.", project_name);
		error = "1"b;
		return;
	     end;
	if reqfile.qdf (tx) ^= 0
	then call ioa_ ("^a: Warning: Project ""^a"" deleted from reqfile.", me, project_name);

	reqfile_index = tx;
	Nreqfile = reqfile.reqfiletab (tx);

	do tx = 1 to projfile.nproj while (project_name ^= projfile.id (tx));
	end;
	if tx > projfile.nproj
	then do;
		call com_err_ (0, me, "Project ""^a"" is not in projfile.", project_name);
		error = "1"b;
		return;
	     end;
	if projfile.off (tx) ^= 0
	then call ioa_ ("^a: Warning: project ""^a"" deleted from projfile.", me, project_name);
	Nprojfile = projfile.projfiletab (tx);
	projfile_index = tx;
	return;
     end find_and_copy_other_tables;

cleanup_segments:
     procedure;

	if dir_priv_code = 0
	then call system_privilege_$dir_priv_off (code);
	if pp ^= null ()
	then call terminate_file_ (pp, 36 * (loph + projfile.nproj * lope), TERM_FILE_TRUNC_BC_TERM, (0));
	if qp ^= null ()
	then call terminate_file_ (qp, 36 * (loqh + reqfile.nacts * loqe), TERM_FILE_TRUNC_BC_TERM, (0));
	if satp ^= null ()
	then call terminate_file_ (satp, 36 * (SAT_header_lth + sat.current_size * SAT_entry_lth),
		TERM_FILE_TRUNC_BC_TERM, (0));
	if sadp ^= null ()
	then do;
		if ^mylock
		then call set_lock_$unlock (sys_admin_data.lock, code);
		call terminate_file_ (sadp, (0), TERM_FILE_TERM, (0));
	     end;
	if mgtp ^= null ()
	then call terminate_file_ (mgtp, 0, TERM_FILE_TERM, (0));

     end cleanup_segments;

ERROR_EXIT:
	call cleanup_segments;
	return;

return:
	return;

     end edit_proj;




		    edit_proj_.pl1                  10/21/92  1138.8rew 10/21/92  1137.3      362151



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




/****^  HISTORY COMMENTS:
  1) change(86-04-23,Martinson), approve(86-04-23,MCR7363),
     audit(86-04-30,GDixon), install(86-05-01,MR12.0-1050):
     Fix transfer request to work again when changing requisition or account
     number.
  2) change(92-09-23,Zimmerman), approve(92-09-23,MCR8268), audit(92-10-13,Vu),
     install(92-10-21,MR12.5-1034):
     edit_proj changed to allow deletion of project alias from SAT (phx21304)
                                                   END HISTORY COMMENTS */


/* format: style2 */
edit_proj_:
     procedure (EPA_ptr);

/* Written by T. H. VanVleck in 1973
   Modified June 1975 by T. Casey to add groups
   Modified August 1977 by T. Casey to add min_ring and max_ring
   Modified May 1978 by T. Casey to add pdir_quota.
   Modified November 1978 by T. Casey for MR7.0 to add new absentee control parameters.
   Modified July 1979 by J. Bakal to implement the multiple rate structure feature.
   Modified November 1979 by T. Casey to implement -long and change the default to not -long.
   Modified Feb 1980 by M. B. Armstrong to make corrections re rate structures.
   Modified June 1980 by J. N. R. Barnecut to integrate multiple rate structure feature into MR8.0
   Modified April 1980 by J. N. R. Barnecut to allow reset when changing requistion number or account number.
   Modified 1984-07-05 BIM to clean up, ready for B2 new fields.
   Modified 1984-09-14 BIM for bugs in group handling.
   Modified 1984-10-24 by E. Swenson to allow attributes to be set properly.
   Modified 1984-12-14 by EJ Sharpe for new audit flags
   Modified 1985-04-19 by EJ Sharpe to fix checking to always return, report
	project name before prompting for changes, support matching for
	project supervisor, fix out-of-bounds error
*/
	dcl     code		 fixed bin (35);
	dcl     printed_projname	 bit (1) aligned;
	dcl     rs_name		 char (32);
	dcl     rs_number		 fixed bin;
	dcl     (set_attr, reset_attr) bit (36);


	dcl     midnight		 fixed bin (71);
	dcl     (i, j)		 fixed bin;
	dcl     (vstr, vstr2)	 char (200) varying;
	dcl     char_16		 char (16);
	dcl     char_32		 char (32);
	dcl     (char_100, char_100_2) char (100);
	dcl     (char_500, char_500_2) char (500);
	dcl     sign		 char (1);
	dcl     fb71		 fixed bin (71);
	dcl     ftemp		 float bin;
	dcl     temp_aim_range	 (2) bit (72) aligned;
	dcl     temp_audit		 bit (36) aligned;

	dcl     (pp, qp)		 pointer;		/* use in include files */
	dcl     mgtp		 pointer;
	dcl     (Nsatep, Nprojfile_p, Nreqfile_p)
				 pointer;
	dcl     EPA_ptr		 pointer;		/* paramter */

	declare error_table_$bad_conversion
				 fixed bin (35) ext static;

	dcl     (satp, satep)	 ptr;		/* hush */

	dcl     1 Nsate		 aligned like project based (Nsatep);

	dcl     1 Nprojfile		 aligned like projfile.projfiletab based (Nprojfile_p);
	dcl     1 Nreqfile		 aligned like reqfiletab based (Nreqfile_p);
	dcl     1 temp_attr		 unaligned like user_attributes;

	dcl     LEGAL		 char (70) int static options (constant)
				 init
				 /* Legal chars */ (
				 "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'_`^~/-abcdefghijklmnopqrstuvwxyz");

	dcl     (addr, after, before, char, hbound, length, ltrim, null, rtrim, string, substr, unspec, verify)
				 builtin;


/* Entries */

	dcl     com_err_		 entry () options (variable);
	dcl     command_query_	 entry () options (variable);
	dcl     command_query_$yes_no	 entry () options (variable);
	dcl     convert_date_to_binary_
				 entry (char (*), fixed bin (71), fixed bin (35));
	dcl     convert_date_to_binary_$relative
				 entry (character (*), fixed binary (71), fixed binary (71), fixed binary (35));
	dcl     convert_access_class_$to_string_range_short
				 entry ((2) bit (72) aligned, character (*), fixed binary (35));
	dcl     convert_access_class_$from_string_range
				 entry ((2) bit (72) aligned, character (*), fixed binary (35));
	dcl     convert_access_class_$to_string_range
				 entry ((2) bit (72) aligned, character (*), fixed binary (35));
	dcl     convert_access_audit_flags_$to_string
				 entry (bit (36) aligned, character (*), fixed binary (35));
	dcl     convert_access_audit_flags_$from_string
				 entry (character (*), bit (36) aligned, fixed binary (35));
	dcl     convert_access_audit_flags_$edit_from_string
				 entry (character (*), bit (36) aligned, fixed binary (35));
	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cv_float_		 entry (character (*), fixed binary (35)) returns (float binary (27));
	dcl     cv_dec_check_	 entry (character (*), fixed binary (35)) returns (fixed binary (35));
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     datebin_$last_midnight entry (fixed binary (71));
	dcl     format_attributes_	 entry (ptr, char (*) var);
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     ioa_$general_rs	 entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21),
				 bit (1) aligned, bit (1) aligned);
	dcl     parse_attributes_	 entry (character (*), bit (36), bit (36), fixed binary (35));

	dcl     system_info_$rs_number entry (char (*), fixed bin, fixed bin (35));
	dcl     system_info_$rs_name	 entry (fixed bin, char (*), fixed bin (35));
	dcl     sub_err_		 entry () options (variable);

%include query_info;
%include sub_err_flags;
%include edit_proj_arguments_;
%include edit_proj_keywords_;
%include user_attributes;
%include sat;
%include projfile;
%include reqfile;
%include mgt;


	code = 0;
	printed_projname = "0"b;

	edit_proj_arg_ptr = EPA_ptr;
	Nsatep = edit_proj_arg.satep;
	Nprojfile_p = edit_proj_arg.projfile_ep;
	Nreqfile_p = edit_proj_arg.reqfile_ep;
	mgtp = edit_proj_arg.mgtp;

	if edit_proj_arg.all
	then call process_all_items ();
	else call process_one_item (edit_proj_arg.value_index, "0"b);
						/* Don't perform a check, really make the change */
	return;

check:
     entry (EPA_ptr);
	edit_proj_arg_ptr = EPA_ptr;
	Nsatep = edit_proj_arg.satep;
	Nprojfile_p = edit_proj_arg.projfile_ep;
	Nreqfile_p = edit_proj_arg.reqfile_ep;
	mgtp = edit_proj_arg.mgtp;
	call process_one_item (edit_proj_arg.value_index, "1"b);
	return;


process_all_items:
     procedure;

	declare x			 fixed bin;
	declare again		 bit (1) aligned;

	again = "1"b;
	do while (again);
	     do x = 1 to hbound (PROJ_KEY_ALL_ORDER, 1);
		call process_one_item (PROJ_KEY_ALL_ORDER (x), "0"b);
	     end;
	     call command_query_$yes_no (again, (0), edit_proj_arg.caller, "", "Do you wish to review the project?");
	end;

	return;
     end process_all_items;



process_one_item:
     procedure (Value_index, check);			/* uses EPA for other data */

	declare Value_index		 fixed bin;
	declare check		 bit (1) aligned;
	declare new		 bit (1) aligned;

/**** check can only be on if there is a match or new_value to check */

	new = edit_proj_arg.new_value.ptr ^= null ();
	go to item (Value_index);


/**** Title */
item (1):
	call simple_string ("Title", Nprojfile.title);
	return;

/**** Investigator */
item (2):
	call simple_string ("Investigator", Nprojfile.inv);
	return;

/**** inv Address */
item (3):
	call simple_string ("Inv. Address", Nprojfile.inv_addr);
	return;

/**** Supervisor */
item (4):
	if check
	then return;
	char_100 = Nprojfile.sup;
	if edit_proj_arg.match
	then if match_value_string ^= char_100
	     then call no_match;
	call get_string ("Supervisor", Nprojfile.sup);
	if Nprojfile.sup = "="
	then do;
		Nprojfile.sup = Nprojfile.inv;
		Nprojfile.sup_addr = Nprojfile.inv_addr;
	     end;
	if char_100 ^= Nprojfile.sup
	then do;
		call long_report ("""^a"" to ""^a""", char_100, Nprojfile.sup);
		edit_proj_arg.changes.anything = "1"b;
	     end;
	return;

/**** Supervisor addr */
item (5):
	if check
	then return;
	if edit_proj_arg.all			/* minor non-modularity */
	then if Nprojfile.sup = Nprojfile.inv
	     then return;				/* Let the = to (4) do the work */

	char_100 = Nprojfile.sup_addr;
	if edit_proj_arg.match
	then if match_value_string ^= char_100
	     then call no_match;
	call get_string ("Sup. Address", Nprojfile.sup_addr);
	if Nprojfile.sup_addr = "="
	then Nprojfile.sup_addr = Nprojfile.inv_addr;
	if char_100 ^= Nprojfile.sup_addr
	then do;
		call long_report ("""^a"" to ""^a""", char_100, Nprojfile.sup_addr);
		edit_proj_arg.changes.anything = "1"b;
	     end;
	return;

/**** Supervisor phone */
item (6):
	call simple_string (" Phone", Nprojfile.sup_phone);
	return;

/**** Account */
item (7):
	if check
	then return;				/* nothing is invalid */
	char_16 = Nreqfile.mitacct;			/* save the old req */
	if edit_proj_arg.match
	then if match_value_string ^= char_16
	     then call no_match;

	/*** get_string will retrieve the value from EPA if available */
	call get_string ("Account", char_16);		/* get the new one, dont set changed  */
	if char_16 ^= Nreqfile.mitacct
	then call change_account (char_16);		/* switch */
	return;

/**** Requisition */
item (8):
	if check
	then return;
	char_16 = Nreqfile.reqno;
	if edit_proj_arg.match
	then if match_value_string ^= char_16
	     then call no_match;
	call get_string ("Requisition", char_16);
	if char_16 ^= Nreqfile.reqno
	then call change_requisition (char_16);
	return;

/**** Amount */
item (9):
	if check
	then do;
		if edit_proj_arg.match
		then call sub_err_ (error_table_$bad_conversion, edit_proj_arg.caller, ACTION_CANT_RESTART, null (),
			(0), "Matching on the value of Amount is not possible.");
		if new
		then do;
			ftemp = cv_float_ (new_value_string, code);
			if code ^= 0
			then call sub_err_ (error_table_$bad_conversion, edit_proj_arg.caller, ACTION_CANT_RESTART,
				null (), (0), """^a"" is not a valid requisition amount.", new_value_string);
		     end;
		return;
	     end;


	char_16 = "";
	sign = "r";
	if Nreqfile.req_amt = 0e0
	then char_16 = "open";
	else call ioa_$rsnnl ("^.2f", char_16, (0), Nreqfile.req_amt);
	call get_string ("Amount", char_16);
	if char_16 = "open"
	then ftemp = 0;
	else do;
		if substr (char_16, 1, 1) = "+" | substr (char_16, 1, 1) = "-"
		then sign = substr (char_16, 1, 1);

		ftemp = cv_float_ ((char_16), code);
		if code ^= 0
		then do;
			call com_err_ (error_table_$bad_conversion, edit_proj_arg.caller,
			     "Invalid specification of amount ""^a""", char_16);
			go to item (9);
		     end;

		if sign ^= "r"
		then ftemp = Nreqfile.req_amt + ftemp;

		if ftemp = 0e0
		then do;
			call com_err_ (0, edit_proj_arg.caller,
			     "Setting an Amount of zero will not cut the project off. Say ""open"" to give the project an open requisition, or set the cutoff date to cut it off."
			     );
			go to item (9);
		     end;
	     end;
	if ftemp ^= Nreqfile.req_amt
	then do;
		Nsate.cutoff = " ";			/* Reset this. */
		edit_proj_arg.changes.anything = "1"b;
		call long_report ("^[open^s^;^.2f^] to ^[open^;^.2f^]", Nreqfile.req_amt = 0e0, Nreqfile.req_amt,
		     ftemp = 0e0, ftemp);
		Nreqfile.req_amt = ftemp;
	     end;
	return;

/**** Cutoff date */
item (10):
	if check
	then do;
		if edit_proj_arg.match
		then do;
			call convert_date_to_binary_ (match_value_string, (0), code);
			if code ^= 0
			then call sub_err_ (code, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"""^a"" is not a valid cutoff date.", match_value_string);
		     end;
		if new
		then do;
			call convert_date_to_binary_ (new_value_string, (0), code);
			if code ^= 0
			then call sub_err_ (code, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"""^a"" is not a valid cutoff date.", new_value_string);
		     end;
		return;
	     end;

	if edit_proj_arg.match
	then do;
		call convert_date_to_binary_ (match_value_string, fb71, (0));
		if fb71 ^= Nreqfile.cutoff
		then call no_match;
	     end;

	call datebin_$last_midnight (midnight);

RE_GET_CUTOFF:
	call date_time_ (Nreqfile.cutoff, char_100_2);
	char_100 = char_100_2;
	call get_string ("Cutoff date", char_100);
	call convert_date_to_binary_$relative ((char_100), fb71, midnight, code);
	if code ^= 0
	then do;
		call com_err_ (code, edit_proj_arg.caller, "Cutoff date ""^a"". ", char_100);
		go to item (10);
	     end;

	if fb71 ^= Nreqfile.cutoff
	then do;
		call date_time_ (fb71, char_100);
		call long_report ("^a to ^a", char_100_2, char_100);
		Nreqfile.cutoff = fb71;
		Nsate.cutoff = " ";
		edit_proj_arg.changes.anything = "1"b;
	     end;
	return;

/**** Billing name */
item (11):
	call simple_string ("Billing name", Nreqfile.billing_name);
	return;

/**** Billing address */
item (12):
	call simple_string ("Billing Address", Nreqfile.billing_addr);
	return;

/**** Rate structure */
item (26):
	if check
	then do;
		if edit_proj_arg.match
		then do;
			call system_info_$rs_number (match_value_string, (0), code);
			if code ^= 0
			then call sub_err_ (code, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"""^a"" is not a valid rate structure.", match_value_string);
		     end;
		if new
		then do;
			call system_info_$rs_number (new_value_string, (0), code);
			if code ^= 0
			then call sub_err_ (code, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"""^a"" is not a valid rate structure.", new_value_string);
		     end;
		return;
	     end;

	call system_info_$rs_name ((Nsate.rs_number), rs_name, (0));
	if edit_proj_arg.match
	then if match_value_string ^= rs_name
	     then call no_match;

RS_LOOP:
	char_32 = rs_name;
	call get_string ("Rate structure", char_32);
	if char_32 = ""
	then return;				/* no change requested */

	call system_info_$rs_number ((char_32), rs_number, code);
	if code ^= 0
	then do;
		call com_err_ (code, edit_proj_arg.caller, "Invalid rate structure name: ""^a""", char_32);
		go to RS_LOOP;
	     end;
	if rs_number ^= Nsate.rs_number
	then do;
		call long_report ("^a to ^a", rs_name, char_32);
		Nsate.rs_number = rs_number;
		edit_proj_arg.changes.anything = "1"b;
	     end;
	return;

/**** (default) Group */
item (13):
	if check
	then do;
		if new
		then if new_value_string ^= ""
		     then do;
			     if ^valid_group (rtrim (new_value_string))
			     then call sub_err_ (0, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				     """^a"" is not a group defined in >sc1>mgt.", new_value_string);
			     if new_value_string = "*"
			     then call sub_err_ (0, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				     """*"" is not valid as a default group.");
			end;
		return;
	     end;

	if edit_proj_arg.match
	then if match_value_string ^= Nsate.group
	     then call no_match;

DEFAULT_GROUP_LOOP:
	char_32 = Nsate.group;
	call get_string ("Default group", char_32);
	if char_32 = ""
	then return;				/* no change */
	if ^valid_group (rtrim (char_32))
	then do;
		call com_err_ (0, edit_proj_arg.caller, """^a"" is not a group defined in >sc1>mgt.", char_32);
		go to DEFAULT_GROUP_LOOP;
	     end;
	if char_32 = "*"
	then do;
		call com_err_ (0, edit_proj_arg.caller, """*"" is not a valid default group.");
		go to DEFAULT_GROUP_LOOP;
	     end;

	Nsate.group = substr (char_32, 1, length (Nsate.group));
	edit_proj_arg.changes.anything = "1"b;
	return;

/**** Attributes  -- parsed into explicitly set/reset */
item (14):
	if check
	then do;
		if edit_proj_arg.match
		then do;
			call parse_attributes_ (match_value_string, (""b), (""b), code);
			if code ^= 0
			then call sub_err_ (code, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"""^a"" is not a valid attribute string.", match_value_string);
		     end;
		if new
		then do;
			call parse_attributes_ (new_value_string, (""b), (""b), code);
			if code ^= 0
			then call sub_err_ (code, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"""^a"" is not a valid attribute string.", new_value_string);
		     end;
		return;
	     end;

/**** What should matching mean for attributes? Any with these on and off
      and no others? sounds reasonable */

	if edit_proj_arg.match
	then do;
		call parse_attributes_ (match_value_string, set_attr, reset_attr, (0));
		temp_attr = Nsate.at;
		temp_attr.pm_ok = ^temp_attr.pm_ok;	/* no_prim instead if prim_ok */
		temp_attr.sb_ok = ^temp_attr.sb_ok;	/* no_sb ... */
		temp_attr.eo_ok = ^temp_attr.eo_ok;	/* no_eo ... */
		if ^(((string (temp_attr) & set_attr) = set_attr) /* all the sets are set */
		     & ((^string (temp_attr) & reset_attr) = reset_attr))
						/* all the resets are off */
		then call no_match;
	     end;

	call format_attributes_ (addr (Nsate.at), vstr);	/* get current set */
ATTR_LOOP:
	char_500 = vstr;				/* always reprompt with old value */
	call get_string ("Attributes", char_500);
	if char_500 = ""
	then return;				/* Yawn */
	call parse_attributes_ ((char_500), set_attr, reset_attr, code);
	if code ^= 0
	then do;
		call com_err_ (code, edit_proj_arg.caller, "Invalid attribute specification ""^a"" .", char_500);
		go to ATTR_LOOP;
	     end;

	if (set_attr | reset_attr) = ""b
	then return;				/* nothing doing */

	temp_attr = Nsate.at;
	temp_attr.pm_ok = ^temp_attr.pm_ok;		/* no_prim instead if prim_ok */
	temp_attr.sb_ok = ^temp_attr.sb_ok;		/* no_sb ... */
	temp_attr.eo_ok = ^temp_attr.eo_ok;		/* no_eo ... */
	string (temp_attr) = (string (temp_attr) | set_attr) & ^reset_attr;
	temp_attr.pm_ok = ^temp_attr.pm_ok;
	temp_attr.sb_ok = ^temp_attr.sb_ok;
	temp_attr.eo_ok = ^temp_attr.eo_ok;
	if string (temp_attr) = string (Nsate.at)
	then return;
	call format_attributes_ (addr (temp_attr), vstr2);
	call long_report ("^a to^/ ^a", vstr, vstr2);
	Nsate.at = temp_attr;
	edit_proj_arg.changes.anything = "1"b;
	return;

/**** (say) Grace */
item (15):
	call sfb17 ("Grace", 0, -1, Nsate.grace_max);
	return;

%page;
/**** Administrators ... */
item (16):
	if check
	then do;
/**** Don't check match value, there might be junk in there */
		if new
		then if new_value_string ^= ""
		     then call check_admin (new_value_string);
		return;
	     end;

	if edit_proj_arg.match
	then do;					/* We are looking for just one */
		do i = 1 to 4;
		     if Nsate.admin (i).userid = match_value_string
		     then go to HAVE_MATCHING_ADMIN;
		end;
		call no_match;

HAVE_MATCHING_ADMIN:
RE_PROMPT_ONE_ADMIN:
		char_32 = Nsate.admin (i).userid;
		call get_string ("Administrator", char_32);
		if char_32 = Nsate.admin (i).userid
		then return;
		if (char_32 = "." | char_32 = "")
		then do;				/* Delete the creature */
			if Nsate.admin (i).userid ^= ""
			then do;			/* unless already gone */
				call long_report_ ("Deleted administrator ""^a""", Nsate.admin (i).userid);
				do j = i to 3;
				     Nsate.admin (i).userid = Nsate.admin (i + 1).userid;
				end;
				Nsate.admin (4).userid = "";
			     end;
		     end;
		else do;				/* its a replacement */
			if ^check_admin_ (char_32)
			then do;
				call com_err_ (0, edit_proj_arg.caller,
				     "Project administrator ""^a"" not of form Name.Project.", char_32);
				go to RE_PROMPT_ONE_ADMIN;
			     end;
			if Nsate.admin (i).userid = ""
			then call long_report_ ("Added administrator ""^a"".", char_32);
			else call long_report ("^a to ^a", Nsate.admin (i).userid, char_32);
			Nsate.admin (i).userid = substr (char_32, 1, length (Nsate.admin (i).userid));
		     end;
		edit_proj_arg.changes.anything, edit_proj_arg.changes.acls = "1"b;
		return;
	     end;					/* dealing with the match */

/**** We wind up here for the vanilla "show me them one by one" case. */
/**** There can be no "new_value" for this unless we were in the 
      match department, upstairs. */

	if edit_proj_arg.report_project_name & ^printed_projname
	then do;
		call ioa_ ("Project ^a:", Nsate.project_id);
		printed_projname = "1"b;		/* once only */
	     end;
	call ioa_ ("Project administrators. Type ""."" to delete.");
	do i = 1 to 4;
	     if i > 1
	     then if Nsate.admin (i - 1).userid = ""
		then go to DONE_ADMIN;
RE_GET_ADMIN:
	     char_32 = Nsate.admin (i).userid;
	     call get_string (" Administrator", char_32);
	     if char_32 = Nsate.admin (i).userid
	     then ;
	     else if char_32 = "."
	     then do;				/* Deleting */
		     if Nsate.admin (i).userid = ""
		     then go to DONE_ADMIN;		/* . to empty slot */
		     call long_report_ ("Deleted administrator ""^a""", Nsate.admin (i).userid);
		     do j = i to 3;
			Nsate.admin (j).userid = Nsate.admin (j + 1).userid;
		     end;
		     Nsate.admin (4).userid = "";
		     i = i - 1;
		     edit_proj_arg.changes.acls, edit_proj_arg.changes.anything = "1"b;
		end;
	     else do;				/* Replacing */
		     if ^check_admin_ (char_32)
		     then do;
			     call com_err_ (0, edit_proj_arg.caller, "Invalid administrator ""^a"" .", char_32);
			     go to RE_GET_ADMIN;
			end;

		     if Nsate.admin (i).userid = ""
		     then call long_report_ ("Added administrator ""^a""", char_32);
		     else call long_report ("""^a"" to ""^a""", Nsate.admin (i).userid, char_32);
		     Nsate.admin (i).userid = substr (char_32, 1, length (Nsate.admin (i).userid));
		     edit_proj_arg.changes.acls, edit_proj_arg.changes.anything = "1"b;
		end;
	end;

DONE_ADMIN:
	return;					/* PHEW */
%page;

/**** Segment quota */
item (17):
	call quota_value ("seg", "Segment quota", Nprojfile.disk_quota);
	return;

/**** Dir quota */
item (27):
	call quota_value ("dir", "Directory quota", Nprojfile.dir_disk_quota);
	return;

/**** Alias */
item (18):
	if check
	then do;
	     call simple_string ("Alias", char_32);
	end;
	else do;
	     char_32 = Nsate.alias;		/* will need this to see if it changed */
	     call ioa_ ("Project Alias: type ""."" to delete current alias from SAT.");
	     call simple_string ("Alias", Nsate.alias);
	     if Nsate.alias ^= char_32
	     then do;
		edit_proj_arg.changes.alias = "1"b;
		if Nsate.alias = "." then Nsate.alias = "";
	     end;
	end;

	return;

%page;
/**** Groups */
item (19):
	if check
	then do;
/**** Don't check match value, it might contain an invalid group */

		if new
		then if new_value_string ^= ""
		     then if ^valid_group (rtrim (new_value_string))
			then call sub_err_ (0, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"""^a"" is not a group defined in >sc1>mgt.", new_value_string);
		return;
	     end;

	if edit_proj_arg.match
	then do;					/* We are looking for just one */
		do i = 1 to 2;
		     if Nsate.groups (i) = match_value_string
		     then go to HAVE_MATCHING_GROUP;
		end;
		return;				/* not one of ours, jack */
HAVE_MATCHING_GROUP:
RE_PROMPT_ONE_GROUP:
		char_32 = Nsate.groups (i);
		call get_string ("Group", char_32);
		if char_32 = Nsate.groups (i)
		then return;
		if char_32 = "." | char_32 = ""
		then do;				/* Delete the creature */
			if Nsate.groups (i) ^= ""
			then do;
				call long_report_ ("Deleted group ^a", Nsate.groups (i));
				if i = 1
				then Nsate.groups (1) = Nsate.groups (2);
				Nsate.groups (2) = "";
				i = i - 1;	/* revisit */
				edit_proj_arg.changes.anything = "1"b;
			     end;
		     end;
		else do;				/* its a replacement */
			if ^valid_group (rtrim (char_32))
			then do;
				call com_err_ (0, edit_proj_arg.caller,
				     """^a"" is not a group defined in >sc1>mgt.", char_32);
				go to RE_PROMPT_ONE_GROUP;
			     end;
			if Nsate.groups (i) = ""
			then call long_report_ ("Added group ""^a""", char_32);
			else call long_report ("""^a"" to ""^a""", Nsate.groups (i), char_32);
			Nsate.groups (i) = substr (char_32, 1, length (Nsate.groups (i)));
			edit_proj_arg.changes.anything = "1"b;
		     end;
		return;
	     end;					/* dealing with the match */

/**** We wind up here for the vanilla "show me them one by one" case. */
/**** There can be no "new_value" for this unless we were in the 
      match department, upstairs. */

	if edit_proj_arg.report_project_name & ^printed_projname
	then do;
		call ioa_ ("Project ^a:", Nsate.project_id);
		printed_projname = "1"b;		/* once only */
	     end;
	call ioa_ ("Authorized groups. Type ""."" to delete.");
	do i = 1 to 2;
	     if i = 2
	     then if Nsate.groups (1) = ""
		then go to DONE_GROUPS;
RE_PROMPT_FOR_VALID_GROUP:
	     char_32 = Nsate.groups (i);
	     call get_string (" Group", char_32);
	     if char_32 = Nsate.groups (i)
	     then ;
	     else if char_32 = "."
	     then do;				/* Deleting */
		     if Nsate.groups (i) = (8)" "
		     then return;
		     call long_report_ ("Deleted group ^a", Nsate.groups (i));
		     if i = 1
		     then Nsate.groups (1) = Nsate.groups (2);
		     Nsate.groups (2) = "";
		     i = i - 1;
		     edit_proj_arg.changes.anything = "1"b;
		end;
	     else do;				/* Replacing */
		     if ^valid_group (rtrim (char_32))
		     then do;
			     call com_err_ (0, edit_proj_arg.caller, """^a"" is not a group defined in >sc1>mgt.",
				char_32);
			     go to RE_PROMPT_FOR_VALID_GROUP;
			end;

		     if Nsate.groups (i) = ""
		     then call long_report_ ("Added group ""^a""", char_32);
		     else call long_report ("""^a"" to ""^a""", Nsate.groups (i), char_32);
		     Nsate.groups (i) = substr (char_32, 1, length (Nsate.groups (i)));
		     edit_proj_arg.changes.anything = "1"b;
		end;
	end;
DONE_GROUPS:
	return;					/* PHEW */
%page;

/**** Min ring */
item (20):
	call sfb17 ("Minimum login ring", 1, 7, Nsate.min_ring);
	return;

/**** Max ring */
item (21):
	call sfb17 ("Maximum login ring", 1, 7, Nsate.max_ring);
	return;

/**** Pdir Quota */
item (22):
	call sfb17u ("Maximum pdir quota", 0, 262143, Nsate.pdir_quota);
	return;


/**** Max FG */
item (23):
	call sfb9uu ("Maximum foreground processes", 0, -1, Nsate.max_foreground);
	return;

/**** Max BG */
item (24):
	call sfb9uu ("Maximum background processes", 0, -1, Nsate.max_background);
	return;

/**** Abs fg cpu limit */
item (25):
	call sfb17u ("Absentee foreground cpu limit", 0, -1, Nsate.abs_foreground_cpu_limit);
	return;

/**** Authorization */
item (28):
	if check
	then do;
		if edit_proj_arg.match
		then do;
			call convert_access_class_$from_string_range (temp_aim_range, match_value_string, code);
			if code ^= 0
			then call sub_err_ (code, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"Invalid authorization range ""^a"" .", match_value_string);
		     end;

		if new
		then do;
			call convert_access_class_$from_string_range (temp_aim_range, new_value_string, code);
			if code ^= 0
			then call sub_err_ (code, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"Invalid authorization range ""^a"" .", new_value_string);
		     end;
		return;
	     end;

	if edit_proj_arg.match
	then do;
		call convert_access_class_$from_string_range (temp_aim_range, match_value_string, (0));
		if unspec (Nsate.project_authorization) ^= unspec (temp_aim_range)
		then call no_match;
	     end;

	call convert_access_class_$to_string_range (Nsate.project_authorization, char_500, (0));
RE_GET_AUTH:
	call get_string ("Authorization", char_500);
	call convert_access_class_$from_string_range (temp_aim_range, char_500, code);
	if code ^= 0
	then do;
		call com_err_ (code, edit_proj_arg.caller, "Invalid AIM authorization range ""^a"" .", char_500);
		go to item (28);
	     end;

	if unspec (Nsate.project_authorization) = unspec (temp_aim_range)
	then return;				/* no change */

	call convert_access_class_$to_string_range_short (Nsate.project_authorization, char_100, (0));
	call convert_access_class_$to_string_range_short (temp_aim_range, char_100_2, (0));
	call long_report ("""^a""^/ to ""^a""", char_100, char_100_2);
	Nsate.project_authorization = temp_aim_range;
	edit_proj_arg.changes.anything = "1"b;
	return;
%page;

/**** Audit */
item (29):
	if check
	then do;
		if edit_proj_arg.match
		then call sub_err_ (0, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
			"Matching on the audit flags is not supported");
		if new
		then do;
			call convert_access_audit_flags_$from_string (new_value_string, temp_audit, code);
			if code ^= 0
			then call sub_err_ (code, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
				"Invalid audit string ""^a"".", new_value_string);
		     end;
		return;
	     end;


	call convert_access_audit_flags_$to_string (Nsate.audit, char_500, (0));
	temp_audit = Nsate.audit;
RE_GET_AUDIT:
	char_500_2 = char_500;
	call get_string ("Audit flags", char_500_2);
	if char_500_2 = ""
	then return;

	call convert_access_audit_flags_$edit_from_string (char_500_2, temp_audit, code);
	if code ^= 0
	then do;
		call com_err_ (code, edit_proj_arg.caller, "Invalid audit flag string ""^a"" .", char_500_2);
		go to RE_GET_AUDIT;
	     end;

	if temp_audit = Nsate.audit
	then return;

/* now the combined flags */
	call convert_access_audit_flags_$to_string (temp_audit, char_500_2, (0));

	call long_report ("""^a""^/ to ""^a""", char_500, char_500_2);
	Nsate.audit = temp_audit;
	edit_proj_arg.changes.anything = "1"b;
	return;

dispose_of_old_charges:
     procedure;

	declare response		 char (12);
	declare explanation		 char (100) init
	  ("You may respond ""drop"", ""bill"", ""transfer"" or ""reset"".")
	  int static options (constant);

	if Nreqfile.chg_mo <= 0e0 & Nreqfile.chg_tr <= 0e0
	then return;


	query_info.version = query_info_version_6;
	query_info.yes_or_no_sw = "0"b;
	query_info.suppress_name_sw = "1"b;
	query_info.suppress_spacing = "1"b;
	query_info.literal_sw = "0"b;
	query_info.prompt_after_explanation = "1"b;
	query_info.explanation_ptr = addr (explanation);
	query_info.explanation_len = length (rtrim (explanation));

RE_QUERY:
	call command_query_ (addr (query_info), response, edit_proj_arg.caller,
	     "What is the disposition of charges of $^.2f to acct ^a, req ^a?", Nreqfile.chg_mo + Nreqfile.chg_tr,
	     Nreqfile.mitacct, Nreqfile.reqno);
	if response = "drop"
	then do;
		Nreqfile.chg_tr = 0.0e0;
		Nreqfile.chg_mo = 0.0e0;
	     end;
	else if response = "transfer"
	then do;
	end;
	else if response = "bill"
	then do;
		call ioa_ ("Generate a manual charge for $^.2f to ^a ^a", Nreqfile.chg_mo, Nreqfile.mitacct,
		     Nreqfile.reqno);
		Nreqfile.chg_tr = 0.0e0;
		Nreqfile.chg_mo = 0.0e0;
	     end;
	else if response = "reset"
	then do;
		call ioa_ ("Charge this requistion has been changed from $^.2f to $0.00", Nreqfile.chg_tr);
		if Nreqfile.req_amt = 0.0e0
		then Nreqfile.chg_tr = 0.0e0;
		else do;
			call ioa_ ("The requisition amount has been changed from $^.2f to $^.2f", Nreqfile.req_amt,
			     Nreqfile.req_amt - Nreqfile.chg_tr);
			Nreqfile.req_amt = Nreqfile.req_amt - Nreqfile.chg_tr;
			Nreqfile.chg_tr = 0.0e0;
		     end;
	     end;
	else do;
		call ioa_ ("^a", explanation);
		go to RE_QUERY;
	     end;
	return;
     end dispose_of_old_charges;

simple_string:
     procedure (prompt, target);
	declare prompt		 char (*);
	declare target		 char (*);
	declare old_target		 char (600);

	if check
	then return;				/* what's to say? */
	if edit_proj_arg.match
	then if match_value_string ^= target
	     then call no_match;

	old_target = target;
	call get_string (prompt, target);
	if target = old_target
	then return;

	call long_report ("""^a"" to ""^a""", old_target, target);
	edit_proj_arg.changes.anything = "1"b;
	return;
     end simple_string;

get_string:
     procedure (prompt, target);
	declare prompt		 char (*);
	declare target		 char (*);
	declare response		 char (500);

	if new					/* use the global so we can turn it off to use it only once. */
	then do;
		target = new_value_string;
		new = "0"b;
		return;
	     end;

	query_info.version = query_info_version_6;
	query_info.yes_or_no_sw = "0"b;
	query_info.suppress_name_sw = "1"b;
	query_info.suppress_spacing = "1"b;
	query_info.literal_sw = "0"b;
	query_info.prompt_after_explanation = "1"b;
	query_info.explanation_ptr = null ();
	query_info.explanation_len = 0;

	if edit_proj_arg.report_project_name & ^printed_projname
	then do;
		call ioa_ ("Project ^a:", Nsate.project_id);
		printed_projname = "1"b;		/* once is enough */
	     end;

	call command_query_ (addr (query_info), response, edit_proj_arg.caller, "^a:^[^25t^a^/^;   ^]", prompt,
	     target ^= "", target);
	if response = ""
	then return;
	target = response;

	return;
     end get_string;


change_account:
     procedure (new_account);
	declare new_account		 char (*);

	call long_report ("""^a"" to ""^a""", Nreqfile.mitacct, new_account);
	call dispose_of_old_charges;
	Nreqfile.mitacct = new_account;
	edit_proj_arg.changes.anything = "1"b;
	return;
     end change_account;

change_requisition:
     procedure (new_requisition);

	declare new_requisition	 char (*);

	call long_report ("""^a"" to ""^a""", Nreqfile.reqno, new_requisition);
	call dispose_of_old_charges;
	Nreqfile.reqno = new_requisition;
	edit_proj_arg.changes.anything = "1"b;
	return;
     end change_requisition;

long_report:
     procedure options (variable);

	declare alp		 pointer;
	declare change_string	 char (1000);
	declare csl		 fixed bin (21);

	if ^edit_proj_arg.long
	then return;
	call cu_$arg_list_ptr (alp);
	call ioa_$general_rs (alp, 1, 2, change_string, csl, "0"b, "0"b);
	call ioa_ ("Changed ^a^[ for project ^a^;^s^] from ^a.", PROJ_KEY_NAMES (Value_index),
	     edit_proj_arg.report_project_name, Nsate.project_id, substr (change_string, 1, csl));
	return;
     end long_report;

long_report_:
     procedure options (variable);

	declare alp		 pointer;
	declare change_string	 char (1000);
	declare csl		 fixed bin (21);

	if ^edit_proj_arg.long
	then return;
	call cu_$arg_list_ptr (alp);
	call ioa_$general_rs (alp, 1, 2, change_string, csl, "0"b, "0"b);
	call ioa_ ("^[Changed project ^a: ^;^s^]^a.", edit_proj_arg.report_project_name, Nsate.project_id,
	     substr (change_string, 1, csl));
	return;
     end long_report_;

sfb17:
     procedure (prompt, min, max, target);

	declare prompt		 char (*);
	declare (min, max)		 fixed bin (18);
	declare (target)		 fixed bin;
	declare junk		 fixed bin (35);

	if check
	then do;
		call sfbcheck (min, max);
		return;
	     end;
	if edit_proj_arg.match
	then if ^sfbmatch ((target))
	     then call no_match;

	call get_fb (prompt, min, max, junk, (target));
	target = junk;
	return;
     end sfb17;


sfb17u:
     procedure (prompt, min, max, target);

	declare prompt		 char (*);
	declare (min, max)		 fixed bin (18);
	declare (
	        target		 unaligned
	        )			 fixed bin;
	declare junk		 fixed bin (35);

	if check
	then do;
		call sfbcheck (min, max);
		return;
	     end;
	if edit_proj_arg.match
	then if ^sfbmatch ((target))
	     then call no_match;

	call get_fb (prompt, min, max, junk, (target));
	target = junk;
	return;
     end sfb17u;


sfb9uu:
     procedure (prompt, min, max, target);

	declare prompt		 char (*);
	declare (min, max)		 fixed bin (18);
	declare target		 fixed bin (9) uns unal;
	declare junk		 fixed bin (35);

	if check
	then do;
		call sfbcheck (min, max);
		return;
	     end;
	if edit_proj_arg.match
	then if ^sfbmatch ((target))
	     then call no_match;

	call get_fb (prompt, min, max, junk, (target));
	target = junk;
	return;
     end sfb9uu;


sfbcheck:
     procedure (min, max);

	declare (min, max)		 fixed bin (18);

	if edit_proj_arg.new_value.ptr ^= null ()
	then call sfbcheck_ (new_value_string);
	if edit_proj_arg.match_value.ptr ^= null ()
	then call sfbcheck_ (match_value_string);

	return;

sfbcheck_:
     procedure (checkee);

	declare checkee		 char (*);
	declare junk		 fixed bin (35);

	junk = cv_dec_check_ (checkee, code);
	if code ^= 0 | junk < min | (max > 0 & junk > max)
	then call sub_err_ (error_table_$bad_conversion, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
		"Invalid value ""^a"".", checkee);
	return;
     end sfbcheck_;
     end sfbcheck;

sfbmatch:
     procedure (test) returns (bit (1) aligned);

	declare test		 fixed bin;
	declare junk		 fixed bin (35);

	junk = cv_dec_check_ (match_value_string, (0));
	return (junk = test);
     end sfbmatch;

get_fb:
     procedure (prompt, min, max, newfb, oldfb);

	declare prompt		 char (*);
	declare (min, max)		 fixed bin (18);
	declare (newfb, oldfb)	 fixed bin (35);
	declare fb_string		 char (20);

	if new
	then do;					/* already checked */
		newfb = cv_dec_check_ (new_value_string, (0));
		new = "0"b;
		if newfb ^= oldfb
		then do;
			edit_proj_arg.changes.anything = "1"b;
			call long_report ("^d to ^d", oldfb, newfb);
		     end;
		return;
	     end;

RE_GET_FB:
	fb_string = ltrim (char (oldfb));
	call get_string (prompt, fb_string);
	newfb = cv_dec_check_ (fb_string, code);
	if code ^= 0 | newfb < min | (max > 0 & newfb > max)
	then do;
		call com_err_ (error_table_$bad_conversion, edit_proj_arg.caller, "Invalid value ""^a"".", fb_string);
		go to RE_GET_FB;
	     end;
	if newfb = oldfb
	then return;
	call long_report ("^d to ^d", oldfb, newfb);
	edit_proj_arg.changes.anything = "1"b;
	return;
     end get_fb;

check_admin:
     procedure (admin_name);

	declare admin_name		 char (*);

	if ^check_admin_ (admin_name)
	then call sub_err_ (0, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
		"Invalid project administrator name ""^a"".", admin_name);
	return;
     end check_admin;

check_admin_:
     procedure (admin) returns (bit (1) aligned);

	declare admin		 char (*);
	declare u			 char (32) varying;
	declare p			 char (32) varying;

	u = rtrim (before (admin, "."));
	p = rtrim (after (admin, "."));
	if u = admin
	then return ("0"b);				/* has to have a . */
	if p = ""
	then return ("0"b);				/* followed by something */
	if u = "*" & p = "*"
	then return ("0"b);
	if (u ^= "*" & verify (u, LEGAL) > 0) | (p ^= "*" & verify (p, LEGAL) > 0)
	then return ("0"b);
	return ("1"b);
     end check_admin_;

quota_value:
     procedure (qtype, prompt, target);
	declare qtype		 char (3);
	declare prompt		 char (*);
	declare target		 fixed bin (35);
	declare junk		 fixed bin (35);
	declare (new_string, old_string)
				 char (20);

	if check
	then do;
		if edit_proj_arg.match
		then call sub_err_ (0, edit_proj_arg.caller, ACTION_CANT_RESTART, null (), (0),
			"Matching on quota values is not permitted.");
		if new
		then call sfbcheck (0, 262120);
		return;
	     end;

	if qtype = "dir"
	then old_string = ltrim (char (Nprojfile.dir_disk_quota));
	else old_string = ltrim (char (Nprojfile.disk_quota));

RE_GET_QUOTA:
	new_string = old_string;
	call get_string (prompt, new_string);
	if new_string = old_string
	then return;

	sign = substr (new_string, 1, 1);
	if sign ^= "+" & sign ^= "-"
	then sign = "r";
	junk = cv_dec_check_ (new_string, code);
	if code ^= 0
	then do;
		call com_err_ (error_table_$bad_conversion, edit_proj_arg.caller, "Invalid quota value ""^a"".",
		     new_string);
		go to RE_GET_QUOTA;
	     end;

	if sign ^= "r"
	then if qtype = "dir"
	     then junk = Nprojfile.dir_disk_quota + junk;
	     else junk = Nprojfile.disk_quota + junk;

	if qtype = "dir"
	then do;
		call long_report ("^d to ^d", Nprojfile.dir_disk_quota, junk);
		Nprojfile.dir_disk_quota = junk;
	     end;
	else do;
		call long_report ("^d to ^d", Nprojfile.disk_quota, junk);
		Nprojfile.disk_quota = junk;
	     end;
	edit_proj_arg.changes.anything = "1"b;
	if qtype = "seg"
	then edit_proj_arg.changes.seg_quota = "1"b;
	else edit_proj_arg.changes.dir_quota = "1"b;
	return;
     end quota_value;

no_match:
     procedure;
	go to RETURN;
     end no_match;

valid_group:
     procedure (perhaps_group_name) returns (bit (1) aligned);
	declare perhaps_group_name	 char (*);
	declare groupx		 fixed bin;

	if length (perhaps_group_name) > length (Nsate.group)
						/* easy case */
	then return ("0"b);
	if perhaps_group_name = "*"
	then return ("1"b);				/* special case "*" means "any" */
	do groupx = 17 to mgt.current_size;		/* first 16 are WC's, uggh */
	     mgtep = addr (mgt.entry (groupx));
	     if group.group_id = perhaps_group_name
	     then return ("1"b);
	end;
	return ("0"b);
     end valid_group;

RETURN:
	return;

     end process_one_item;
     end edit_proj_;




		    edit_projfile.pl1               09/19/84  0911.6rew 09/18/84  0756.2       88434



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


edit_projfile: epro: procedure options (variable);

/* project file editor */

dcl (path, dn) char (168),				/* path and directory name */
     en char (32),					/* entry name */
     pj char (12) aligned,				/* project id for find */
    (j, np) fixed bin,				/* integers */
     ec fixed bin (35),
     num fixed bin,
     num24 fixed bin (24),
     code char (8),					/* change code */
     func char (8) aligned,				/* edit request */
     flg fixed bin,					/* flag from ask */
    (pp, ppp) ptr,					/* ptr to projfile */
     hp ptr,
     dtem char (8),
     ap ptr,					/* ptr to arg */
     bchr char (al) based (ap) unaligned,		/* pickup for arg */
     al fixed bin;					/* lth of arg */

dcl  projfile_zap (num24) fixed bin based;


dcl (ask_, ask_$ask_int, ask_$ask_cint,
     ask_$ask_n, ask_$ask_line, ask_$ask_clr) entry options (variable),
     com_err_ entry options (variable),
     convert_date_to_binary_ entry (char(*), fixed bin(71), fixed bin (35)),
     expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     ioa_ entry options (variable),
     date_time_ entry (fixed bin (71), char (*)),
     get_temp_segment_ entry (char (*), pointer, fixed bin (35)),
     release_temp_segment_ entry (char (*), pointer, fixed bin (35)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35));

dcl (clock, null, addr, substr) builtin;

%include projfile;



/* - - - - - - - - - - */

	call cu_$arg_ptr (1, ap, al, ec);		/* see if any args */
	if ec ^= 0 | al = 0				/* if not, then ... */
	then path = "projfile";			/* set up default */
	else path = bchr;				/* get pathname of projfile */

	call expand_pathname_ (path, dn, en, ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "edit_projfile", path);
	     return;				/* die */
	end;
	call hcs_$initiate (dn, en, "", 0, 1, ppp, ec);	/* Initiate real project file. */
	if ppp = null then go to er;
	if ppp -> projfile.version ^= PROJFILE_VERSION
	then do;
	     call com_err_ (0, "edit_projfile", "^a>^a version ^d is not current version ^d.", dn, en, projfile.version, PROJFILE_VERSION);
	     call hcs_$terminate_noname (ppp, (0));
	     return;
	end;
	     
	call get_temp_segment_ ("edit_projfile", pp, ec);
	if ec ^= 0 then go to er;
	np = ppp -> projfile.nproj;
	num24 = loph + np * lope;
	pp -> projfile_zap = ppp -> projfile_zap;
	call hcs_$terminate_noname (ppp, ec);

	if np = 0 then
	     call ioa_ ("WARNING: projfile is empty.");

cmain:	call ask_$ask_clr;				/* Clear input buffer. */
	j = np;					/* Set pointer to last entry */
main:	call ask_ ("type    ", func);			/* Ask for editing function. */

	if func = "f" then go to find;
	if func = "find" then go to find;

	if func = "c" then go to change;
	if func = "change" then go to change;

	if func = "p" then go to print;
	if func = "print" then go to print;

	if func = "file" then go to file;
	if func = "w" then go to file;
	if func = "q" then go to quit;
	if func = "quit" then go to quit;

	if func = "d" then go to delete;
	if func = "delete" then go to delete;

	if func = "n" then go to next;
	if func = "next" then go to next;

	if func = "a" then go to add;
	if func = "add" then go to add;

	if func = "t" then go to top;
	if func = "top" then go to top;

	if func = "help" then do;
	     call ioa_ ("Instructions:");
	     call ioa_ ("""f id""^-to find");
	     call ioa_ ("""c code val code val ... *"" to change");
	     call ioa_ ("""p -n-""^-to print");
	     call ioa_ ("""file""^-to file");
	     call ioa_ ("""a id""^-to add");
	     call ioa_ ("""n -n-""^-to go to next");
	     call ioa_ ("""t""^-to go to top");
	     call ioa_ ("""help""^-for instructions");
	     go to main;
	end;

	call ioa_ ("""^a"" illegal. Type ""help"" for instructions.", func);
	go to cmain;				/* Clear line buffer and go */

/* Search for an ID */

find:	call ask_ ("proj id ", pj);			/* Get project to search for. */
	if pj = id (j) then go to main;		/* Skip out if we're there. */

	do j = 1 to np;				/* Otherwise, look at all id's. */
	     if pj = id (j) then go to main;		/* ... */
	end;

	call ioa_ ("Project ""^a"" not found.", pj);	/* Missing. Gripe. */
	go to cmain;				/* Go and clear line buffer. */

/* Modify an entry */

change:	call ask_$ask_n (code, flg);			/* Peek to see if any more on line. */
	if flg = 0 then call ioa_ ("Type changes.");	/* If not, suggest something. */

clp:	call ask_ ("code    ", code);			/* Get a change code. */

	if code = "*" then go to main;		/* Star for done. */

	if code = "id" then do;			/* Change project id? */
	     call ask_ (code, id (j));
	end;
	else if code = "title" then do;		/* Change project title? */
	     call ask_$ask_line (code, title (j));
	end;
	else if code = "inv" then do;			/* Change investigator? */
	     call ask_$ask_line (code, inv (j));
	end;
	else if code = "inv_addr" then do;		/* Investigator address? */
	     call ask_$ask_line (code, inv_addr (j));
	end;
	else if code = "sup" then do;			/* Supervisor name? */
	     call ask_$ask_line (code, sup (j));
	end;
	else if code = "sup_addr" then do;		/* Supervisor address? */
	     call ask_$ask_line (code, sup_addr (j));
	end;
	else if code = "sup_phon" then do;		/* Supervisor phon? */
	     call ask_$ask_line (code, sup_phone (j));
	end;
	else if code = "dps" then do;
	     call ask_$ask_int (code, num);
	     disk_psec (j) = num;
	end;
	else if code = "dq" then do;
	     call ask_$ask_int (code, disk_quota (j));
	end;
	else if code = "ddq" then do;
	     call ask_$ask_int (code, dir_disk_quota (j));
	end;
	else if code = "du" then do;
	     call ask_$ask_int (code, disk_use (j));
	end;
	else if code = "ddu" then do;
	     call ask_$ask_int (code, dir_disk_use (j));
	end;
	else if code = "on" then do;
	     on (j) = gdate (code);
	end;
	else if code = "off" then do;
	     off (j) = gdate (code);
	end;
	else do;					/* Unknown change code. Gripe. */
	     call ioa_ ("Illegal change code ""^a"".", code);
	     call ask_$ask_clr;			/* Clear line. */
	end;

	go to clp;				/* Go look for another code. */

/* Print an entry */

print:	call ask_$ask_cint (num, flg);		/* see how many */
	if flg ^= 1 then num = 1;
ploop:	call ioa_ ("^a", id (j));			/* print entry */
	call ioa_ ("^-^a", title (j));
	call ioa_ ("^-^a", inv (j));
	call ioa_ ("^-^a", inv_addr (j));
	call ioa_ ("^-^a", sup (j));
	call ioa_ ("^-^a", sup_addr (j));
	call ioa_ ("^-^a", sup_phone (j));
	call date_time_ (on (j), dtem);
	ec = disk_psec (j);
	call ioa_ ("^-date on ^a, disk ps = ^d, ^d/^d", dtem, ec, disk_quota (j), disk_use (j));
	call ioa_ ("^-directory quota ^d/^d", dir_disk_quota (j), dir_disk_use (j));
	call date_time_ (off (j), dtem);
	if off (j) ^= 0 then call ioa_ ("^-date off ^a", dtem);
	num = num - 1;
	if num <= 0 then go to main;			/* see if done */
	j = j + 1;				/* no, do next */
	if j > np then go to eof;			/* ... if any */
	go to ploop;

/* Go to nentry */

next:	call ask_$ask_cint (num, flg);		/* Check for a number. */
	if flg ^= 1 then num = 1;			/* If none there, assume one. */
	j = j + num;				/* Bump index. */
	if j > np then do;				/* Check range. */
eof:	     call ioa_ ("EOF");			/* Remark if too big. */
	     go to cmain;				/* clear buffer */
	end;
	go to main;

/* Delete an entry */

delete:	call ioa_ ("Deleting ""^a"".", id (j));		/* say, just in case */
	off (j) = clock ();				/* project is off now */
	go to main;

/* Add a new entry */

add:	np = np + 1;				/* Allocate new slot. */
	j = np;					/* Set pointer. */
	call ask_ ("proj id ", id (j));		/* Get ID. */
	call ask_$ask_line ("title   ", title (j));	/* Get title. */
	call ask_$ask_line ("inv     ", inv (j));	/* Get investigator. */
	call ask_$ask_line ("inv_addr ", inv_addr (j));	/* & address */
	call ask_$ask_line ("sup     ", sup (j));	/* Get supervisor. */
	call ask_$ask_line ("sup_addr ", sup_addr (j));	/* & address */
	call ask_$ask_line ("sup_phone ", sup_phone (j)); /* & phone */
	on (j) = clock ();
	off (j) = 0;
	go to main;

/* Go to top */

top:	j = 1;					/* whee */
	go to main;

/* Finish up. */

file:	nproj = np;				/* Set count back in file. */
	num24 = loph + np * lope;			/* compute number of wds in file */
	call hcs_$initiate (dn, en, "", 0, 1, ppp, ec);	/* initi real copy */
	if ppp = null then go to er;
	ppp -> projfile_zap = pp -> projfile_zap;
	call hcs_$terminate_noname (ppp, ec);
	num24 = 36 * num24;				/* Compute bit count. */
	call hcs_$set_bc (dn, en, num24, ec);		/* ... */

	if func = "w" then go to main;

quit:	call release_temp_segment_ ("edit_projfile", pp, ec);
	call ioa_ ("");

gdate:	proc (xcode) returns (fixed bin (71));		/* date getter */
dcl  xcode char (*) parameter;				/* argument */
dcl  temp char (12),
     b71 fixed bin (71);		/* temps */

xgdate:	     call ask_ (xcode, temp);			/* ask for the date */
	     call convert_date_to_binary_ (temp, b71, ec); /* Turn it into binary  */
	     if ec ^= 0 then do;			/* was it illegal? */
		call ioa_ ("Illegal date for ""^a"": ""^a""", xcode, temp);
		call ask_$ask_clr;
		go to xgdate;			/* try again */
	     end;
	     return (b71);
	end gdate;
     end edit_projfile;




		    edit_reqfile.pl1                09/19/84  0911.6rew 09/18/84  0756.2       88542



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

edit_reqfile: erf: proc;

/* requisition file editor */

dcl (path, dn) char (168) aligned,			/* path and directory name */
     en char (32) aligned,				/* entry name */
     pj char (12) aligned,				/* acct id for find */
    (ec, j, nq, num) fixed bin,			/* integers */
     num24 fixed bin (24),
     code char (8),					/* change code */
     func char (8) aligned,				/* edit request */
     chdt char (8),					/* date temp */
     ftemp float bin,				/* floating temp */
     flg fixed bin,					/* flag from ask */
    (qp, qpp) ptr,					/* ptr to reqfile */
     ap ptr,					/* ptr to arg */
     bchr char (168) based (ap) unaligned,		/* pickup for arg */
     al fixed bin;					/* lth of arg */

dcl (ask_, ask_$ask_cint, ask_$ask_n, ask_$ask_line, ask_$ask_clr) entry options (variable),
     com_err_ entry options (variable),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     ioa_ entry options (variable),
     ask_$ask_flo entry options (variable),
     date_time_ entry (fixed bin (71), char (*)),
     hcs_$delentry_seg entry (ptr, fixed bin),
     clock_ entry () returns (fixed bin (71)),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin);

dcl (addr, substr, null) builtin;

dcl  reqfile_zap (num24) fixed bin based;


%include reqfile;

/* - - - - - - - - - - */

	call cu_$arg_ptr (1, ap, al, ec);		/* see if any args */
	if ec ^= 0 | al = 0 then do;			/* if not, then ... */
	     path = "reqfile";			/* set up default */
	     al = 7;				/* ... */
	end;
	else path = substr (bchr, 1, al);		/* get pathname of reqfile */

	call expand_path_ (addr (path), al, addr (dn), addr (en), ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "edit_reqfile", path);
	     return;				/* die */
	end;
	call hcs_$initiate (dn, en, "", 0, 1, qpp, ec);	/* Initiate real requisition file. */
	if qpp = null then go to er;
	call hcs_$make_seg ("", "", "", 1011b, qp, ec);	/* Make scratch seg */
	if qp = null then go to er;
	nq = qpp -> reqfile.nacts;
	num24 = loqh + nq * loqe;
	qp -> reqfile_zap = qpp -> reqfile_zap;
	call hcs_$terminate_noname (qpp, ec);

	if nq = 0 then
	     call ioa_ ("WARNING: reqfile is empty.");

cmain:	j = nq;					/* Set pointer to last entry */
cmain1:	call ask_$ask_clr;				/* Clear input buffer. */
main:	call ask_ ("type    ", func);			/* Ask for editing function. */

	if func = "f" then go to find;
	if func = "find" then go to find;

	if func = "c" then go to change;
	if func = "change" then go to change;

	if func = "p" then go to print;
	if func = "print" then go to print;

	if func = "file" then go to file;
	if func = "w" then go to file;
	if func = "q" then go to quit;
	if func = "quit" then go to quit;

	if func = "d" then go to delete;
	if func = "delete" then go to delete;

	if func = "n" then go to next;
	if func = "next" then go to next;

	if func = "a" then go to add;
	if func = "add" then go to add;

	if func = "t" then go to top;
	if func = "top" then go to top;

	if func = "help" then do;
	     call ioa_ ("Instructions:");
	     call ioa_ ("""f id""^-to find");
	     call ioa_ ("""c code val code val ... *"" to change");
	     call ioa_ ("""p -n-""^-to print");
	     call ioa_ ("""file""^-to file");
	     call ioa_ ("""a id""^-to add");
	     call ioa_ ("""n -n-""^-to go to next");
	     call ioa_ ("""t""^-to go to top");
	     call ioa_ ("""help""^-for instructions");
	     go to main;
	end;

	call ioa_ ("""^a"" illegal. Type ""help"" for instructions.", func);
	go to cmain1;				/* Clear line buffer and go */

/* Search for an ID */

find:	call ask_ ("id      ", pj);			/* Get req to search for. */
	if pj = acctid (j) then go to main;		/* Skip out if we're there. */

	do j = 1 to nq;				/* Otherwise, look at all id's. */
	     if pj = acctid (j) then go to main;	/* ... */
	end;

	call ioa_ ("Account ""^a"" not found.", pj);	/* Missing. Gripe. */
	go to cmain;				/* Go and clear line buffer. */

/* Modify an entry */

change:	call ask_$ask_n (code, flg);			/* Peek to see if any more on line. */
	if flg = 0 then call ioa_ ("Type changes.");	/* If not, suggest something. */

clp:	call ask_ ("code    ", code);			/* Get a change code. */

	if code = "*" then go to main;		/* Star for done. */

	if code = "id" then do;			/* Change project id? */
	     call ask_ (code, acctid (j));
	end;
	else if code = "acct" then do;		/* Change MIT account no.? */
	     call ask_ (code, mitacct (j));
	end;
	else if code = "req" then do;			/* change requisition no? */
	     call ask_ (code, reqno (j));
	end;
	else if code = "name" then do;		/* change billing anme */
	     call ask_$ask_line (code, billing_name (j));
	end;
	else if code = "addr" then do;		/* change billing address? */
	     call ask_$ask_line (code, billing_addr (j));
	end;
	else if code = "amt" | code = "$" then do;
	     call ask_$ask_flo (code, ftemp);
	     req_amt (j) = ftemp;
	end;
	else if code = "chg_mo" | code = "mo" then do;
	     call ask_$ask_flo (code, ftemp);
	     chg_mo (j) = ftemp;
	end;
	else if code = "chg_tr" | code = "tr" then do;
	     call ask_$ask_flo (code, ftemp);
	     chg_tr (j) = ftemp;
	end;
	else if code = "cutoff" then do;
	     cutoff (j) = gdate (code);		/* change cutoff date */
	end;
	else if code = "on" then do;			/* change date on? */
	     qdn (j) = gdate (code);
	end;
	else if code = "off" then do;			/* change date off? */
	     qdf (j) = gdate (code);
	end;
	else do;					/* Unknown change code. Gripe. */
	     call ioa_ ("Illegal change code ""^a"".", code);
	     call ask_$ask_clr;			/* Clear line. */
	end;

	go to clp;				/* Go look for another code. */

/* Print an entry */

print:	call ask_$ask_cint (num, flg);		/* see how many */
	if flg ^= 1 then num = 1;
ploop:	call ioa_ ("^a - ^a - ^a.", acctid (j), mitacct (j), reqno (j));
	call date_time_ (cutoff (j), chdt);		/* make date printable */
	call ioa_ ("^-$^15.2f, cutoff ^a", req_amt (j), chdt);
	call date_time_ (qdn (j), chdt);
	call ioa_ ("^-date on ^a", chdt);
	if qdf (j) ^= 0 then do;
	     call date_time_ (qdf (j), chdt);
	     call ioa_ ("^-date off ^a", chdt);
	end;
	call ioa_ ("^-^a", billing_name (j));
	call ioa_ ("^-^a", billing_addr (j));
	call ioa_ ("^-this mo $^15.2f, this req $^15.2f", chg_mo (j), chg_tr (j));
	num = num - 1;
	if num <= 0 then go to main;			/* see if done */
	j = j + 1;				/* no, do next */
	if j > nq then go to eof;			/* ... if any */
	go to ploop;

/* Go to nentry */

next:	call ask_$ask_cint (num, flg);		/* Check for a number. */
	if flg ^= 1 then num = 1;			/* If none there, assume one. */
	j = j + num;				/* Bump index. */
	if j > nq then do;				/* Check range. */
eof:	     call ioa_ ("EOF");			/* Remark if too big. */
	     go to cmain;				/* clear buffer */
	end;
	go to main;

/* Delete an entry */

delete:	call ioa_ ("Deleting ""^a"".", acctid (j));	/* say, just in case */
	qdf (j) = clock_ ();
	go to main;

/* Add a new entry */

add:	nq = nq + 1;				/* Allocate new slot. */
	j = nq;					/* Set pointer. */
	call ask_ ("id      ", acctid (j));
	call ask_ ("MITacct ", mitacct (j));
	call ask_ ("reqno   ", reqno (j));
	call ask_$ask_flo ("amount  ", ftemp);
	req_amt (j) = ftemp;
	cutoff (j) = gdate ("cutoff  ");
	call ask_$ask_line ("name    ", billing_name (j));
	call ask_$ask_line ("address ", billing_addr (j));
	chg_mo (j), chg_tr (j) = 0.0e0;
	qflag (j) = "";
	qdn (j) = clock_ ();
	qdf (j) = 0;
	go to main;

/* Go to top */

top:	j = 1;					/* whee */
	go to main;

/* Finish up. */

file:	qp -> reqfile.nacts = nq;			/* set count back in file */
	num24 = loqh + nq * loqe;			/* compute # of wds in file */
	call hcs_$initiate (dn, en, "", 0, 1, qpp, ec);	/* initiate real file */
	if qpp = null then go to er;
	qpp -> reqfile_zap = qp -> reqfile_zap;		/* copy new into old */
	num24 = 36 * num24;				/* compute new bit count */
	call hcs_$set_bc (dn, en, num24, ec);		/* ... */
	call hcs_$terminate_noname (qpp, ec);		/* terminate input */
	if func = "w" then go to main;

quit:	call hcs_$delentry_seg (qp, ec);		/* delete scratch copy */
	call ioa_ ("");

gdate:	proc (xcode) returns (fixed bin (71));		/* date getter */
dcl  xcode char (*);				/* argument */
dcl  temp char (12) aligned, b71 fixed bin (71),		/* temps */
     convert_date_to_binary_ entry (char (*) aligned, fixed bin (71), fixed bin);

xgdate:	     call ask_ (xcode, temp);			/* ask for the date */
	     call convert_date_to_binary_ (temp, b71, ec);
	     if ec ^= 0 then do;			/* was it illegal? */
		call ioa_ ("Illegal date for ""^a"": ""^a""", xcode, temp);
		call ask_$ask_clr;			/* illegal date. clear input */
		go to xgdate;			/* try again */
	     end;
	     return (b71);				/* good date, return it */
	end gdate;
     end;




		    is_he_user.pl1                  11/12/82  1412.9rew 11/12/82  1109.5       13014



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


is_he_user: proc (name, ans);

/* IS_HE_USER - active function to tell if user ID is in current URF hash table. */
/* Modified August 1979 by C. Hornig for new URF format */

dcl  name char (*) unal,
     ans char (*) varying,
     val fixed bin,
     ec fixed bin (35);

dcl (error_table_$wrong_no_of_args,
     error_table_$id_not_found) external fixed bin (35);

dcl  active_fnc_err_ entry options (variable),
     cu_$af_arg_count entry (fixed bin, fixed bin (35)),
     urf_manager_$get_entry entry (character (*), pointer, fixed bin (35));

dcl  null builtin;

	call cu_$af_arg_count (val, ec);
	if ec = 0 & val ^= 1 then ec = error_table_$wrong_no_of_args;
	if ec ^= 0 then do;
er:	     call active_fnc_err_ (ec, "is_he_user");
	     return;
	end;

	ans = "false";
	call urf_manager_$get_entry (name, null (), ec);
	if ec = 0 then ans = "true";
	else if ec ^= error_table_$id_not_found then goto er;
	return;
     end is_he_user;




		    is_legal_proj.pl1               07/13/88  1122.2r w 07/13/88  0941.1       16434



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


is_legal_proj: proc (name, ans);

/* IS_LEGAL_PROJ - answer whether a project is a legal one. looks in SAT */

dcl  name char (*) unal,
     name1 char (32) aligned,
     en char (32) aligned,
     ans char (*) varying,
     i fixed bin,
     ec fixed bin,
     satep ptr,
     satp ptr;

dcl (addr, null) builtin;

dcl  active_fnc_err_ entry options (variable),
     error_table_$wrong_no_of_args fixed bin ext,
     cu_$arg_count entry (fixed bin),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin, fixed bin, ptr, fixed bin),
     get_wdir_ entry () returns (char (168) aligned);

/* =============================================== */

	call cu_$arg_count (i);			/* check arg count */
	if i ^= 2 then do;
	     ec = error_table_$wrong_no_of_args;
	     en = "";
er:	     call active_fnc_err_ (ec, "is_legal_proj", en);
	     return;
	end;
	name1 = name;
	ans = "false";
	en = "smf.cur.sat";
	call hcs_$initiate ((get_wdir_()), en, "", 0, 1, satp, ec);
	if satp = null then go to er;
	do i = 1 to sat.current_size;
	     satep = addr (sat.project(i));
	     if satep -> project.state = 1 then
	     if name1 = satep -> project.project_id then go to yup;
	end;
	return;
yup:	ans = "true";

%page;
%include sat;
%page;
%include user_attributes;


     end is_legal_proj;




		    labl1.pl1                       09/19/84  0911.6rew 09/18/84  0757.0       24570



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


labl1: proc;

/* Write labels from "projfile" */

dcl (hp, pp) ptr,					/* pointers */
    (path, dn) char (168) aligned,			/* file system names */
     en char (32) aligned,				/* .. */
     wkp ptr,					/* pointer to readin buffer (dn) */
     nc fixed bin,					/* number of chars read in */
    (i, np, ec) fixed;				/* counters */

dcl  com_err_ entry options (variable),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     ioa_ entry options (variable),
     ios_$read_ptr entry (ptr, fixed bin, fixed bin);

dcl (addr, null, substr) builtin;


dcl  x1 char (50) int static aligned init		/* format statements */
    ("     xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"),
     x2 char (20) int static aligned init
    ("     x   ^32ax");

/* - - - - */

	wkp = addr (dn);				/* get ptr to buffer */
	path = "projfile";				/* Hunt up project file */
	call expand_path_ (addr (path), 8, addr (dn), addr (en), ec);
	if ec ^= 0 then do;
err:	     call com_err_ (ec, "labl1", path);
	     return;
	end;
	call hcs_$initiate (dn, en, "", 0, 1, pp, ec);	/* Get project file. */
	if pp = null then go to err;

test:	call ioa_ (x1);				/* Write out test box. */
	call ioa_ (x2, "");
	call ioa_ (x2, "Multics billing labels.");
	call ioa_ (x2, "");
	call ioa_ (x2, "This box should be centered.");
	call ioa_ (x2, "Type cr to go, x to repeat");
	call ioa_ (x1);
	call ioa_ ("");
	call ios_$read_ptr (wkp, 12, nc);		/* Read his answer. */
	if nc > 1 then go to test;			/* If he typed anything, repeat */

	np = pp -> projfile.nproj;			/* Ready to go. */

	do i = 1 to np;				/* Loop for all projects */
	     call ioa_ ("");			/* Drop down one line */
	     call ioa_ ("^-^a", projfile.projfiletab.sup (i)); /* Supervisor. */
	     call ioa_ ("");
	     call ioa_ ("^-^a", projfile.projfiletab.sup_addr (i));   /* Address. */
	     call ioa_ ("^/");
	     call ioa_ ("^-Supervisor, ^a", projfile.projfiletab.id (i));	/* Group. */
	     call ioa_ ("^/");
	end;
	call hcs_$terminate_noname (pp, ec);
%page;
%include projfile;


     end;





		    make_volume_labels.pl1          03/25/86  0844.2r   03/25/86  0843.7      110493



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


make_volume_labels: proc;

/* This command generates data used to print paper labels for
   tape reels, disk packs, etc.

   Written (read "cribbed after make_tape_labels") 03/79 by C. D. Tavares
   Modified 09/81 by M.R. Jordan to fix a bug in -height processing. */

dcl  cu_$arg_count ext entry (fixed bin),
     cu_$arg_list_ptr ext entry (pointer),
     cu_$arg_ptr_rel ext entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer),
    (com_err_, com_err_$suppress_name, ioa_$rsnnl) ext entry options (variable);

dcl  authenticate_ ext entry (char (*)) returns (char (3) aligned),
     bigletter_$five ext entry (char (*) aligned, entry),
     resource_info_$canonicalize_name entry (char (*), char (*), char (*), fixed bin (35));

dcl  alp pointer,
     nargs fixed bin;

dcl (NEWLINE char (1) initial ("
"),
     RETURN char (1) initial (""),
     usage_line char (128) initial
    ("Usage:  make_volume_labels resource_name1 {-to resource_nameN} {-control_args}")) static options (constant);

dcl (error_table_$bad_arg,
     error_table_$bad_conversion,
     error_table_$inconsistent,
     error_table_$badopt,
     error_table_$noarg) ext fixed bin (35) static;

%include iox_dcls;

%include rcp_resource_types;

	call cu_$arg_count (nargs);
	if nargs = 0 then call crump (error_table_$noarg, usage_line);

	call cu_$arg_list_ptr (alp);

	begin;

dcl 1 arg_structure aligned automatic,
    2 n_used fixed bin initial (0),
    2 each (nargs) aligned,
      3 label char (32) varying,
      3 multiple bit (1) aligned,
      3 label_prefix char (32) varying,
      3 first_value fixed bin (35),
      3 last_value fixed bin (35),
      3 field_size fixed bin,
      3 label_suffix char (32) varying;

dcl  ap pointer,
    (skip_name_label, skip_auth_label) bit (1) aligned initial (""b),
     al fixed bin,
     auth char (3) aligned,
    (i, j) fixed bin,
    (prefix_len, suffix_len, len_wo_suffix) fixed bin,
     code fixed bin (35),
     temp char (32),
     temp_len fixed bin,
     temp_var char (32) varying,
     prefix char (512) varying,
     resource_type char (32) initial (VOLUME_TYPE (TAPE_VOL_VTYPEX)),
     switchname char (32) initial ("label_stream"),
     switch_ptr pointer;

dcl  sticker_width fixed bin initial (50),
     sticker_height fixed bin initial (9);

dcl  max_linel fixed bin,
     partial_linel fixed bin,
     max_label_chars fixed bin,
     partial_label_chars fixed bin;

dcl  arg char (al) based (ap);

dcl (rtrim, addrel, translate, substr, verify) builtin;
dcl (addr, binary, copy, divide, index, length, max, min, mod, reverse, search) builtin;

dcl  NUMERICS char (10) static options (constant) initial ("0123456789"),
     UPPERCASE char (26) static options (constant) initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

	     do i = 1 to nargs;

		call cu_$arg_ptr_rel (i, ap, al, code, alp);
		if code ^= 0 then call crump (code, "Obtaining argument.");

		if substr (arg, 1, 1) = "-" then do;
		     if arg = "-to" then do;
			i = i + 1;
			call cu_$arg_ptr_rel (i, ap, al, code, alp);
			if code ^= 0 then call crump (code, "After -to.");

			if arg_structure.n_used = 0 then call crump (error_table_$inconsistent, usage_line);

			if arg_structure.multiple (n_used) = "1"b then
			     call crump (error_table_$inconsistent, "-to specified more than once.");

			arg_structure.multiple (n_used) = "1"b;

			temp_var = arg_structure.label (n_used);

			j = search (reverse (temp_var), NUMERICS);
			if j = 0 then
			     call crump (error_table_$bad_arg,
			     "No numeric portion in " || arg_structure.label (n_used));

			len_wo_suffix = length (temp_var) - j + 2;
			if len_wo_suffix ^> length (temp_var) then do;
			     arg_structure.label_suffix (n_used) = substr (temp_var, len_wo_suffix);
			     temp_var = substr (temp_var, 1, len_wo_suffix-1);
			end;

			suffix_len = length (arg_structure.label_suffix (n_used));
			prefix_len = length (rtrim (temp_var, NUMERICS));
			arg_structure.label_prefix (n_used) = substr (temp_var, 1, prefix_len);
			arg_structure.field_size (n_used) = length (arg_structure.label (n_used)) - prefix_len
			     - length (arg_structure.label_suffix (n_used));
			arg_structure.first_value (n_used) = binary (substr (temp_var, prefix_len+1));

			call resource_info_$canonicalize_name (resource_type, arg, temp, code);
			if code ^= 0 then
			     call crump (code, rtrim (resource_type) || " " || arg);

			if substr (temp, 1, prefix_len) ^= substr (temp_var, 1, prefix_len) then
						/* prefix check */
dissimilar:		     call crump (error_table_$bad_arg, "Resource name is not similar:  " || temp);

			temp_len = length (rtrim (temp));
			if verify (substr (temp, prefix_len+1, temp_len-suffix_len-prefix_len), NUMERICS) > 0 then
			     goto dissimilar;	/* numeric field check */

			arg_structure.last_value (n_used) = binary (substr (temp, prefix_len+1,
			     temp_len - suffix_len - prefix_len));

			j = temp_len - suffix_len + 1;
			if substr (temp, j) ^= arg_structure.label_suffix (n_used) then
			     goto dissimilar;	/* suffix check */

			if arg_structure.last_value (n_used) < arg_structure.first_value (n_used) then
			     call crump (error_table_$bad_arg, "Numeric portion of " || temp
			     || "greater than that of " || arg_structure.label (n_used));
		     end;

		     else if arg = "-auth_only" then
			skip_name_label = "1"b;

		     else if arg = "-name_only" then
			skip_auth_label = "1"b;

		     else if arg = "-width" | arg = "-height" then do;
			temp_var = arg;

			i = i + 1;
			call cu_$arg_ptr_rel (i, ap, al, code, alp);
			if code ^= 0 then call crump (error_table_$noarg, "No number after " || temp_var);

			if verify (arg, NUMERICS) > 0 then
			     call crump (error_table_$bad_conversion, "Non-numeric:  " || arg);

			j = binary (arg);

			if temp_var = "-width" then do;
			     if j < 19 then call crump (error_table_$bad_arg, "Width less than 19 characters.");
			     sticker_width = j;
			end;

			else do;
			     if j < 8 then call crump (error_table_$bad_arg, "Height less than 8 lines.");
			     sticker_height = j;
			end;
		     end;

		     else if arg = "-output_switch" | arg = "-osw" then do;
			i = i + 1;
			call cu_$arg_ptr_rel (i, ap, al, code, alp);
			if code ^= 0 then call crump (code, "After -output_switch.");
			switchname = arg;
		     end;

		     else if arg = "-resource_type" | arg = "-rst" then do;
			i = i + 1;
			call cu_$arg_ptr_rel (i, ap, al, code, alp);
			if code ^= 0 then call crump (code, "After -resource_type.");
			resource_type = arg;
		     end;


		     else call crump (error_table_$badopt, arg);
		end;

		else do;
		     call resource_info_$canonicalize_name (resource_type, arg, temp, code);
		     if code ^= 0 then
			call crump (code, rtrim (resource_type) || " " || arg);

		     arg_structure.n_used = arg_structure.n_used + 1;
		     arg_structure.label (n_used) = rtrim (temp);
		     arg_structure.multiple (n_used) = ""b;
		     arg_structure.label_prefix (n_used),
			arg_structure.label_suffix (n_used) = "";
		     arg_structure.first_value (n_used),
			arg_structure.last_value (n_used),
			arg_structure.field_size (n_used) = 0;
		end;
	     end;

	     if skip_name_label & skip_auth_label then
		call crump (error_table_$inconsistent, "-auth_only and -name_only");

	     max_label_chars = divide (sticker_width + 2, 7, 17, 0);
	     partial_label_chars = divide (sticker_width, 7, 17, 0);
	     partial_linel = sticker_width - 2 - max (mod (sticker_width - 3, 7) - 4, 0);

	     call iox_$look_iocb (switchname, switch_ptr, code);
	     if code ^= 0 then call crump (code, switchname);

/* Now we have all the arguments.  Process them. */

	     do i = 1 to arg_structure.n_used;

/* Do the first one first */

		if ^skip_name_label then
		     if length (arg_structure.label (i)) > max_label_chars then
			call com_err_$suppress_name (0, "make_volume_labels",
			"Warning:  Only the first ^d complete characters of ^[^s^a^a^a^;^a^] will appear on the label.",
			partial_label_chars, arg_structure.multiple (i),
			arg_structure.label (i),
			arg_structure.label_prefix (i), copy ("_n", arg_structure.field_size (i)),
			arg_structure.label_suffix (i));

		call make_label (arg_structure.label (i));

		if arg_structure.multiple (i) = "1"b then /* have a set of them to make */
		     do j = arg_structure.first_value (i) + 1 to arg_structure.last_value (i);

		     call ioa_$rsnnl ("^a^vd^a", temp_var, 0, arg_structure.label_prefix (i),
			arg_structure.field_size (i), j,
			arg_structure.label_suffix (i));

		     temp_var = translate (temp_var, "0", " "); /* change blanks to zeroes */

		     call make_label (temp_var);
		end;
	     end;

	     return;
	     
make_label:    proc (label);

dcl  label char (32) varying parameter;
dcl  i fixed bin,
    (extra_lines, leading_spaces) fixed bin,
     data_len fixed bin,
     buffer char (1024) varying;

		auth = authenticate_ ((label));
		leading_spaces = max (divide (sticker_width - 5 - length (label), 2, 17, 0), 0);
		extra_lines = sticker_height - 7;

		if ^ skip_name_label then do;
		     i = divide (sticker_width + 2 - (7 * length (label)), 2, 17, 0);
		     if i > 0 then prefix = copy (" ", i);
		     else prefix = "";

		     data_len = length (label);
		     if data_len <= max_label_chars then
			max_linel = data_len * 7 - 2;
		     else max_linel = partial_linel;

		     call bigletter_$five ((label), line_proc);

		     buffer = prefix;

		     do i = 1 to min (max_label_chars, length (label));
			if index (UPPERCASE, substr (label, i, 1)) > 0 then
			     buffer = buffer || "-=-=-=-=-=  ";
			else buffer = buffer || "       ";
		     end;

		     buffer = buffer || copy (NEWLINE, 2);

		     call iox_$put_chars (switch_ptr, addrel (addr (buffer), 1), length (buffer), code);
		     if code ^= 0 then call crump (code, "while printing label");

		     call ioa_$rsnnl ("^vx^a^2x^3a", buffer, 0,
			leading_spaces, label, auth);

		     buffer = buffer || RETURN || buffer;
		     buffer = buffer || copy (NEWLINE, extra_lines);

		     call iox_$put_chars (switch_ptr, addrel (addr (buffer), 1), length (buffer), code);
		     if code ^= 0 then call crump (code, "while printing label");
		end;

		if ^ skip_auth_label then do;
		     i = divide (sticker_width - 19, 2, 17, 0);
		     prefix = copy (" ", i);

		     data_len = 3;
		     max_linel = 19;		/* 3 * 7 - 2 */

		     call bigletter_$five (auth, line_proc);

		     call ioa_$rsnnl ("^vx^a^2x^3a", buffer, 0,
			leading_spaces, label, auth);

		     buffer = buffer || RETURN || buffer;
		     buffer = copy (NEWLINE, 2) || buffer || copy (NEWLINE, extra_lines);

		     call iox_$put_chars (switch_ptr, addrel (addr (buffer), 1), length (buffer), code);
		     if code ^= 0 then call crump (code, "while printing label");
		end;

		return;
		
line_proc:	proc (linep, linel);

dcl  linep pointer parameter,
     linel fixed bin parameter;

dcl  line char (max_linel) based (linep);

dcl  buffer char (512) aligned varying,
     i fixed bin;

dcl  ANVZ_at_number char (11) static options (constant) initial ("ANVZ@#");

		     buffer = prefix;

		     do i = 1 to length (line);
			if substr (line, i, 1) = " " then buffer = buffer || " ";
			else buffer = buffer || ANVZ_at_number;
		     end;

		     if data_len > max_label_chars then buffer = buffer || " /";
		     buffer = buffer || NEWLINE;

		     call iox_$put_chars (switch_ptr, addrel (addr (buffer), 1), length (buffer), code);

		     return;
		end line_proc;
	     end make_label;
	end;					/* begin block */
	
crump:	proc (code, reason);

dcl  code fixed bin (35) parameter,
     reason char (*) parameter;

	     call com_err_ (code, "make_volume_labels", reason);
	     goto returner;
	end crump;

returner:	return;
     end;




		    misc.pl1                        09/19/84  0911.6rew 09/18/84  0757.5       66141



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


misc: charge:  proc;

dcl  descn char (168) aligned,
    en char (32),
    (char8, char8a) char (8) aligned init (""),
    (date1, date2) fixed bin(71),
     instr char(28),
     pamt pic "(7)$v.99cr",
    (i, j, n) fixed bin,
     time fixed bin (71),
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     acredit bit(1) aligned init("1"b),
     amt float bin,
     proj char (12) aligned,
     pp ptr,
     (p1,p2 ) ptr,
     miscfilep ptr,
     ec fixed bin(35);

dcl (null, addr, rel, bin, fixed, dec, round, substr, verify, search) builtin;

dcl  movew(nmove) fixed bin based,
     (nmove, lomh, lome) fixed bin;

dcl  clock_ entry () returns (fixed bin (71)),
     get_wdir_ entry () returns (char (168)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     ioa_ entry options (variable),
     date_time_ entry (fixed bin (71), char (*) aligned),
     convert_date_to_binary_$relative entry(char(*),fixed bin(71), fixed bin(71), fixed bin(35)),
     com_err_ entry options (variable),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1),
     fixed bin (2), ptr, fixed bin(35)),
     hcs_$make_seg entry(char(*),char(*),char(*),fixed bin(5),ptr,fixed bin(35)),
     hcs_$terminate_noname entry (ptr, fixed bin(35)),
     hcs_$delentry_seg entry(ptr, fixed bin(35)),
     ask_$ask_clr entry options (variable),
     ask_$ask_flo entry options (variable),
     ask_$ask_int entry options (variable),
     ask_ entry options (variable),
     ask_$ask_line entry options (variable);


%include miscfile;

%include projfile;

/* ====================================================== */

	acredit="0"b;

credit:	entry;

	en = "projfile";
	call hcs_$initiate ((get_wdir_ ()), en, "", 0, 1, pp, ec);
	if pp = null then do;
er:	     call com_err_ (ec, "misc", en);
	     return;
	end;
	en = "miscfile";
	call hcs_$initiate ((get_wdir_ ()), en, "", 0, 1, miscfilep, ec);
	if miscfilep = null then go to er;

	time = clock_ ();

main1:	call ask_$ask_clr;
main:	call ask_ ("^/Project^-", proj);
	if proj = "x" then go to exit;

	do i = 1 to nproj;
	     if proj = id (i) then go to found;
	end;
	call ioa_ ("misc: project ""^a"" not in projfile.", proj);
	go to main1;

found:	/*  if off (i) ^= 0 then do;
	     call ioa_ ("misc: project ""^a"" has been deleted.", proj);
	     go to main1;
	end;  */
	call ask_$ask_flo ("amount^-", amt);

	call ask_$ask_line ("desc^-", descn);
	if descn = "x" then go to main;

	n_misc (i) = n_misc (i) + 1;
	if acredit then amt=-amt;
	misc_charges (i) = misc_charges (i) + amt;

	misc_ents = misc_ents + 1;
	j = misc_ents;

	mproj (j) = proj;
	mdate (j) = time;
	mamt (j) = amt;
	mdesc (j) = descn;

	go to main;

exit:	call hcs_$terminate_noname (miscfilep, ec);
	call hcs_$terminate_noname (pp, ec);

	return;

/* - - - - - - - - - - - - - - - - - - - - - - - - - */

print_misc: entry;

bug:	en = "x";
	en = "miscfile";
	call hcs_$initiate ((get_wdir_ ()), en, "", 0, 1, miscfilep, ec);
	if miscfilep = null then go to er;

mainp:	call ask_$ask_clr;
mainp1:	call ask_("^/Project^-", proj);
mainp2:	call ask_$ask_line("dates^-",instr);
	if instr="all"
	then do;
	     date1=mdate(1);
	     date2=mdate(misc_ents);
	     end;
	else do;
	     i=verify(instr,"/0123456789");
	     j=search(substr(instr,i+1),"0123456789")+i;
	     time=mdate(1)-86400000000;	/* make sure we get beginning of period */
	     call convert_date_to_binary_$relative(substr(instr,1,i-1)||" 0000.",date1,time,ec);
	     if ec^=0
	     then do;
		call ioa_("Illegal date ^a",substr(instr,1,i-1));
		go to mainp2;
		end;
	     if j>i
	     then call convert_date_to_binary_$relative(substr(instr,j)||" 2400.",date2,mdate(1),ec);
	     else date2=date1+86400000000;
	     if ec^=0
	     then do;
		call ioa_("Illegal date ^a",substr(instr,j));
		go to mainp2;
		end;
	     end;

	amt = 0.0e0;
	n=0;
	do i = 1 to misc_ents while(mdate(i)<=date2);
	     call date_time_ (mdate (i), char8);
	     if (proj="all"&mproj(i)^="")|proj=mproj(i)
	     then if mdate(i)>=date1
	          then do;
		     if char8 = char8a then char8 = "";
		     else char8a = char8;
		     pamt=round(fixed(dec(mamt(i)),14,8),2);		/* form picture representation */
		     call ioa_ ("^8a ^5d    ^12a ^12a ^a", char8, i, mproj (i), pamt, mdesc (i));
		     amt = amt + mamt (i);
		     n=n+1;
		     end;
	end;
	if n=0
	then call ioa_("No entries matching project and date");
	else if proj="all"&instr="all"
	     then do;
		pamt=round(fixed(dec(amt),14,8),2);		/* picture representation */
		call ioa_("^/Total:^24x ^12a^/^d entries in ""miscfile""",pamt,n);
		end;

	call hcs_$terminate_noname (miscfilep, ec);
	return;

/* ------------------------------------------ */

print_all_miscs:	entry;

	en = "miscfile";
	call hcs_$initiate ((get_wdir_ ()), en, "", 0, 1, miscfilep, ec);
	if miscfilep = null then go to er;

	amt = 0.0e0;
	n=0;
	do i = 1 to misc_ents;
	     if mproj(i)^=""
	     then do;
		call date_time_ (mdate (i), char8);
		if char8 = char8a then char8 = "";
		else char8a = char8;
		pamt=round(fixed(dec(mamt(i)),14,8),2);	/* form picture representation */
		call ioa_ ("^8a ^5d    ^12a ^12a ^a", char8, i, mproj (i), pamt, mdesc (i));
		amt = amt + mamt (i);
		n=n+1;
		end;
	     end;
	pamt=round(fixed(dec(amt),14,8),2);	/* picture representation */
	call ioa_("^/Total:^24x ^12a^/^d entries in ""miscfile""",pamt,n);
	call hcs_$terminate_noname (miscfilep, ec);
	return;

/* - - - - - - - - - - - - - */

reset_misc: entry;

	en = "projfile";
	call hcs_$initiate ((get_wdir_ ()), en, "", 0, 1, pp, ec);
	if pp = null then go to er;
	do i = 1 to nproj;
	     misc_charges (i) = 0.0e0;
	     n_misc (i) = 0;
	end;

	call hcs_$terminate_noname (pp, ec);
	return;

/* ------------------------------------------------------ */

dmisc:	entry;

	en = "projfile";
	call hcs_$initiate ((get_wdir_ ()), en, "", 0, 1, pp, ec);
	if pp=null then go to er;
	en = "miscfile";
	call hcs_$initiate ((get_wdir_ ()), en, "", 0, 1, miscfilep, ec);
	if miscfilep=null then go to er;


maind:	call ask_$ask_clr;
maind1:	call ask_("^/Project^-",proj);
	if proj="x" then go to exit;
	do i=1 to nproj;
	     if proj=id(i) then go to foundd;
	     end;
	call ioa_("misc: project ""^a"" not in projfile.",proj);
	go to maind;

foundd:	call ask_$ask_int("Number^-",j);
	if j>misc_ents|j<1
	then do;
	     call ioa_("Entry number ^d not in miscfile",j);
	     go to maind;
	     end;
	if mproj(j)=""&mamt(j)=0.0e0
	then do;
	     call ioa_("Entry number ^d has already been deleted",j);
	     go to maind;
	     end;
	if mproj(j)^=proj
	then do;
	     call ioa_("Entry number ^d not charged to project ^a",j,proj);
	     go to maind;
	     end;
	n_misc(i)=n_misc(i)-1;
	misc_charges(i)=misc_charges(i)-mamt(j);
	if n_misc(i)=0 then misc_charges(i)=0.0e0;
	mamt(j)=0;
	mproj(j)="";
	go to maind;

     end misc;




		    new_proj.pl1                    03/15/89  0840.1r w 03/15/89  0800.0      308133



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





/****^  HISTORY COMMENTS:
  1) change(86-09-25,Parisek), approve(87-06-17,MCR7570),
     audit(87-06-15,Hirneisen), install(87-08-06,MR12.1-1066):
     Make reusing a previously deleted project id optional by querying
     administrator for reuse. This enhances the security feature of reusing old
     project id's if this is not desirable.
                                                   END HISTORY COMMENTS */



/* format: style2 */
new_proj:
     procedure options (variable, separate_static);

/* NEW_PROJ - This program is used by User Accounts to add projects.

   THVV

   Modified by T. Casey, May 1978 to zero entire Nsate, as part of adding pdir_quota to sate.
   Modified by J. Bakal, July 1979 to add multiple rate structures.
   Modified by C. Hornig, March 1980, to check length of project name.
   Modified by J. N. R. Barnecut, April 1980 to default cutoff to midnight of day specified.
   Modified by E. N. Kittlitz, March 1982, to eliminate proj_admin_seg.
   Modified by E. N. Kittlitz, April 1982, to allow registration of anonymous users on projects
   Modified by E. N. Kittlitz, July 1982, call the pmf Project.pmf with the added name Project
   Modified 84-07-03 by BIM to remove added name on pmf, and query for dir
   quota, target LV, target access class, and target audit.
   Modified 1984-08-24 by E. Swenson for Version 2 PNT calling sequences.
   Modified 1984-09-13 by BIM to recognize when a request for a project
	  logical volume is not in fact a request for a master dir.
   Modified 1984-09-14 by BIM for mgtp passed to edit_proj_.
   Modified 1984-10-10 by E. Swenson to special case the ACLs on >udd>SysAdmin
      and on >udd>SysDaemon when creating these projects during a cold boot.
   Modified 1984-12-14 by EJ Sharpe to set project.audit to sys_admin_data
default.
   Modified 1984-12-27 by Keith Loepere for setting dir_quota at append.
   Modified 1985-01-02 by EJ Sharpe to create project dirs with owner and account if it is a master dir
*/

	dcl     dir_priv_code	 fixed bin (35) init (-1);
	dcl     dn		 char (168);
	dcl     en		 char (32);
	dcl     delegated		 bit (1) aligned;
	dcl     (i, j, k)		 fixed bin;
	dcl     bitct		 fixed bin (24);
	dcl     lvid		 bit (36) aligned;
	dcl     mylock		 bit (1) init ("0"b);
	dcl     ap		 ptr;
	dcl     al		 fixed bin (21);
	dcl     bchr		 char (al) unaligned based (ap);
	dcl     ec		 fixed bin (35);
	dcl     access		 bit (36) aligned;
	dcl     pubbit		 bit (1) aligned;
	dcl     TESTING		 bit (1) aligned init ("0"b);
	dcl     arg_count		 fixed bin;
	dcl     found_error		 bit (1) aligned;
	dcl     project_name	 char (32) varying;
	dcl     char16		 char (16);
	dcl     char168		 char (168);
	dcl     (char500, char500_2)	 char (500);
	dcl     pmf_dir		 char (168) init ("");
	dcl     pmf_en		 char (32);
	dcl     char32		 char (32);
	dcl     u			 (40) char (32);
	dcl     time		 fixed bin (71);
	dcl     rings		 (3) fixed bin (3) init ((3) 7);
	dcl     uid		 char (32);
	dcl     n_users		 fixed bin;
	dcl     project_dir_acc	 bit (72) aligned init (""b);
	dcl     project_dir_lv	 char (32);
	dcl     project_dir_owner	 char (32) init ("");	/* owner of a project master dir */
	dcl     project_dir_account	 char (32) init ("");	/* quota account of a project master dir */
	dcl     udd_acc		 bit (72) aligned;
	dcl     have_anonymous_user	 bit (1) aligned;

	dcl     USER_RING		 fixed bin (3) init (4) static options (constant);

	dcl     udd		 char (64) int static init (">user_dir_dir");
	dcl     sc1		 char (64) int static init (">system_control_1");

	dcl     pp		 ptr;		/* ptr to projfile */
	dcl     qp		 ptr;		/* ptr to reqfile */
	dcl     mgtp		 ptr;		/* ptr to mgt */
	dcl     satp		 ptr;		/* ptr to sat */
	dcl     protop		 ptr;		/* ptr to prototype pmf */
	dcl     protol		 fixed bin (21);	/* lth in chars */
	dcl     sadp		 ptr;		/* ptr to sys_admin_data */
	dcl     satep		 ptr;		/* ptr to sat entry. */
	dcl     projfile_ep		 ptr;		/* ptr to projfile entry */
	dcl     reqfile_ep		 ptr;		/* ptr to reqfile entry */
	dcl     (tp, ttp)		 ptr;
	dcl     sat_count		 fixed bin;
	dcl     projfile_count	 fixed bin;
	dcl     reqfile_count	 fixed bin;
	dcl     aim_check_$equal	 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed bin, fixed bin (35));
	dcl     set_lock_$unlock	 entry (bit (36) aligned, fixed bin (35));
	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$namedup	 fixed bin (35) ext;
	dcl     error_table_$locked_by_this_process
				 fixed bin (35) ext;
	dcl     error_table_$id_not_found
				 fixed bin (35) ext;
	dcl     error_table_$invalid_lock_reset
				 fixed bin (35) ext;


	dcl     (addr, after, before, byte, clock, divide, hbound, index,
		length, null, rtrim, string, substr, unspec, verify)
				 builtin;


	dcl     command_query_	 entry () options (variable);
	dcl     pnt_manager_$get_entry entry (character (*), pointer, fixed bin (35));
	dcl     datebin_$last_midnight entry (fixed bin (71));
	dcl     convert_date_to_binary_$relative
				 entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));
	dcl     cv_float_		 entry (char (*), fixed bin (35)) returns (float bin);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     get_wdir_		 entry () returns (char (168));
	dcl     get_group_id_	 entry () returns (char (32));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$rs		 entry options (variable);
	dcl     com_err_		 entry options (variable);
	dcl     convert_access_class_$from_string
				 entry (bit (72) aligned, character (*), fixed binary (35));
	dcl     convert_access_class_$to_string_short
				 entry (bit (72) aligned, character (*), fixed binary (35));
	dcl     expand_pathname_	 entry (character (*), character (*), character (*), fixed binary (35));
	dcl     sub_err_		 entry () options (variable);
	dcl     absolute_pathname_	 entry (character (*), character (*), fixed binary (35));
	dcl     mdc_$create_dirx_acct	 entry (char (*), char (*), char (*), pointer, char (*), char (*), fixed bin (35));
     	dcl     mdc_$get_lv_access	 entry (char (*), fixed bin (3), bit (36) aligned, bit (1) aligned, fixed bin (35));
	dcl     mdc_$find_lvid	 entry (char (*), bit (36) aligned, fixed bin (35));
	dcl     continue_to_signal_	 entry (fixed binary (35));
	dcl     edit_proj_		 entry (pointer);

	dcl     find_condition_info_	 entry (pointer, pointer, fixed binary (35));
     	dcl     get_ring_ 		 entry() returns(fixed bin(3));
	dcl     hcs_$add_acl_entries	 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$add_dir_acl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$add_dir_inacl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35));
	dcl     hcs_$create_branch_	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$chname_file	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$get_access_class	 entry (char (*), char (*), bit (72) aligned, fixed bin (35));
	dcl     initiate_file_	 entry (character (*), character (*), bit (*), pointer, fixed binary (24),
				 fixed binary (35));
	dcl     initiate_file_$create	 entry (character (*), character (*), bit (*), pointer, bit (1) aligned,
				 fixed binary (24), fixed binary (35));
	dcl     hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     (
	        system_privilege_$dir_priv_on,
	        system_privilege_$dir_priv_off
	        )			 entry (fixed bin (35));
	dcl     terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));

	dcl     bcs		 char (131071) based (tp);
	dcl     prototype_pmf	 char (protol) based (protop);

	dcl     1 CBI		 aligned like create_branch_info;
	dcl     1 EPA		 aligned like edit_proj_arg;
	dcl     1 Nsate		 aligned like project;
	dcl     1 Bprojfile		 aligned like projfile.projfiletab based;
	dcl     1 Nprojfile		 aligned like projfile.projfiletab;
	dcl     1 Breqfile		 aligned like reqfile.reqfiletab based;
	dcl     1 Nreqfile		 aligned like reqfile.reqfiletab;
	dcl     1 pnte		 aligned like pnt_entry automatic;

	dcl     LEGAL		 char (71) int static options (constant)
				 init
				 /* Legal chars for project ID. */ (
				 "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'_`^~/-abcdefghijklmnopqrstuvwxyz")
				 options (constant);

	declare 1 seg_acl_array	 (10) aligned like segment_acl_entry;
	declare 1 dir_acl_array	 (10) aligned like directory_acl_entry;
	declare cleanup		 condition;
	declare sub_error_		 condition;


	call cu_$arg_count (arg_count, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, "new_proj");
		return;
	     end;
	if arg_count = 0
	then do;
		call com_err_ (0, "new_proj", "Usage: new_proj ProjectName");
		return;
	     end;

	project_name = "";
	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, ap, al, (0));
	     if index (bchr, "-") ^= 1
	     then do;
		     if project_name ^= ""
		     then do;
			     call com_err_ (0, "new_proj",
				"Only one project name may be specified. ""^a"" is the second.", bchr);
			     call cleanup_segments;
			     return;
			end;
		     project_name = bchr;
		end;
	     else if bchr = "-debug"
	     then TESTING = "1"b;

	     else do;
		     call com_err_ (error_table_$badopt, "new_proj", """^a""", bchr);
		     return;
		end;
	end;

	if length (project_name) > 9
	then do;
		call com_err_ (0, "new_proj", "Project ID ^a longer then 9 characters.", project_name);
		return;
	     end;
	if verify (project_name, LEGAL) ^= 0
	then do;
		call com_err_ (0, "new_proj", "Illegal character in project ID ""^a""", project_name);
		return;
	     end;

	sadp, pp, qp, tp, ttp, protop, satp = null ();
	on cleanup call cleanup_segments;
	on sub_error_
	     begin;
		declare 1 CI		 aligned like condition_info;
		if TESTING
		then call continue_to_signal_ ((0));
		else do;
			CI.version = condition_info_version_1;
			call find_condition_info_ (null (), addr (CI), (0));
			sub_error_info_ptr = CI.info_ptr;
			call com_err_ (sub_error_info.status_code, "new_proj", "^a", sub_error_info.info_string);
			go to ERROR_EXIT;
		     end;
	     end;

	seg_acl_array (*).status_code, dir_acl_array (*).status_code = 0;
	dn = get_wdir_ ();
	en = "sys_admin_data";
	call initiate_file_ (dn, en, R_ACCESS, sadp, (0), ec);
	if ec ^= 0
	then go to er;
	call set_lock_$lock (sys_admin_data.lock, 60, ec);
	if ec ^= 0
	then if ec = error_table_$locked_by_this_process
	     then mylock = "1"b;
	     else if ec ^= error_table_$invalid_lock_reset
	     then do;
		     call com_err_ (ec, "new_proj", "Sys_admin_data is locked by ^a", sys_admin_data.locker);
		     call terminate_file_ (sadp, (0), TERM_FILE_TERM, (0));
		     return;
		end;

/* If sys_admin_data gets mashed, fix it up. */

	if sys_admin_data.default_proj_group < ""
	then do;
		sys_admin_data.default_proj_group = "Other";
		sys_admin_data.default_proj_grace = 2880;
		sys_admin_data.default_proj_ring1 = 4;
		sys_admin_data.default_proj_ring2 = 5;
		sys_admin_data.default_proj_attributes = "000010000111111110000000000000000000"b;
						/* anon,bumping,brief,vinitproc,vhomedir,nostart */
	     end;

	acl_count = 0;				/* start with none */
	uid = get_group_id_ ();

	en = "smf.cur.sat";
	call initiate_file_ (dn, en, RW_ACCESS, satp, (0), ec);
	if ec ^= 0
	then do;
er:
		call com_err_ (ec, "new_proj", en);
		go to abend;
	     end;
	do i = 1 to 2;				/* Put system admins on acls. */
	     if sat.system_admin (i) ^= ""
	     then do;
		     acl_count = acl_count + 1;
		     seg_acl_array (acl_count).access_name, dir_acl_array (acl_count).access_name =
			rtrim (sat.system_admin (i)) || ".*";
		     seg_acl_array (acl_count).mode = RW_ACCESS;
		     seg_acl_array (acl_count).extended_mode = ""b;
		     dir_acl_array (acl_count).mode = SMA_ACCESS;
		end;
	end;
	en = "projfile";
	call initiate_file_ (dn, en, RW_ACCESS, pp, (0), ec);
	if ec ^= 0
	then go to er;
	en = "reqfile";
	call initiate_file_ (dn, en, RW_ACCESS, qp, (0), ec);
	if ec ^= 0
	then go to er;
	en = "prototype_pmf";
	call initiate_file_ (dn, en, R_ACCESS, protop, bitct, ec);
	if ec ^= 0
	then go to er;
	protol = divide (bitct, 9, 17, 0);

	dn = sc1;
	en = "mgt";
	call initiate_file_ (dn, en, R_ACCESS, mgtp, (0), ec);
	if ec ^= 0
	then go to er;

	call expand_pathname_ (udd, dn, en, (0));
	call hcs_$get_access_class (dn, en, udd_acc, ec);
	if ec ^= 0
	then go to er;

	en = "";					/* clean err msg */
	unspec (Nsate) = ""b;			/* to avoid having to zero every new variable by name */


	call ioa_ ("Creating new project ""^a"".", project_name);

	Nsate.project_id = project_name;
	pmf_en = rtrim (Nsate.project_id) || ".pmf";

	sat_count = sat.current_size;
	reqfile_count = reqfile.nacts;
	projfile_count = projfile.nproj;
	satep, reqfile_ep, projfile_ep = null;

	do i = 1 to sat.current_size;
	     satep = addr (sat.project (i));
	     if Nsate.project_id = project.project_id
	     then if project.state = 1
		then do;
			call com_err_ (0, "new_proj", "Project ""^a"" is already registered.", Nsate.project_id);
			go to abend;
		     end;
		else if project.state = 2 | project.state = 3
		then do;
REUSE_PROJ:		char16 = get_input ("new_proj: Project " || rtrim(project.project_id) || " was previously deleted.  Do you wish to reuse it? ", "Just answer yes or no");
			if rtrim(char16) = "yes" | rtrim(char16) = "y" then goto check_req;
			else if rtrim(char16) = "no" | rtrim(char16) = "n" then goto abend;
			else do;
			     call ioa_ ("You must answer yes or no");
			     goto REUSE_PROJ;
			end;
		     end;
	end;
	sat_count = sat_count + 1;
	satep = addr (sat.project (sat_count));

check_req:
	do i = 1 to reqfile.nacts while (Nsate.project_id ^= reqfile.acctid (i));
	end;
	if i <= reqfile.nacts
	then if reqfile.qdf (i) = 0
	     then do;
		     call com_err_ (0, "new_proj", "Project ""^a"" is already in reqfile.", Nsate.project_id);
		     go to abend;
		end;
	     else ;				/* Returned. */
	else reqfile_count = reqfile_count + 1;
	reqfile_ep = addr (reqfile.reqfiletab (i));
	Nreqfile.acctid = Nsate.project_id;

	do i = 1 to projfile.nproj while (Nsate.project_id ^= projfile.id (i));
	end;
	if i <= projfile.nproj
	then if projfile.off (i) = 0
	     then do;
		     call com_err_ (0, "new_proj", "Project ""^a"" is already in projfile.", Nsate.project_id);
		     go to abend;
		end;
	     else ;				/* Returned. */
	else projfile_count = projfile_count + 1;
	projfile_ep = addr (projfile.projfiletab (i));
	Nprojfile.id = Nsate.project_id;

/* Clear the temporary data structures. */

	Nsate.state = 1;
	Nsate.project_dir = rtrim (udd) || ">" || Nsate.project_id;
	Nsate.pdt_ptr = null;
	Nsate.max_users = 32767;
	Nsate.n_users = 0;
	string (Nsate.at) = sys_admin_data.default_proj_attributes;
	do i = 1 to 4;
	     Nsate.admin (i).userid = "";
	     Nsate.admin (i).pad = "";
	end;
	Nsate.cutoff = "";
	Nsate.min_ring = sys_admin_data.default_proj_ring1;
	Nsate.max_ring = sys_admin_data.default_proj_ring2;
	Nsate.alias = "";
	Nsate.group = sys_admin_data.default_proj_group;
	Nsate.groups (1) = "";
	Nsate.groups (2) = "";
	Nsate.grace_max = sys_admin_data.default_proj_grace;
	Nsate.rs_number = 0;
	Nsate.audit = sys_admin_data.default_audit_flags;
	Nsate.project_authorization = ""b;

	Nsate.satpad = "0"b;
	Nsate.chain = 0;

	Nprojfile.title = "";
	Nprojfile.inv = "";
	Nprojfile.inv_addr = "";
	Nprojfile.sup = "";
	Nprojfile.sup_addr = "";
	Nprojfile.sup_phone = "";


	Nprojfile.on = clock ();
	Nprojfile.off = 0;
	Nprojfile.disk_psec = 0;
	Nprojfile.disk_quota = 100;
	Nprojfile.dir_disk_quota = 10;
	Nprojfile.disk_use = 0;
	Nprojfile.dir_disk_use = 0;
	Nprojfile.misc_charges = 0;
	Nprojfile.n_misc = 0;
	Nprojfile.processed = 0;

	Nreqfile.mitacct = "";
	Nreqfile.reqno = "";
	Nreqfile.req_amt = 0;			/* open ... */
	Nreqfile.qflag = "";
	Nreqfile.procssd = 0;
	Nreqfile.qdn = clock ();
	Nreqfile.qdf = 0;
	Nreqfile.billing_name = "";
	Nreqfile.billing_addr = "";
	Nreqfile.chg_mo = 0;
	Nreqfile.chg_tr = 0;
	call datebin_$last_midnight (time);
	call convert_date_to_binary_$relative ("+1year", Nreqfile.cutoff, time, (0));

	EPA.version = EDIT_PROJ_ARGS_V_2;
	EPA.caller = "new_proj";
	EPA.satep = addr (Nsate);
	EPA.projfile_ep = addr (Nprojfile);
	EPA.reqfile_ep = addr (Nreqfile);
	EPA.mgtp = mgtp;
	EPA.flags = "0"b;
	EPA.flags.all = "1"b;
	EPA.changes = "0"b;
	EPA.new_value.ptr, EPA.match_value.ptr = null ();

	call edit_proj_ (addr (EPA));

	delegated = "0"b;
	do i = 1 to 4;
	     if Nsate.admin (i).userid ^= ""
	     then delegated = "1"b;
	end;

	if delegated
	then do ec = -1 repeat ec while (ec ^= 0);
		char168 = get_input ("PMF directory", "Pathname of the directory to put the PMF into.");
		call absolute_pathname_ (char168, pmf_dir, ec);
		if ec ^= 0
		then call com_err_ (ec, "new_proj", "Illegal PMF directory: ""^a""", char168);
	     end;

	do ec = -1 repeat ec while (ec ^= 0);
GET_PROJ_DIR_LV:
	     project_dir_lv =
		get_input ("Project directory logical volume",
		"Logical volume on which segments under this project directory will reside. The default is to inherit the logical volume of >user_dir_dir."
		);
	     if project_dir_lv = ""
	     then ec = 0;				/* call hcs_, not mdc */
	     else do;
		     call mdc_$find_lvid (project_dir_lv, lvid, ec);
		     if ec ^= 0
		     then call com_err_ (ec, "new_proj", "Invalid logical volume name ""^a"".", project_dir_lv);
		     else if lvid = get_dir_lvid (udd)	/* mdc_ is not clever about creation of mdir that is not really an mdir */
		     then project_dir_lv = "";	/* so this filters out the easy case */
		     else do;	/* get owner and account for the master dir */
			call mdc_$get_lv_access (project_dir_lv, get_ring_ (), access, pubbit, ec);
			if ec ^= 0
			then do;
			     call com_err_ (ec, "new_proj", "Unable to check logical volume access.");
			     goto GET_PROJ_DIR_LV;
			end;
			else do;
			     if (access  & E_ACCESS) ^= E_ACCESS
			     then do;
				call com_err_ (0, "new_proj", "Process lacks executive access to LV ^a.", project_dir_lv);
				goto GET_PROJ_DIR_LV;
			     end;
			end;
GET_PROJ_DIR_OWNER:
			project_dir_owner = get_input ("Master directory owner",
			     "User ID of person to manage the project quota.  The default is your user_id.");
			if project_dir_owner ^= ""
			then if ^check_user_id_syntax$person_project (project_dir_owner)
			then do;
			     call com_err_ (0, "new_proj", "Illegal user_id format.");	
			     goto GET_PROJ_DIR_OWNER;
			end;
GET_PROJ_DIR_ACCT:
			project_dir_account = get_input ("Master directory account",
			     "Quota account where master directory will draw quota.  The default is the owner's account.");
			if project_dir_account ^= ""
			then if ^check_user_id_syntax$person_project_star (project_dir_account)
			then do;
			     call com_err_ (0, "new_proj", "Illegal quota account format.");
			     goto GET_PROJ_DIR_ACCT;
			end;

			/* now check for existance of the proper quota account */
/*TBD			Unfortunately the proper MDC entries don't exist which			/*TBD*/
/*TBD			would allow us to do this right.  We don't want to			/*TBD*/
/*TBD			try to mimic the quota account matching stuff here, so			/*TBD*/
/*TBD			the code is commented out until the appropriate interfaces			/*TBD*/
/*TBD			can be supplied.							/*TBD*/
/*TBD			if project_dir_account ^= ""						/*TBD*/
/*TBD			then if ^mdc_$find_account (project_dir_account)				/*TBD*/
/*TBD			     then do;							/*TBD*/
/*TBD				call com_err_ (0, "new_proj", "Quota account does not exist.");	/*TBD*/
/*TBD				goto GET_PROJ_DIR_ACCT;					/*TBD*/
/*TBD			     end;								/*TBD*/
/*TBD			     else; /*nothing*/						/*TBD*/
/*TBD			else if ^mdc_$find_matching_account (project_dir_owner)			/*TBD*/
/*TBD			     then do;							/*TBD*/
/*TBD				call com_err_ (0, "new_proj",					/*TBD*/
/*TBD				     "There is no quota account for the specified dir owner.");	/*TBD*/
/*TBD				goto GET_PROJ_DIR_OWNER;					/*TBD*/
/*TBD			     end;								/*TBD*/
/*TBD			     else; /*nothing*/						/*TBD*/
		     end;
		end;
	end;

	if unspec (Nsate.project_authorization) ^= ""b
	then do ec = -1 repeat ec while (ec ^= 0);
		char500 =
		     get_input ("Project directory access class",
		     "AIM access class marking for the project directory.");
		call convert_access_class_$from_string (project_dir_acc, char500, ec);
		if ec ^= 0
		then call com_err_ (ec, "new_proj", "Invalid project directory access class ""^a"".", char500);
	     end;

	call ioa_ ("Enter initial list of users. Type ""."" to exit");


	n_users = 0;
	have_anonymous_user = "0"b;
GET_USERS:
	do while ("1"b);

RE_GET_USER:
	     char32 = get_input (" Person", "Multics person-id of a user to be registered on this project.");
	     if char32 = ""
	     then go to GOT_USERS;
	     else if char32 = "."
	     then go to GOT_USERS;
	     else if char32 = "*"
	     then do;				/* anonymous */
		     if have_anonymous_user
		     then do;
			     call com_err_ (0, "new_proj", "Only one anonymous user may be supplied.");
			     go to RE_GET_USER;
			end;
		     have_anonymous_user = "1"b;
		     n_users = n_users + 1;
		     u (n_users) = "*";
		end;
	     else do;
		     if verify (char32, LEGAL) ^= 0
		     then do;
			     call com_err_ (0, "new_proj", "Illegal character in user id ""^a""", char32);
			     go to RE_GET_USER;
			end;
		     if index (rtrim (char32), " ") ^= 0
		     then do;
			     call ioa_ (0, "new_proj", "No spaces are permitted in user names. ""^a"" is invalid.",
				char32);
			     go to RE_GET_USER;
			end;
		     if index (substr (LEGAL, 11, 26), substr (char32, 1, 1)) = 0
		     then call com_err_ (0, "new_proj", "Warning: user name ""^a"" does not begin with a capital",
			     char32);
		     n_users = n_users + 1;
		     u (n_users) = char32;
		     call pnt_manager_$get_entry ((char32), addr (pnte), ec);
		     if ec = error_table_$id_not_found
		     then call com_err_ (0, "new_proj", "Warning: ^a is not registered.", char32);
		end;
GOT_A_USER:
	     if n_users = hbound (u, 1)
	     then do;
		     call com_err_ (0, "new_proj",
			"Limitation: only ^d users may be in the initial list. Add the rest to the PMF later.",
			hbound (u, 1));
		     go to GOT_USERS;
		end;
	end;
GOT_USERS:
	if n_users = 0
	then do;
		call com_err_ (0, "new_proj", "At least one user must be specified.");
		go to GET_USERS;
	     end;


	call ioa_ ("^/Input for ""^a"" complete.", Nsate.project_id);

/* Now add the data to the files. */

	project = Nsate;
	projfile_ep -> Bprojfile = Nprojfile;
	reqfile_ep -> Breqfile = Nreqfile;

/* Create project directory and set quota. */

	unspec (CBI) = ""b;
	CBI.version = create_branch_version_2;
	CBI.dir_sw = "1"b;
	CBI.parent_ac_sw = aim_check_$equal (project_dir_acc, udd_acc);
	CBI.mode = SMA_ACCESS;
	CBI.rings = rings;
	CBI.userid = get_group_id_ ();
	CBI.quota = Nprojfile.disk_quota;
	CBI.dir_quota = Nprojfile.dir_disk_quota;
	if ^CBI.parent_ac_sw
	then CBI.access_class = project_dir_acc;

	if project_dir_lv ^= ""
	then call mdc_$create_dirx_acct (udd, (Nsate.project_id),
		project_dir_lv, addr (CBI), project_dir_account, project_dir_owner, ec);
	else call hcs_$create_branch_ (udd, (Nsate.project_id), addr (CBI), ec);

	if ec ^= 0 & ec ^= error_table_$namedup
	then call sub_err_ (ec, "new_proj", ACTION_CANT_RESTART, null (), (0), "Call to create directory failed.");
	else if ec = error_table_$namedup
	then call com_err_ (ec, "new_proj", "Creating ^a>^a", udd, Nsate.project_id);

	if ^CBI.parent_ac_sw
	then call system_privilege_$dir_priv_on (dir_priv_code);
						/* Try to allow manipulations of upgraded dir. */

	if Nsate.alias ^= ""
	then do;
		call hcs_$chname_file (udd, (Nsate.project_id), "", (Nsate.alias), ec);
		if ec ^= 0
		then call com_err_ (ec, "new_proj", "Warning: Could not add alias ""^a"" to project directory ^a>^a.",
			Nsate.alias, udd, Nsate.project_id);
	     end;

/* Calculate ACLs for project dir, etc. */

	do i = 1 to 4;
	     if Nsate.admin (i).userid ^= ""
	     then do;
		     acl_count = acl_count + 1;
		     dir_acl_array (acl_count).access_name, seg_acl_array (acl_count).access_name =
			rtrim (Nsate.admin (i).userid) || ".*";
		     dir_acl_array (acl_count).mode = A_ACCESS;
						/* We are going to use it for >sc1>update */
		     seg_acl_array (acl_count).mode = R_ACCESS;
		     seg_acl_array (acl_count).extended_mode = ""b;
		end;
	end;
	acl_count = acl_count + 1;
	dir_acl_array (acl_count).access_name = "*." || rtrim (Nsate.project_id) || ".*";

	if Nsate.project_id = "SysAdmin" | Nsate.project_id = "SysDaemon"
	     then dir_acl_array (acl_count).mode = SMA_ACCESS;
	else dir_acl_array (acl_count).mode = S_ACCESS;	/*  for *.Project.* */

/* NOTE -- acl_count is one to big for the segment acl, and for >sc1>update */
/* since the *.Project.* should not go on sc1>update */

/* Set ACL of >sc1>update. */

	if acl_count > 1				/* We have project administrator acls to add */
	then do;
		call hcs_$add_dir_acl_entries (sc1, "update", addr (dir_acl_array), acl_count - 1, ec);
		found_error = "0"b;
		if ec ^= 0
		then do i = 1 to acl_count - 1;
			if dir_acl_array (i).status_code ^= 0
			then do;
				call com_err_ (dir_acl_array (i).status_code, "new_proj",
				     "Warning: Could not set acl of ^a>^a for ^a", sc1, "update",
				     dir_acl_array (i).access_name);
				found_error = "1"b;
			     end;
		     end;
		if ec ^= 0 & ^found_error
		then call com_err_ (ec, "new_proj", "Warning: Could not set acl of ^a>^a.", sc1, "update");
	     end;

/* Set ACL of Project Directory. */

	do i = 1 to acl_count - 1;			/* Give proj admin SMA on proj dir. */
						/* -1 dodges the *.Project.* term */
	     if dir_acl_array (i).mode ^= SMA_ACCESS
	     then dir_acl_array (i).mode = SMA_ACCESS;
	end;
	call hcs_$add_dir_acl_entries (udd, (Nsate.project_id), addr (dir_acl_array), acl_count, ec);
	found_error = "0"b;
	if ec ^= 0
	then do i = 1 to acl_count;
		if dir_acl_array (i).status_code ^= 0
		then do;
			found_error = "1"b;
			call com_err_ (dir_acl_array (i).status_code, "new_proj",
			     "Warning: Could set acl of ^a>^a for ^a", udd, Nsate.project_id,
			     dir_acl_array (i).access_name);
		     end;
	     end;
	if ec ^= 0 & ^found_error
	then call com_err_ (ec, "new_proj", "Warning: Could not set acl of ^a>^a.", udd, Nsate.project_id);


/* Set initial dir ACL of project dir same as project dir ACL. */

	call hcs_$add_dir_inacl_entries (udd, (Nsate.project_id), addr (dir_acl_array), acl_count, USER_RING, ec);
	found_error = "0"b;
	if ec ^= 0
	then do i = 1 to acl_count;
		if dir_acl_array (i).status_code ^= 0
		then do;
			call com_err_ (dir_acl_array (i).status_code, "new_proj",
			     "Warning: Could not set initial acl of ^a>^a for ^a", udd, Nsate.project_id,
			     dir_acl_array (i).access_name);
			found_error = "1"b;
		     end;
	     end;
	if ec ^= 0 & ^found_error
	then call com_err_ (ec, "new_proj", "Warning: Could not set dir initial acl of ^a>^a.", udd, Nsate.project_id);

/* Create initial PMF */

	dn = get_wdir_ ();
	en = pmf_en;
	call initiate_file_$create (dn, pmf_en, RW_ACCESS, tp, ("0"b), (0), ec);
	if ec ^= 0
	then call sub_err_ (ec, "new_proj", ACTION_CANT_RESTART, null (), (0), "Could not create PMF ^a>^a.", dn,
		pmf_en);

	call ioa_$rs ("Projectid:^-^a;", char168, j, Nsate.project_id);
	substr (bcs, 1, j) = substr (char168, 1, j);

	substr (bcs, j + 1, protol) = prototype_pmf;
	j = j + protol + 1;
	if Nsate.project_authorization (1) ^= ""b	/* start them off at min */
	then do;
		call convert_access_class_$to_string_short (Nsate.project_authorization (1), char500, (0));
		call ioa_$rs ("Authorization:^-""^a"";", char500_2, k, rtrim (char500));
		substr (bcs, j, k) = substr (char500_2, 1, k);
		j = j + k;
	     end;
	do i = 1 to n_users;
	     call ioa_$rs ("personid:^-^-^a;", char168, k, u (i));
	     substr (bcs, j, k) = substr (char168, 1, k);
	     j = j + k;
	end;
	substr (bcs, j, 5) = "end;
";
	j = j + 4;


	if pmf_dir ^= ""				/* create copy of pmf for project administrators */
	then do;
		call initiate_file_$create (pmf_dir, pmf_en, RW_ACCESS, ttp, "0"b, (0), ec);
		if ec ^= 0
		then do;
			call com_err_ (ec, "new_proj", "Warning: Could not create pmf ^a.pmf in ^a",
			     Nsate.project_id, pmf_dir);
			go to SKIP_PMF;
		     end;

		do i = 1 to acl_count - 1;
		     if seg_acl_array (i).mode = R_ACCESS
		     then seg_acl_array (i).mode = RW_ACCESS;
		end;
		call hcs_$add_acl_entries (pmf_dir, pmf_en, addr (seg_acl_array), acl_count - 1, ec);
		found_error = "0"b;
		if ec ^= 0
		then do i = 1 to acl_count - 1;
			if seg_acl_array (i).status_code ^= 0
			then do;
				found_error = "1"b;
				call com_err_ (seg_acl_array (i).status_code, "new_proj",
				     "Warning: Could not set acl of ^a>^a for ^a", pmf_dir, pmf_en,
				     seg_acl_array (i).access_name);
			     end;
		     end;
		if ec ^= 0 & ^found_error
		then call com_err_ (ec, "new_proj", "Warning: Could not set acl of ^a>^a.", pmf_dir, pmf_en);

		substr (ttp -> bcs, 1, j) = substr (bcs, 1, j);
						/* copy the pmf */
		call terminate_file_ (ttp, 9 * j, TERM_FILE_TRUNC_BC_TERM, (0));
	     end;
SKIP_PMF:
	call terminate_file_ (tp, 9 * j, TERM_FILE_TRUNC_BC_TERM, (0));

/* Increase counts in head of data bases */

	reqfile.nacts = reqfile_count;
	projfile.nproj = projfile_count;
	sat.current_size = sat_count;

/* Terminate all segments. */

ERROR_EXIT:
abend:
	call cleanup_segments;
	return;


cleanup_segments:
     procedure;

	if dir_priv_code = 0
	then call system_privilege_$dir_priv_off (dir_priv_code);
	if pp ^= null ()
	then call terminate_file_ (pp, 36 * (loph + projfile.nproj * lope), TERM_FILE_TRUNC_BC_TERM, (0));
	if qp ^= null ()
	then call terminate_file_ (qp, 36 * (loqh + reqfile.nacts * loqe), TERM_FILE_TRUNC_BC_TERM, (0));
	if satp ^= null ()
	then call terminate_file_ (satp, 36 * (SAT_header_lth + sat.current_size * SAT_entry_lth),
		TERM_FILE_TRUNC_BC_TERM, (0));
	if protop ^= null ()
	then call terminate_file_ (protop, (0), TERM_FILE_TERM, ec);
	if sadp ^= null ()
	then do;
		if ^mylock
		then call set_lock_$unlock (sys_admin_data.lock, ec);
		call terminate_file_ (sadp, (0), TERM_FILE_TERM, (0));
	     end;
     end cleanup_segments;

/* -------------------------------------------------------- */

get_input:
     procedure (prompt, explanation) returns (char (*));

	declare prompt		 char (*);
	declare buf		 character (1000);
	declare explanation		 char (*);
%include query_info;

	query_info.version = query_info_version_6;
	query_info.yes_or_no_sw = "0"b;
	query_info.suppress_name_sw = "1"b;
	query_info.suppress_spacing = "1"b;
	query_info.literal_sw = "0"b;
	query_info.prompt_after_explanation = "1"b;
	query_info.explanation_ptr = addr (explanation);
	query_info.explanation_len = length (rtrim (explanation));

	call command_query_ (addr (query_info), buf, "new_proj", "^a:^25t", prompt);
	if buf = "stop"
	then go to abend;
	return (rtrim (rtrim (buf), byte (10)));

     end get_input;


get_dir_lvid:
     procedure (dir) returns (bit (36) aligned);

	dcl     dir		 char (*);
	dcl     dir_dn		 char (168);
	dcl     dir_en		 char (32);
	dcl     1 status		 aligned like status_branch automatic;

	call expand_pathname_ (dir, dir_dn, dir_en, ec);
	if ec ^= 0
	then call sub_err_ (ec, "new_proj", ACTION_CANT_RESTART, null (), (0),
		"Failed to expand pathname ^a in get_dir_lvid.", dir);
	status_ptr = addr (status);
	call hcs_$status_long (dir_dn, dir_en, (1), addr (status), null (), ec);
	if ec ^= 0
	then call sub_err_ (ec, "new_proj", ACTION_CANT_RESTART, null (), (0),
		"Failed to get status_long for ^a in get_dir_lvid.", dir);
	return (status.lvid);
     end get_dir_lvid;

/* -------------------------------------------------- */

check_user_id_syntax:  procedure (userid) returns (bit (1));

dcl	userid		char (*) parameter;
dcl	project_required	bit (1);
dcl	star_ok		bit (1);
dcl	(person, project)	char (32) varying;


	project_required = "0"b;
	star_ok = "0"b;
	goto join;

check_user_id_syntax$person_project: entry (userid) returns (bit(1)); /* requires Person.Project */

	project_required = "1"b;
	star_ok = "0"b;
	goto join;
	
check_user_id_syntax$person_project_star: entry (userid) returns (bit(1)); /* requires Person.Project but allows "*" for either */

	project_required = "1"b;
	star_ok = "1"b;
	goto join;

join:
	if length(rtrim(userid)) > 32
	then return ("0"b);

	if userid = ""
	then return ("0"b);

	person = before (userid, ".");
	if person = ""
	then return ("0"b);
	if length(person) > 22
	then return ("0"b);
	if person = "*" & ^star_ok
	then return ("0"b);

	project = rtrim(after(userid, "."));
	if project = ""
	then return ("0"b);
	if length(project) > 9
	then return ("0"b);
	if project = "*" & ^star_ok
	then return ("0"b);

	return ("1"b);

end check_user_id_syntax;


test:
     entry (asc1, audd);
	dcl     (asc1, audd)	 char (*);

	call absolute_pathname_ (asc1, sc1, (0));
	call absolute_pathname_ (audd, udd, (0));
	call ioa_ ("udd = ^a^/sc1 = ^a", udd, sc1);
	return;

/* -------------------------------------------------- */

%include edit_proj_arguments_;
%include user_attributes;
%include sys_admin_data;
%include projfile;
%include reqfile;
%include sat;
%include create_branch_info;
%include acl_structures;
%include terminate_file;
%include access_mode_values;
%include condition_info_header;
%include sub_error_info;
%include condition_info;
%include status_structures;
%include sub_err_flags;
%include pnt_entry;

     end new_proj;




		    new_user.pl1                    08/05/87  0804.2r   08/04/87  1540.2      387558



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



/****^  HISTORY COMMENTS:
  1) change(86-08-04,Parisek), approve(86-10-02,MCR7541),
     audit(86-10-14,Martinson), install(86-10-15,MR12.0-1186):
     Set the date/time password was changed in the PNT entry.
  2) change(86-08-04,Parisek), approve(86-10-02,MCR7541),
     audit(86-10-14,Martinson), install(86-10-15,MR12.0-1186):
     Bypasses mail table updates if items to be changed do not effect the mail
     table.
  3) change(86-08-06,Parisek), approve(86-10-02,MCR7541),
     audit(86-10-14,Martinson), install(86-10-15,MR12.0-1186):
     In the event of a linkage_error,  a cleaner error message is printed
     before termination.
  4) change(86-08-06,Parisek), approve(86-10-02,MCR7541),
     audit(86-10-14,Martinson), install(86-10-15,MR12.0-1186):
     Leave "notes" in URF as is,  if null string ("") is input to "Notes:"
     query.  To delete notes input of "." is needed.  This makes the null
     string and period (".") input consistent with the same responses of
     other field queries.
                                                   END HISTORY COMMENTS */


/* format: style4 */
new_user: procedure options (separate_static, variable);

/* new_user: define new users and put in the PNT and URF */
/* Rewritten July 1979 by C. Hornig */
/* Modified August 1980 by J. N. R. Barnecut to process notes. */
/* Modified September 1982 by E. N. Kittlitz to reject reserved passwords. */
/* Modified October 1982 by J. I. Schiller to add -no_password_info and
   -password_info to print_pnt, fixed new_user$nua to check if an alias
   is in use before prompting for any additional information (which it
   would have to throw away if the alias is in use). also fixed it to
   verify that user_id's only have valid characters in them */
/* Modified July 1983 by B. Margolin to update the Mail Table when
   Person_ids and aliases are registered or changed, and to check Person_ids
   and aliases against the Mail Table before allowing them to be assigned. */
/* Modified August 1983 by B. Margolin to allow aliases to be deleted and to
   use a larger character string for the audit flags. */
/* Modified 1984-09-14 by E. Swenson for Version 2 PNT interface.
   The new format supports a login authorization range and is
   specified as min_auth:max_auth.  The keyword "network_pw" is now
   used to describe the network_password (formerly the card input
   password.  The keyword "card_pw" is a synonym for "network_pw"
   for compatibility. */
/* Modified 84-09-25 for "operator" attribute... -E. A. Ranzenbach */
/* Modified 84-12-14 by EJ Sharpe for new audit flags, init set_password and set_network_password */
/* Modified 85-03-05 by E. Swenson for user revalidation */

declare  pp pointer init (null ());			/* projfile pointer */
declare  sadp pointer init (null ());			/* sys_admin_data pointer */
declare  sadir character (168) init (">udd>SysAdmin>admin") internal static;

/* Constant */

dcl  sysdir char (168) initial (">system_control_1") internal static options (constant);
	

/* External Static */

dcl  error_table_$bad_arg fixed bin (35) external static;
dcl  error_table_$bad_index fixed bin (35) external static;
dcl  error_table_$checksum_failure fixed bin (35) external static;
dcl  error_table_$id_not_found fixed bin (35) external static;
dcl  error_table_$inconsistent fixed bin (35) external static;
dcl  error_table_$long_record fixed bin (35) external static;
dcl  error_table_$moderr fixed bin (35) external static;
dcl  error_table_$no_record fixed bin (35) external static;
dcl  mlsys_et_$ambiguous_address fixed bin (35) external static;

declare  iox_$user_input pointer external static;

/* External Entries */

dcl  check_password_ entry (char (*), char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  command_query_ entry () options (variable);
dcl  convert_access_audit_flags_$from_string entry (char (*), bit (36) aligned, fixed bin (35));
dcl  convert_access_audit_flags_$edit_from_string entry (char (*), bit (36) aligned, fixed bin (35));
dcl  convert_access_audit_flags_$to_string entry (bit (36) aligned, char (*), fixed bin (35));
dcl  convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  ioa_ entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  mail_table_$get entry (char (*) varying, ptr, char (*), fixed bin (35));
dcl  mail_table_priv_$add entry (ptr, bit (1), fixed bin (35));
dcl  mail_table_priv_$add_alias entry (char (*) varying, char (*) varying, bit (1), fixed bin (35));
dcl  mail_table_priv_$delete_alias entry (char (*) varying, bit (1), fixed bin (35));
dcl  mail_table_priv_$get entry (char (*) varying, ptr, fixed bin (35));
dcl  mail_table_priv_$update entry (ptr, bit (1), fixed bin (35));
dcl  mail_table_priv_$test entry (char (*));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  pnt_admin_gate_$add_entry entry (character (*), pointer, fixed bin (35));
dcl  pnt_admin_gate_$get_entry entry (character (*), pointer, fixed bin (35));
dcl  pnt_manager_$get_abs_entry entry (fixed bin (35), pointer, fixed bin (35));
dcl  pnt_manager_$get_entry entry (character (*), pointer, fixed bin (35));
dcl  pnt_manager_$add_entry entry (character (*), pointer, fixed bin (35));
dcl  pnt_manager_$test entry (char (*));
dcl  pnt_manager_$update_entry entry (ptr, bit (1), bit (1), fixed bin (35));
dcl  read_password_ entry (char (*), char (*));
dcl  scramble_ entry (char (8)) returns (char (8));
dcl  urf_manager_$test entry (char (*));
dcl  urf_manager_$get_entry entry (character (*), pointer, fixed bin (35));
dcl  urf_manager_$add_entry entry (character (*), pointer, fixed bin (35));
dcl  urf_manager_$update_entry entry (character (*), pointer, pointer, fixed bin (35));
dcl  entry_var entry variable;

/* Automatic */

declare
         1 (pnte, old_pnte, alias_pnte) aligned like pnt_entry,
         1 (urfe, old_urfe) aligned like urf_entry,
         1 mte aligned like mail_table_entry,
         uid character (32) aligned,
         ap pointer,
         al fixed bin (21),
         argument character (al) based (ap),
         rec fixed bin (35),
         line character (256) aligned,
         code fixed bin (35),
         initial character,
         (loud, alias_allowed, arg_given, changing) bit aligned;
dcl  ip ptr initial (null ());			/* pointer to installation_parms */
dcl  set_network_password bit (1) init ("0"b);		/* Whether we need to change this */
dcl  set_password bit (1) init ("0"b);			/* Whether we need to change this */
dcl  what char (12);
dcl  whoami char (32) automatic;
	

declare  (addr, clock, index, length, min, null, rtrim, search, substr,
         unspec, verify) builtin;

declare  clean_up condition;
declare  new_user_stop condition;
declare  linkage_error condition;
	

/* * * * * * * * * * NEW_USER * * * * * * * * * */

	loud = "1"b;
	alias_allowed = "0"b;
	goto common;

/* * * * * * * * * * NU * * * * * * * * * */

nu:  entry options (variable);

	loud, alias_allowed = "0"b;
	goto common;

/* * * * ** * * * * * NUA * * * * * * * * * */

nua: entry options (variable);

	loud = "0"b;
	alias_allowed = "1"b;

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

common:
	whoami = "new_user";
	arg_given, changing = "0"b;
	on clean_up call cleaner;
	call initialize ();
	on new_user_stop goto stop_given;
	on linkage_error begin;
	     code = error_table_$moderr;
	     goto NO_ACCESS_TO_GATE;
	end;
	entry_var = pnt_admin_gate_$add_entry;
	revert linkage_error;
add_user:
	unspec (pnte) = ""b;
	pnte.version = PNT_ENTRY_VERSION_2;
	pnte.audit = sys_admin_data.default_audit_flags;

	if loud then call ioa_ ("^/Enter full user name (Last, First I.)");
	call read_name;
	if loud then call ioa_ ("^/Enter mailing address");
	call read_address;
	if loud then call ioa_ ("^/Enter programmer number");
	call read_prog_number;
	if loud then call ioa_ ("^/Enter notes");
	call read_notes;
	if loud then call ioa_ ("^/Enter default project");
	call read_project;
	pnte.alias = "";
	if alias_allowed then do;
	     if loud then call ioa_ ("^/Enter alias");
	     call read_alias;
	     if loud then call ioa_ ("^/User registration flags:");
	     call read_flags;
	     if loud then call ioa_ ("^/User authorization range:");
	     call read_authorization_range (pnte.person_authorization);
	     if loud then call ioa_ ("Default user authorization:");
	     call read_default_authorization (pnte.default_person_authorization);
	     if loud then call ioa_ ("^/Audit flags:");
	     call read_audit;
	end;

	call read_password ("Password:", pnte.private.password, pnte.public.flags.has_password, pnte.private.pw_flags.short_pw, ("0"b));

	call read_password ("Network Password:", pnte.private.network_password, pnte.public.flags.has_network_password, pnte.private.pw_flags.short_network_pw, ("0"b));

	if substr (urfe.last_name, 1, 1) = "*" then goto ask_uid;
	if ^uid_exists (urfe.last_name) then goto got_uid;
	if initial ^= "" then if ^uid_exists (substr (urfe.first_name, 1, 1) || initial || urfe.last_name) then goto got_uid;
	if ^uid_exists (substr (urfe.first_name, 1, 1) || urfe.last_name) then goto got_uid;
ask_uid:
	call ioa_ ("^/Please suggest a user ID for ""^a, ^a""", urfe.last_name, urfe.first_name);
read_uid:
	call read_line ("userid^-");
	if line = "" then goto read_uid; else uid = rtrim(line);
	if uid_exists (uid) then goto read_uid;

got_uid:
	call ioa_ ("^/User ID assigned is ""^a"".", uid);
	if ^yes_no ("Is this OK? ") then goto read_uid;

	pnte.user_id = uid;
	pnte.bad_pw_term_id, pnte.bad_pw_term_type = "";

	pnte.user_validated_time = clock ();		/* indicate validated */
	call pnt_manager_$add_entry ((uid), addr (pnte), code);
	if code ^= 0 then do;
	     call com_err_ (code, whoami, "Updating PNT.");
	     goto stop_given;
	end;
	call urf_manager_$add_entry ((uid), addr (urfe), code);
	if code ^= 0 then
	     call com_err_ (code, whoami, "Updating URF.");

	mte.version = MAIL_TABLE_ENTRY_VERSION_1;
	mte.name = rtrim (uid);
	mte.default_project = rtrim (pnte.default_project);
	mte.mailing_address = "";
	mte.acs_path.dir, mte.acs_path.entry = "";
	call mail_table_priv_$add (addr (mte), "1"b, code);
	if code ^= 0 then
	     call com_err_ (code, whoami, "Updating MAIL_TABLE.");

	if pnte.alias ^= "" then do;
	     call mail_table_priv_$add_alias (rtrim (uid), rtrim (pnte.alias), "1"b, code);
	     if code ^= 0 then
		call com_err_ (code, whoami, "Updating MAIL_TABLE.");
	end;

stop_given:
	if yes_no ("^/More users to add? ") then goto add_user;

RETURN_TO_CALLER:

	call cleaner;

	return;

/* * * * * * * * * * CHANGE * * * * * * * * * */

change: entry options (variable);

	alias_allowed = "0"b;
	loud = "1"b;

cg:  entry options (variable);

	alias_allowed, loud = "0"b;
	goto change_common;

cga: entry options (variable);

	loud = "0"b;
	alias_allowed = "1"b;

change_common:
	whoami = "new_user$change";

/**** Initialize these for cleanup handler */
	pp = null ();
	sadp = null ();
	ip = null ();
	on clean_up
	     call cleaner;

	call initialize ();
	arg_given = "0"b;
	changing = "1"b;
	uid, what, line = "";
	call cu_$arg_ptr (1, ap, al, code);
	if code = 0 then do;
	     uid = argument;
	     call cu_$arg_ptr (2, ap, al, code);
	     if code = 0 then do;
		what = argument;
		call cu_$arg_ptr (3, ap, al, code);
		if code = 0 then do;
		     line = argument;
		     arg_given = "1"b;
		end;
	     end;
	end;
	on new_user_stop goto RETURN_TO_CALLER;

	on linkage_error begin;
	     code = error_table_$moderr;
	     goto NO_ACCESS_TO_GATE;
	end;
	entry_var = pnt_admin_gate_$get_entry;
	revert linkage_error;

	if uid = "" then do;
read_cg_uid:   line = "";
	     call read_line ("User ID^-^-");
	     uid = rtrim(line);
	end;
	call pnt_manager_$get_entry ((uid), addr (old_pnte), code);
	if code ^= 0 then do;
	     call com_err_ (code, whoami, "Searching PNT for ^a.", uid);
	     goto read_cg_uid;
	end;
	uid = old_pnte.user_id;
	call urf_manager_$get_entry ((uid), addr (old_urfe), code);
	if code ^= 0 then do;
	     call com_err_ (code, whoami, "Searching URF for ^a.", uid);
	     goto read_cg_uid;
	end;

	urfe = old_urfe;
	pnte = old_pnte;

	if what ^= "" then do;			/* if item name given, see if it is legal */

/* These declarations are here so that anyone who adds change items to
   the list of "if" statements below will see that the item name must
   be added in two places. */

dcl  change_items char (54) int static options (constant) init
	("name,addr,progn,notes,proj,pass,cpass,npass,revalidate");
dcl  cga_items char (47) int static options (constant) init
	("alias,flags,auth,dfauth,audit");

	     if index (change_items, rtrim (what)) ^= 0 then
		goto change_item_ok;
	     if alias_allowed then
		if index (cga_items, rtrim (what)) ^= 0 then
		     goto change_item_ok;
	     call com_err_ (0, whoami, "Illegal change item ""^a"". Must be one of:^/^a^[,^a^].",
		what, change_items, alias_allowed, cga_items);
	     goto RETURN_TO_CALLER;
	end;
change_item_ok:

	if what = "" | what = "name" then call read_name;
	if what = "" | what = "addr" then call read_address;
	if what = "" | what = "progn" then call read_prog_number;
	if what = "" | what = "notes" then call read_notes;
	if what = "" | what = "proj" then call read_project;
	if (what = "" | what = "alias") & alias_allowed then
	     call read_alias;
	if what = "" | what = "pass" then
	     do;
	     call read_password ("Password", pnte.private.password,
		pnte.public.flags.has_password,
		pnte.private.pw_flags.short_pw, set_password);
	                                               /* Don't forget to update date/time password was changed. */
	     if set_password then pnte.public.time_pw_changed = clock ();
	end;
	if what = "" | what = "cpass" | what = "npass" then
	     call read_password ("Network Password",
		pnte.private.network_password,
		pnte.public.flags.has_network_password,
		pnte.private.pw_flags.short_network_pw,
		set_network_password);
	if alias_allowed then do;
	     if what = "" | what = "flags" then call read_flags;
	     if what = "" | what = "auth" then
		call read_authorization_range (pnte.person_authorization);
	     if what = "" | what = "dfauth" then
		call read_default_authorization (pnte.default_person_authorization);
	     if what = "" | what = "audit" then call read_audit;
	     if what = "" | what = "revalidate" then
		call REVALIDATE_USER ();
	end;

	call urf_manager_$update_entry ((uid), addr (old_urfe), addr (urfe),
	     code);
	if code ^= 0 then
	     call com_err_ (code, whoami, "Updating URF entry.");

	call pnt_manager_$update_entry (addr (pnte), set_password,
	     set_network_password, code);
	if code ^= 0 then
	     call com_err_ (code, whoami, "Updating PNT entry.");

	                                               /* Updating the mail table is not nessesary with some change items. */
	if what = "name" | what = "addr" | what = "proj" | what = "alias" then do;
	     mte.version = MAIL_TABLE_ENTRY_VERSION_1;
	     call mail_table_priv_$get (rtrim (uid), addr (mte), code);
	     if code = 0 then do;
		mte.default_project = rtrim (pnte.default_project);
		call mail_table_priv_$update (addr (mte), "1"b, code);
		if code ^= 0 then call com_err_ (code, whoami, "Updating Mail Table.");
		if pnte.alias ^= old_pnte.alias then do;
		     if pnte.alias = "" then do;		/* Delete the alias */
			call mail_table_priv_$delete_alias (rtrim (old_pnte.alias), "1"b, code);
			if code ^= 0 then call com_err_ (code, whoami, "Deleting the alias from the Mail Table.");
			else do;
			     call mail_table_priv_$add_alias (rtrim (uid), rtrim (old_pnte.alias), "0"b, code);
			     if code ^= 0 then
				call com_err_ (code, whoami, "Adding the alias back to the Mail Table.");
			end;
		     end;
		     else do;
			call mail_table_priv_$add_alias (rtrim (uid), rtrim (pnte.alias), "1"b, code);
			if code ^= 0 then call com_err_ (code, whoami, "Adding new alias to Mail Table.");
		     end;
		end;
	     end;
	     else call com_err_ (code, whoami, "Retrieving Mail Table entry.");
	end;

	goto RETURN_TO_CALLER;
%page;
print_pnt:
     entry options (variable);

/**** This entry implements the command to display the contents of a
      user's PNT entry (or those of all users). */

declare  (nargs, i) fixed bin,
         (print_urf, print_all, password_info_set,
         no_password_info) bit aligned;

	whoami = "print_pnt";
	print_urf = "1"b;
	print_all = "1"b;
	changing = "0"b;
	call cu_$arg_count (nargs, code);
	if code ^= 0 then goto RETURN_TO_CALLER;
	on linkage_error begin;
	     code = error_table_$moderr;
	     goto NO_ACCESS_TO_GATE;
	end;
	entry_var = pnt_admin_gate_$get_entry;
	revert linkage_error;

	password_info_set = "0"b;
	no_password_info = "0"b;			/* Give the password info by default */
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, ap, al, code);
	     if /* case */ argument = "-brief" | argument = "-bf" then print_urf = "0"b;
	     else if argument = "-password_info" | argument = "-no_password_info" then do;
		if password_info_set then do;
		     call com_err_ (error_table_$inconsistent,
			whoami, "-password_info and -no_password_info cannot both appear on a command line");
		     return;
		end;
		if argument = "-no_password_info" then no_password_info = "1"b;
		password_info_set = "1"b;
	     end;
	     else if substr (argument, 1, 1) = "-" then do;
		call com_err_ (error_table_$bad_arg, whoami,
		     "^a", argument);
		return;
	     end;
	     else print_all = "0"b;
	end;

	if ^print_all then do i = 1 to nargs;
	     call cu_$arg_ptr (i, ap, al, code);
	     if substr (argument, 1, 1) ^= "-" then do;
		uid = argument;
		call pnt_manager_$get_entry ((uid), addr (pnte), code);
		if code ^= 0 then do;
		     call com_err_ (code, whoami, "Reading PNT entry of ^a.", uid);
		     return;
		end;
		call print_it;
	     end;
	end;
	else do rec = 1 by 1;
	     call pnt_manager_$get_abs_entry (rec, addr (pnte), code);
	     if code = 0 then call print_it;
	     else if code = error_table_$checksum_failure
	     then call com_err_ (code, whoami, "Checksum failure on record ^d.", rec);
	     else if code ^= error_table_$no_record then do;
		if code ^= error_table_$bad_index
		then call com_err_ (code, whoami, "Reading from PNT.");
		return;
	     end;
	end;
	return;
%page;
print_it:
     procedure ();

/**** This procedure displays a single PNT entry. */

dcl  purf bit aligned;

	if print_urf then do;
	     call urf_manager_$get_entry ((pnte.user_id), addr (urfe), code);
	     purf = (code = 0);
	end;
	else purf = "0"b;

	call ioa_ ("^/User ID:^-^-^a", pnte.user_id);
	if purf then do;
	     call print_name;
	     call print_address;
	     call print_prog_number;
	     call print_notes;
	end;
	call print_project;
	call print_alias;
	call print_flags;
	call print_authorization_range (pnte.person_authorization);
	call print_default_authorization (pnte.default_person_authorization);
	call print_audit;
	if no_password_info then do;
	     if pnte.n_good_pw = 0 then
		call ioa_ ("Never logged in.");
	     else call ioa_ ("Last logged in at ^a.",
		     dt (pnte.time_last_good_pw));
	     return;
	end;
	call ioa_ ("^-^d good passwords given, last at ^a.",
	     pnte.n_good_pw, dt (pnte.time_last_good_pw));
	call ioa_ ("^-^d bad passwords given, last at ^a from ^a ^a terminal ^a.",
	     pnte.n_bad_pw, dt (pnte.time_last_bad_pw),
	     line_types (pnte.bad_pw_line_type), pnte.bad_pw_term_type,
	     pnte.bad_pw_term_id);
	if pnte.time_pw_changed ^= 0 then
	     call ioa_ ("^-Password changed: ^a", dt (pnte.time_pw_changed));
	call ioa_ ("^-User last validated on ^a", dt (pnte.user_validated_time));
     end print_it;
%page;
initialize:
     procedure ();

/**** This procedure initiates several files needed to execute this
      command. */

	call initiate_file_ (sadir, "projfile", R_ACCESS, pp, (0), code);
	if code ^= 0 then do;
	     call com_err_ (code, whoami, "Unable to initiate ^a.", pathname_ (sadir, "projfile"));
	     goto RETURN_TO_CALLER;
	end;

	call initiate_file_ (sadir, "sys_admin_data", R_ACCESS, sadp, (0), code);
	if code ^= 0
	then do;
	     call com_err_ (code, whoami, "Unable to initiate ^a.", pathname_ (sadir, "sys_admin_data"));
	     goto RETURN_TO_CALLER;
	end;

	call initiate_file_ (sysdir, "installation_parms", R_ACCESS, ip, (0), code);
	if code ^= 0 then
	     do;
	     call com_err_ (code, whoami, "Unable to initiate ^a.", pathname_ (sysdir, "installation_parms"));
	     goto RETURN_TO_CALLER;
	end;
	return;
     end initialize;
%page;
cleaner:
     procedure ();

/**** This is the cleanup handler for new_user */

dcl  tptr pointer;					/* temp pointer */

	if pp ^= null ()
	then do;
	     tptr = pp;
	     pp = null ();
	     call terminate_file_ (tptr, 0, TERM_FILE_TERM, (0));
	end;

	if sadp ^= null ()
	then do;
	     tptr = sadp;
	     sadp = null ();
	     call terminate_file_ (tptr, 0, TERM_FILE_TERM, (0));
	end;

	if ip ^= null () then
	     do;
	     tptr = ip;
	     ip = null ();
	     call terminate_file_ (tptr, 0, TERM_FILE_TERM, (0));
	end;
	return;

     end cleaner;


/* * * * * * * * * * READ_LINE * * * * * * * * * */

read_line: procedure (Prompt);

declare  (Prompt) character (*) aligned parameter;
declare  nelemt fixed bin (21),
         code fixed bin (35);

	if arg_given then do;
	     arg_given = "0"b;
	     return;
	end;

read_it:	call ioa_$nnl (Prompt);
	call iox_$get_line (iox_$user_input, addr (line), length (line), nelemt, code);
	if code = 0 then do;
	     substr (line, nelemt) = "";
	     if substr (line, 1, 4) = "stop" then signal new_user_stop;
	     return;
	end;

	do while (code = error_table_$long_record);
	     call iox_$get_line (iox_$user_input, addr (line), length (line), nelemt, code);
	end;
	if code = 0 then do;
	     call ioa_ ("Line too long.");
	     goto read_it;
	end;
	call com_err_ (code, whoami, "Reading from user_input.");
	goto RETURN_TO_CALLER;
     end read_line;


/* * * * * * * * * * UID_EXISTS * * * * * * * * * */

uid_exists: procedure (Uid) returns (bit aligned);

declare  Uid character (*) aligned parameter;
declare  code fixed bin (35);
declare  1 test_urfe aligned like urf_entry;

	uid = substr (Uid, 1, min (length (Uid), 20));
	call urf_manager_$get_entry ((uid), addr (test_urfe), code);
	if code = 0 then do;
	     call ioa_ ("""^a"" is in use by ^a, ^a; ^a.", uid, test_urfe.last_name, test_urfe.first_name, test_urfe.address);
	     return ("1"b);
	end;
	else if code = error_table_$id_not_found then do;
	     code = 0;
	     call mail_table_$get (rtrim (uid), null (), (""), code);
	     if code = 0 | code = mlsys_et_$ambiguous_address then do;
		call ioa_ ("""^a"" is in use as a Mail Table entry name.", uid);
		return ("1"b);
	     end;
	     if code = error_table_$id_not_found then do;
		if check_legal (uid) then return ("0"b);
		call ioa_ ("""^a"" is not a valid user_id.", uid);
		return ("1"b);
	     end;
	     else do;
		call com_err_ (code, whoami, "Getting name from MAIL_TABLE.");
		go to RETURN_TO_CALLER;
	     end;
	end;
	else do;
	     call com_err_ (code, whoami, "Getting entry from URF.");
	     goto RETURN_TO_CALLER;
	end;
     end uid_exists;
%page;
read_password:
     procedure (Prompt, Password, Has_pw, Short_pw, Pword_changed);

/**** This procedure prompts for and changes, if necessary, the specified
      password. */

declare  Prompt character (*);
declare  Password character (32) aligned parameter;
declare  Has_pw bit unaligned parameter;
declare  Short_pw bit (1) unaligned parameter;
declare  (p1, p2) character (8);
dcl  Pword_changed bit (1) parameter;
dcl  error_message char (64) automatic;			/* informative error message */
dcl  code fixed bin (35) automatic;			/* local status code */

	Pword_changed = "0"b;			/* Assume not changed yet */
read_them: call read_password_ (Prompt, p1);
	if p1 = "*"
	then if changing
	     then return;
	     else do;
		Password = "";
		Pword_changed = "1"b;
		Has_pw = "0"b;
		return;
	     end;
	else do;
	     call check_password_ (p1, error_message, code);
	     if code ^= 0 then
		do;
		call ioa_ ("^a", error_message);
		goto read_them;
	     end;
	end;

	call read_password_ ("Password again:", p2);
	if p1 ^= p2 then do;
	     call ioa_ ("Passwords don't agree -- try again.");
	     goto read_them;
	end;
	Password = scramble_ ((p1));
	Pword_changed = "1"b;
	p1, p2 = "";
	Has_pw = "1"b;
	Short_pw = "1"b;				/* We don't support 32 char passwords yet */
     end read_password;

/* * * * * * * * * * PRINT_ALIAS * * * * * * * * * */

print_alias: procedure;
	if (pnte.alias ^= "") | changing
	then call ioa_ ("Alias:^-^-^a", pnte.alias);
     end;

/* * * * * * * * * * READ_ALIAS * * * * * * * * * */

read_alias: procedure;
	if changing then call print_alias;
read_alias_again:
	call read_line ("Alias^-^-");
	if line = "" | line = "no" | line = "stop" then return;
	if changing then
	     if line = "." then do;			/* Means to delete the alias. */
		pnte.alias = "";
		return;
	     end;
	     else if line = pnte.alias then return;	/* Changed to itself */
	call pnt_manager_$get_entry ((line), addr (alias_pnte), code);
	if code = 0 then do;
	     call ioa_ ("The alias ""^a"" is already in use by ^a. Try another.", line, alias_pnte.user_id);
	     goto read_alias_again;
	end;
	code = 0;
	call mail_table_$get ((line), null (), (""), code);
	if code = 0 | code = mlsys_et_$ambiguous_address then do;
	     call ioa_ ("The alias ""^a"" is already in use as a Mail Table entry name.", line);
	     go to read_alias_again;
	end;
	if copy_and_check_length (line, pnte.alias, "alias") then goto read_alias_again;
     end read_alias;

/* * * * * * * * * * PRINT_PROG_NUMBER * * * * * * * * * */

print_prog_number: procedure;
	if urfe.prog_number ^= "none" | changing
	then call ioa_ ("Prog. number:^-^a", urfe.prog_number);
     end print_prog_number;

/* * * * * * * * * * READ_PROG_NUMBER * * * * * * * * * */

read_prog_number: procedure;

read_it:
	if changing then call print_prog_number;
	call read_line ("Prog. number^-");
	if changing
	then if (line = "") | (line = "no")
	     then return;
	     else ;
	else if line = "" then line = "none";
	if copy_and_check_length (line, urfe.prog_number, "programmer number")
	then goto read_it;
	if line ^= "none"
	then if verify (line, "0123456789 ") ^= 0
	     then call ioa_ ("WARNING: Programmer number contains non-numeric characters.");
	urfe.prog_number = rtrim(line);
     end read_prog_number;

/* * * * * * * * * * PRINT_AUDIT * * * * * * * * * */

print_audit: procedure;
declare  audit_string character (256);

	if pnte.audit = ""b & ^changing then return;
	call convert_access_audit_flags_$to_string (pnte.audit, audit_string, code);
	if code = 0
	then call ioa_ ("Audit Flags:^-^a", audit_string);
	else call ioa_ ("Audit Flags:^-""^12.3b""b3 (illegal format)", pnte.audit);
     end print_audit;

/* * * * * * * * * * READ_AUDIT * * * * * * * * * */

read_audit: procedure;

	if changing then do;
change_loop:   call print_audit;
	     call read_line ("Audit Flags^-");
	     if line = "" | line = "no" then return;
	     call convert_access_audit_flags_$edit_from_string ((line), pnte.audit, code);
	     if code ^= 0 then do;
		call com_err_ (code, whoami, "Converting audit string.");
		goto change_loop;
	     end;
	end;
	else do;
read_it:	     call read_line ("Audit Flags^-");
	     call convert_access_audit_flags_$from_string ((line), pnte.audit, code);
	     if code ^= 0 then do;
		call com_err_ (code, whoami, "Converting audit string.");
		goto read_it;
	     end;
	end;

	return;

     end read_audit;

/* * * * * * * * * * PRINT_AUTHORIZATION * * * * * * * * * * */

print_default_authorization: procedure (Which);

declare  Which bit (72) aligned parameter;
declare  auth_string character (256);

	if Which = ""b & ^changing then return;
	call convert_authorization_$to_string_short (Which, auth_string, code);
	call ioa_$nnl ("^a: ", "Default Authorization");
	if code = 0 then do;
	     if auth_string = "" then
		auth_string = "system_low";
	     call ioa_ ("^a", auth_string);
	end;
	else call ioa_ ("""^24.3b""b3", Which);
     end print_default_authorization;
%page;
print_authorization_range: procedure (P_auth_range);

dcl  P_auth_range (2) bit (72) aligned parameter;
dcl  auth_string char (256);
dcl  convert_authorization_$to_string_range_short entry ((2) bit (72) aligned, char (*), fixed bin (35));

	if P_auth_range (1) = ""b & P_auth_range (2) = ""b & ^changing
	then return;
	call convert_authorization_$to_string_range_short (P_auth_range, auth_string, code);
	call ioa_$nnl ("^a: ", "Authorization Range");
	if code = 0 then
	     call ioa_ ("^a", auth_string);
	else call ioa_ ("^24.3b:^24.3b", P_auth_range (1), P_auth_range (2));

     end print_authorization_range;
%page;
/* * * * * * * * * * * READ_AUTHORIZATION * * * * * * * * * */

read_default_authorization: procedure (Which);

declare  Which bit (72) aligned parameter;

read_it:
	if changing then
	     call print_default_authorization (Which);
	call read_line ("Default Authorization: ");
	if (line = "" | line = "no") & changing then return;
	call convert_authorization_$from_string (Which, (line), code);
	if code ^= 0 then do;
	     call com_err_ (code, whoami, "Converting authorization.");
	     goto read_it;
	end;
     end read_default_authorization;
%page;
read_authorization_range: procedure (P_auth_range);

dcl  P_auth_range (2) bit (72) aligned parameter;
dcl  convert_authorization_$from_string_range entry ((2) bit (72) aligned, char (*), fixed bin (35));

read_it:	if changing then
	     call print_authorization_range (P_auth_range);
	call read_line ("Authorization Range: ");
	if (line = "" | line = "no") & changing then return;
	call convert_authorization_$from_string_range (P_auth_range, (line), code);
	if code ^= 0 then do;
	     call com_err_ (code, whoami, "Converting authorization range.");
	     goto read_it;
	end;
	return;
     end read_authorization_range;
%page;
/* * * * * * * * * * PRINT_FLAGS * * * * * * * * * */

print_flags: procedure;
declare  lock_time character (14);

	lock_time = date_time_$format ("date_time", pnte.password_timelock,
	     "", "");
	call ioa_ ("Flags:^-^-^[^^^]password,^[^^^]network_pw,^[^^^]trap,^[^^^]lock,^[^^^]change,^[^^^]must_change,^[^^^]generate,^[^^^]operator,^[time_lock=^a^;^^time_lock^s^]",
	     ^pnte.has_password, ^pnte.has_network_password,
	     ^pnte.flags.trap, ^pnte.flags.lock, pnte.flags.nochange, ^pnte.flags.must_change, ^pnte.flags.generate_pw, ^pnte.flags.operator, pnte.flags.pw_time_lock, lock_time);
     end print_flags;
%page;
read_flags: procedure ();

/**** This internal procedure displays the current PNT flag settings and
      offers to change them.  */

dcl  (i, j) fixed bin;
dcl  mode_value bit aligned;

read_them:
	if changing then
	     call print_flags;
	call read_line ("Flags^-^-");
	if line = "" | line = "no" then
	     return;
	i = 1;
	do while (i <= length (line));
	     j = index (substr (line, i), ",") - 1;
	     if j < 0 then j = length (line) - i + 1;
	     if substr (line, i, 1) = "^"
	     then do;
		mode_value = "0"b;
		i = i + 1;
		j = j - 1;
	     end;
	     else mode_value = "1"b;
	     if substr (line, i, j) = "" then ;
	     else if substr (line, i, j) = "password" then
		pnte.flags.has_password =
		     pnte.flags.has_password & mode_value;
	     else if substr (line, i, j) = "network_pw" then
		pnte.flags.has_network_password =
		     pnte.flags.has_network_password & mode_value;
/**** Still support the old "card_pw" */
	     else if substr (line, i, j) = "card_pw" then
		pnte.flags.has_network_password =
		     pnte.flags.has_network_password & mode_value;
	     else if substr (line, i, j) = "trap" then
		pnte.flags.trap = mode_value;
	     else if substr (line, i, j) = "lock" then
		pnte.flags.lock = mode_value;
	     else if substr (line, i, j) = "change" then
		pnte.flags.nochange = ^mode_value;
	     else if substr (line, i, j) = "must_change" then
		pnte.flags.must_change = mode_value;
	     else if j >= 9 & substr (line, i, 9) = "time_lock" then do;
		if ^mode_value
		then pnte.password_timelock = 0;
		else do;
		     if j < 11 | substr (line, i + 9, 1) ^= "=" then do;
			call ioa_ ("Bad time lock specified.");
			goto read_them;
		     end;
		     call convert_date_to_binary_ (substr (line, i + 10, j - 10), pnte.password_timelock, code);
		     if code ^= 0 then do;
			call com_err_ (code, whoami, "Time lock.");
			goto read_them;
		     end;
		end;
		pnte.flags.pw_time_lock = mode_value;
	     end;
	     else if substr (line, i, j) = "generate" then
		pnte.flags.generate_pw = mode_value;
	     else if substr (line, i, j) = "operator" then pnte.flags.operator = mode_value;
	     else do;
		call ioa_ ("Invalid flag ""^a"" specified.", substr (line, i, j));
		goto read_them;
	     end;
	     i = i + j + 1;
	end;
     end read_flags;

/* * * * * * * * * * PRINT_PROJECT * * * * * * * * * * */

print_project: procedure;
	call ioa_ ("Project ID:^-^a", pnte.default_project);
     end print_project;

/* * * * * * * * * * READ_PROJECT * * * * * * * * * */

read_project: procedure;
declare  i fixed bin;

read_it:
	if changing then call print_project;
	call read_line ("Project ID^-");
	if line = "" | line = "No"
	then if changing
	     then return;
	     else goto read_it;
	if pp ^= null ()
	then do i = 1 to projfile.nproj;
	     if line = projfile.projfiletab (i).id then goto good_project;
	end;
	if length (rtrim (line)) > 9 then do;
	     call ioa_ ("Project name length > 9 characters.");
	     goto read_it;
	end;
	if pp ^= null () then call ioa_ ("WARNING: Project name not in projfile.");
good_project:
	urfe.project, pnte.default_project = rtrim(line);
     end read_project;

/* * * * * * * * * * * PRINT_NOTES * * * * * * * * * * * */

print_notes: procedure;
	call ioa_ ("Notes:^-^-^a", urfe.notes);
     end;

/* * * * * * * * * * * READ_NOTES * * * * * * * * * * * */

read_notes: procedure;

read_it:
	if changing then call print_notes;
	call read_line ("Notes^-^-");
	if changing then
	     if line = "" then return;
	     else if line = "." then line = "";
	if copy_and_check_length (line, urfe.notes, "notes field")
	then goto read_it;
	return;					/* 10/19/82 Jis: Always return, don't force user to give a notes field */
						/*	else if changing then return; */
						/* 	else goto read_it;  */
     end read_notes;

/* * * * * * * * * * * PRINT_ADDRESS * * * * * * * * * * */

print_address: procedure;
	call ioa_ ("Address:^-^-^a", urfe.address);
     end;

/* * * * * * * * * * READ_ADDRESS * * * * * * * * * */

read_address: procedure;

read_it:
	if changing then call print_address;
	call read_line ("Address^-^-");
	if line = "" then
	     if changing then return;
	     else goto read_it;
	else if copy_and_check_length (line, urfe.address, "address")
	then goto read_it;
     end read_address;

/* * * * * * * * * * * PRINT_NAME * * * * * * * * * */

print_name: procedure;
	call ioa_ ("Full name:^-^a, ^a^[ : ^a^;^s^]",
	     urfe.last_name, urfe.first_name, (urfe.title ^= ""), urfe.title);
     end;

/* * * * * * * * * * READ_NAME * * * * * * * * * */

read_name: procedure;
declare  (i1, i2, i4) fixed bin;

read_it:
	if changing then call print_name;
	call read_line ("Full name^-^-");
	if line = "" then if changing then return; else goto read_it;
	i2 = search (line, ":");
	if i2 = 0
	then urfe.title = "";
	else do;
	     i1 = search (substr (line, i2 + 1), " ");
	     if copy_and_check_length (substr (line, i2 + 1, i1 - 1),
		urfe.title, "title") then goto read_it;
	     substr (line, i2, i1) = "";
	end;

	i1 = search (line, ",");
	if i1 = 0 then do;
	     call ioa_ ("A comma must immediately follow the last name.");
	     goto read_it;
	end;
	if copy_and_check_length (substr (line, 1, i1 - 1), urfe.last_name, "last name")
	then goto read_it;
	if urfe.last_name = "" then do;
	     call ioa_ ("No last name given.");
	     goto read_it;
	end;
	if verify (substr (urfe.last_name, 1, 1), "*ABCDEFGHIJKLMNOPQRSTUVWXYZ") ^= 0
	then call ioa_ ("WARNING: Last name does not begin with capital letter.");
	substr (line, 1, i1) = "";

	i2 = verify (line, " ");			/* find beginning of first name */
	if i2 = 0 then do;
	     call ioa_ ("No first name givien.");
	     goto read_it;
	end;
	if copy_and_check_length (substr (line, i2), urfe.first_name, "first name")
	then goto read_it;
	if verify (substr (urfe.first_name, 1, 1), "ABCDEFGHIJKLMNOPQRSTUVWXYZ") ^= 0
	then call ioa_ ("WARNING: First name does not begin with a capital letter.");
	i4 = search (substr (line, i2), " ");
	if i4 = 0
	then initial = "";				/* first name no initial */
	else do;
	     initial = substr (line, i2 + i4, 1);	/* first name middle name */
	     if verify (initial, " ABCDEFGHIJKLMNOPQRSTUVWXYZ") ^= 0
	     then call ioa_ ("WARNING: Middle initial is not a capital letter.");
	end;
     end read_name;

/* * * * * * * * * * YES_NO * * * * * * * * * */

yes_no: procedure (Prompt) returns (bit aligned);
declare  Prompt character (*) aligned parameter;

read_it:	call read_line (Prompt);
	if line = "yes" | line = "y" then return ("1"b);
	else if line = "no" | line = "n" then return ("0"b);
	else do;
	     call ioa_ ("Please answer ""yes"", ""no"", ""y"", or ""n"".");
	     goto read_it;
	end;
     end yes_no;
%page;
dt:  procedure (Date) returns (character (16) aligned);

/**** This function returns a character string representation of
      a date-time. */

dcl  Date fixed bin (71);
dcl  date char (16);

	if Date = 0 then return ("NEVER");
	date = date_time_$format ("date_time", Date, "", "");
	return (date);
     end;

/* * * * * * * * * * CHECK_LEGAL * * * * * * * * * */

check_legal: proc (Thunk) returns (bit (1));
declare  Thunk char (*) aligned;
declare  ILLEGAL_FOR_UIDS char (4) init (" 	.;") internal static options (constant);

	if search (rtrim (Thunk), ILLEGAL_FOR_UIDS) = 0 then
	     return ("1"b);
	else return ("0"b);

     end check_legal;

/* * * * * * COPY_AND_CHECK_LENGTH * * * * * * * */

/* Check to see if Input fits in Output, complaining and returning true if
   it doesn't, copying and returning false if it does. */
copy_and_check_length:
     proc (Input, Output, Name) returns (bit (1));

dcl  (Input, Output, Name) char (*) aligned;

	if length (rtrim (Input)) > length (Output) then do;
	     call ioa_ ("The ^a ""^a"" is too long.  Maximum length is ^d.",
		Name, Input, length (Output));
	     return ("1"b);
	end;
	else do;
	     Output = Input;
	     return ("0"b);
	end;
     end copy_and_check_length;

/* * * * * * * * * * TEST * * * * * * * * * */

new_user_test:
     entry (Test_dir);

declare  Test_dir character (*) parameter;

	sadir = Test_dir;
	call pnt_manager_$test (Test_dir);
	call urf_manager_$test (Test_dir);
	call mail_table_priv_$test (Test_dir);
	return;
%page;
REVALIDATE_USER:
     procedure ();

/**** This procedure is used to revalidate a user.  User revalidation
      is used in order to prevent the expiration of a user's password
      if the installation parameter "password_expiration_interval" is
      set to a non-zero value.  If this parameter is non-zero, then
      if a user has not successfully logged in within the specified
      interval, he/she is refused the login.  If this occurs, a system
      administrator must issue the "new_user$cga Userid revalidate"
      command in order to revalidate the user.  This command line may
      be used to anticipate the password expiration of a user and
      ensure that the user is not denied login.  This is necessary,
      for instance for server processes (network, IMFT, mailer) which
      log in with passwords, but which do not have a means of coping
      with this situation.

      If this procedure was invoked because of the command line specified
      above, the user-revalidation time in the PNT entry is updated
      to the current time.  If this procedure is invoked due to the
      new_user$cga prompt-mode, then the user is prompted as to whether
      or not he/she wants to revalidate the user. */

dcl  1 qi aligned like query_info;
dcl  explanation char (182) initial (
	"Answering ""yes"" to this question will allow the user to log in even though he/she may not have logged in with the password_expiration_interval defined in the installation parameters.") internal static options (constant);
dcl  appropriate_answer_given bit (1) aligned;
dcl  answer char (4);

	if what = "revalidate" then
	     pnte.user_validated_time = clock ();
	else if installation_parms.password_expiration_interval ^= 0 then
	     do;
	     unspec (qi) = ""b;
	     qi.version = query_info_version_6;
	     qi.switches.prompt_after_explanation = "1"b;
	     qi.question_iocbp = null ();
	     qi.answer_iocbp = null ();
	     qi.explanation_ptr = addr (explanation);
	     qi.explanation_len = length (explanation);
	     appropriate_answer_given = "0"b;
	     do while (^appropriate_answer_given);
		call command_query_ (addr (qi), answer, whoami,
		     "User last validated at ^a, revalidate?",
		     dt (pnte.user_validated_time));
		if answer = "yes" | answer = "y" then
		     do;
		     appropriate_answer_given = "1"b;
		     pnte.user_validated_time = clock ();
		end;
		else if answer = "no" | answer = "n" | answer = "" then
		     appropriate_answer_given = "1"b;
	     end;
	end;
	return;
     end REVALIDATE_USER;


NO_ACCESS_TO_GATE:
     call com_err_ (code, whoami, "pnt_admin_gate_");
     return;


/* format: off */
%page;%include access_mode_values;
%page;%include installation_parms;
%page;%include line_types;
%page;%include mail_table_entry;
%page;%include pnt_entry;
%page;%include projfile;
%page;%include query_info;
%page;%include sys_admin_data;
%page;%include terminate_file;
%page;%include urf_entry;
/* format: on */

     end new_user;




		    parse_attributes_.pl1           11/12/82  1412.9rew 11/12/82  1109.8       19512



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


parse_attributes_: proc (attr_string, set_attr, reset_attr, ec);

/* PARSE_ATTRIBUTES_ - Parse string containing attributes into
   two bit strings, one with "on" and one with "off".

   Written by T.H. VanVleck, .... 1974
   Modified by T. Casey, Feb 1975 to fix bugs

   */

dcl  attr_string char (*),				/* String to be parsed. */
    (set_attr, reset_attr) bit (36),			/* Output arguments. */
     ec fixed bin (35);				/* Error code. */

dcl (i, j) fixed bin,				/* Indices. */
     atp ptr,					/* Ptr to bit string. */
     char32 char (32) aligned;			/* Single attribute keyword. */

dcl  lookup_attribute_ entry (char (*) aligned, ptr, fixed bin (35));
dcl (length, search, substr) builtin;

	set_attr, reset_attr = "0"b;			/* Clear return args. */
	ec = 0;					/* clear error code */
	i = 1;					/* "i" locates beginning of keyword */
attloop:	j = search (substr (attr_string, i), ",	; ");	/* Find tab, blank, comma, semi */
	if j = 0 then j = length (attr_string) - i + 2;

	if j > 1 then do;				/* skip over null parameters (e.g. ",,") */
	     if substr (attr_string, i, 1) = "^" then do; /* Check to see if on or off */
		atp = addr (reset_attr);		/* Off. */
		char32 = substr (attr_string, i+1, j-2); /* Get keyword without not-sign. */
	     end;
	     else do;				/* On. */
		atp = addr (set_attr);
		char32 = substr (attr_string, i, j-1);
	     end;
	     call lookup_attribute_ (char32, atp, ec);	/* Find which bit this is. */
	     if ec ^= 0 then return;
	end;
	i = i + j;				/* i = index of first char of next attribute */
	if i <= length (attr_string) then go to attloop;	/* Loop until no more. */
	return;

     end parse_attributes_;




		    pdt_copy.pl1                    10/07/88  1234.3rew 10/07/88  1232.6       53199



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







/****^  HISTORY COMMENTS:
  1) change(86-10-15,Parisek), approve(87-06-17,MCR7570),
     audit(87-06-15,Hirneisen), install(87-08-06,MR12.1-1066):
     Skip projects marked as renamed when scanning the SAT.
  2) change(88-09-15,Parisek), approve(88-09-28,MCR7996),
     audit(88-10-05,Hunter), install(88-10-07,MR12.2-1140):
     Implemented the copying of the hash table for pdts having them.
     This change originally coded by Paul M. Karagianis.
                                                   END HISTORY COMMENTS */



/* PDT_COPY - Procedure to copy the System Administrator's Table (SAT) and the Project Definition Tables (PDTs)
   from given directories to a special administrative directory.

   This procedure is called with three arguments:

   1) pathname of directory containing SAT ("from" dir )
   2) pathname of directory containing PDTs ("from" dir)
   3) pathname of the administrative directory into which the SAT and PDTs will be copied ("to" dir )

   Janice B. Phillipps, April 4, 1972		 */


pdt_copy: proc;

dcl (argp, cp_satp, cp_pdtp, htp, sp, satp, satep, pdtep, pdtp) ptr,
    (arglg, i, lth, llth, w) fixed bin,
     code fixed bin;

dcl (sat_dir, pdt_dir, cp_dir) char (168) aligned,
     pdt_name char (168) aligned;

/* procedures called in this program */

dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin),
     com_err_ ext entry options (variable),
     expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin),
     hcs_$initiate ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2),
     ptr, fixed bin),
     hcs_$make_seg ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr,
     fixed bin),
     hcs_$set_bc_seg ext entry (ptr, fixed bin, fixed bin),
     hcs_$terminate_noname ext entry (ptr, fixed bin),
     hcs_$truncate_seg ext entry (ptr, fixed bin, fixed bin),
     ioa_$rsnnl ext entry options (variable);


dcl (addr, addrel, null) builtin;

dcl  sat_zap (lth) fixed bin based,
     pdt_zap (llth) fixed bin based;
%page;

/* ======================================================= */

	call cu_$arg_ptr (1, argp, arglg, code);	/* get 1st arg, path of dir containing SAT */

	if code ^= 0 then do;
error:	     
	     call com_err_ (code, "pdt_copy", "");
	     return;
	end;
	call expand_path_ (argp, arglg, addr (sat_dir), null, code); /* get absolute path of SAT dir */
	if code ^= 0 then go to error;
	call hcs_$initiate (sat_dir, "sat", "", 0, 0, satp, code); /* get ptr to SAT header */
	if satp = null then go to error;
	call cu_$arg_ptr (2, argp, arglg, code);	/* get 2nd arg, path of dir containing PDTs */
	if code ^= 0 then go to error;
	call expand_path_ (argp, arglg, addr (pdt_dir), null, code); /* get absolute path of PDTs dir */
	if code ^= 0 then go to error;
	call cu_$arg_ptr (3, argp, arglg, code);	/* get 3rd arg, path to copy data bases into */
	if code ^= 0 then go to error;
	call expand_path_ (argp, arglg, addr (cp_dir), null, code); /* get absolute path of admin dir */
	if code ^= 0 then go to error;
	call hcs_$make_seg (cp_dir, "sat", "", 1011b, cp_satp, code);
	if cp_satp = null then go to error;

	lth = SAT_header_lth + (satp -> sat.current_size * SAT_entry_lth); /* copy SAT to admin dir */
	cp_satp -> sat_zap = satp -> sat_zap;

	do i = 1 to cp_satp -> sat.current_size;	/* find a PDT in "from" dir by looping thru SAT */
	     sp = addr (cp_satp -> sat.project (i));	/* get ptr to a project array */
	     if sp -> project.state ^= 0 & sp -> project.state ^= 3 then do;	                                                         /* if project active during the month, count it (do not include renamed projects either) */
		call ioa_$rsnnl ("^a.pdt", pdt_name, w, sp -> project.project_id); /* get name of proj and add ".pdt" */
		call hcs_$initiate (pdt_dir, pdt_name, "", 0, 0, pdtp, code);
		if pdtp = null then go to nonfaterr;	/* continue with other PDTs if find a bad one */
		call hcs_$make_seg (cp_dir, pdt_name, "", 1011b, cp_pdtp, code); /* each time get seg for copied PDT */
		if cp_pdtp = null then go to nonfaterr;	/* continue with other PDTs if find bad one */

		llth = PDT_header_lth + (pdtp -> pdt.current_size * PDT_entry_lth); /* copy PDT to admin dir */
		if pdt.ht_relp > 0 then do;	/* if there is a hash table */
		     htp = addrel (pdtp, pdt.ht_relp);
		     llth = llth + htable.loht;	/* then include it */
		end;
		cp_pdtp -> pdt_zap = pdtp -> pdt_zap;

		call hcs_$terminate_noname (pdtp, code); /* terminate each PDT as you finish */
		call hcs_$truncate_seg (cp_pdtp, llth, code);	/* waste not, want not */
		call hcs_$set_bc_seg (cp_pdtp, llth * 36, code);
		call hcs_$terminate_noname (cp_pdtp, code);
						/* terminate the copied PDT as you finish */
		go to skip;
nonfaterr:	call com_err_ (code, "pdt_copy", pdt_name);
	     end;					/* end of project conditional */
skip:	end;					/* end of project do loop: go back and get the next PDT */

	call hcs_$terminate_noname (satp, code);	/* terminate the SAT */
	call hcs_$terminate_noname (cp_satp, code);	/* terminate the copied SAT */
%page;
%include hashst;
%page;
%include pdt;
%page;
%include sat;
%page;
%include user_attributes;

     end pdt_copy;




		    print_disk.pl1                  09/19/84  0911.6rew 09/18/84  0758.4       46989



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


print_disk: proc;

/* This program prints out a disk usage listing
   from the disk usage figures in "projfile"
   which were placed there by "charge_disk".

   THVV 4/70
   Modified by T. Casey April 1976 to print directory pages used column.
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.
*/

dcl (hp, pp) ptr,					/* pointer to input */
     tid char (9) aligned,
    (path, dn) char (168) aligned,			/* file system names */
     en char (32) aligned,				/* .. */
    (coxx, dpxx) char (64) aligned,			/* company & department */
     temp fixed bin (71),				/* temp for disk use */
     dols float bin,				/* dollar charge */
     tdols float bin init (0.0e0),			/* total charge */
     tqta fixed bin (35) init (0),			/* total quota */
    (tduse, tuse) fixed bin (35) init (0),		/* total use */
     qta fixed bin (35),				/* project quota */
    (duse, use) fixed bin (35),			/* project use */
     disk_price (0:9) float bin,
     dummy1 float bin,
     dummy (0: 7) float bin,
    (i, np) fixed bin;				/* misc */
dcl  ec fixed bin (35);
dcl  rs_number fixed bin;				/* rate structure index */
dcl  rs_name char (32);
dcl  rs_count fixed bin;

dcl  get_wdir_ entry () returns (char (168) aligned),
     system_info_$titles entry (char (*) aligned, char (*) aligned),
     system_info_$prices_rs entry (fixed bin,
    (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, float bin, float bin),
     system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)),
     system_info_$max_rs_number entry (fixed bin),
     search_sat_$rs_number entry (char (*), fixed bin, fixed bin (35)),
     search_sat_$clean_up entry,
     ioa_ entry options (variable),			/* output printing procedure */
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),	/* file system */
     com_err_ entry options (variable);			/* error reporter */
dcl  error_table_$noentry external fixed bin (35);

dcl (hbound, null) builtin;

dcl  format char (32) int static aligned init		/* output formats */
    ("^-^9a^4x^6d^4x^6d^4x^6d^4x^15.2f"),
     head char (49) aligned int static init
    ("^/^/^-Project^5xs-quota^5xs-use^5xd-use^13xCharge"),
     dash char (54) aligned int static init
    ("^----------^5x-----^5x-----^5x-----^5x--------------^/");

%include projfile;

/* - - - - */

	call system_info_$max_rs_number (rs_count);	/* see if site has multiple rate structures */
	call hcs_$initiate ((get_wdir_ ()), "projfile", "", 0, 1, pp, ec);
	if pp = null then do;
	     call com_err_ (ec, "print_disk", "projfile");
	     return;
	end;

	do rs_number = 0 to hbound (disk_price, 1);	/* get all rates */
	     call system_info_$rs_name (rs_number, rs_name, ec); /* check if this is a valid rs_number */
	     if ec ^= 0 then disk_price (rs_number) = disk_price (0); /* assumes default rates are valid */
	     else call system_info_$prices_rs (rs_number, dummy, dummy, dummy, dummy, disk_price (rs_number), dummy1);
	end;

	np = projfile.nproj;			/* get number of projects */
	call system_info_$titles (coxx, dpxx);
	call ioa_ ("^|^-^a^/^/^-^a", coxx, dpxx);
	call ioa_ ("^/^/^-Disk usage report");
	call ioa_ (head);				/* write heading. */
	call ioa_ (dash);				/* .. */

	do i = 1 to np;				/* loop on all projects */
	     if id (i) = "" then go to skip;
	     if off (i) ^= 0 then if disk_psec (i) = 0 then go to skip;
		else tid = "*" || id (i);
	     else tid = id (i);
	     qta = disk_quota (i);			/* extract project quota */
	     use = disk_use (i);			/* use */
	     duse = dir_disk_use (i);
	     temp = disk_psec (i);			/* page-seconds */
	     if rs_count > 0 then do;			/* only if site has multiple rate structures */
		call search_sat_$rs_number ((id (i)), rs_number, ec); /* get rate index */
		if ec ^= 0 then
		     if ec = error_table_$noentry then
			call com_err_ (ec,
			"print_disk",
			"Trying to locate project ""^a"" in the sat.  Default rates will be used.", id (i));
		     else call com_err_ (ec, "print_disk", "Accessing the sat.  Default rates will be used");
	     end;
	     else rs_number = 0;
	     dols = temp * disk_price (rs_number);	/* compute charge */
	     tdols = tdols + dols;			/* accumulate totals */
	     tqta = tqta + qta;
	     tuse = tuse + use;
	     tduse = tduse + duse;
	     call ioa_ (format, tid, qta, use, duse, dols);
skip:	end;
	call ioa_ (dash);				/* write footing */
	call ioa_ (format, "TOTAL", tqta, tuse, tduse, tdols);
	call hcs_$terminate_noname (pp, ec);		/* terminate input */
	if rs_count > 0 then call search_sat_$clean_up;	/* tidy up */
     end print_disk;




		    print_meters.pl1                11/12/82  1412.9rew 11/12/82  1110.0       77472



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

print_meters: proc;

/* PRINT_METERS - Print statistics sampled by answering service.

   THVV */
/* modified to use hardcore defs 77.04.08 THVV */

dcl  dn char (168) aligned,
     en char (32) aligned,
     statp ptr,
    (tcmp, tcdp) ptr,
     double fixed bin (71) aligned based,
     scaled fixed bin (35, 18) aligned based,
     single fixed bin (35) aligned based,
     time float bin,
     meter_time float bin,
     cpu_time float bin,
     cpu_delta float bin,
     idle_val float bin,
     idle_delta float bin,
     zero_idle_val float bin,
     zidle_delta float bin,
     kmu float bin,
     kmu_delta float bin,
     responseval float bin,
    (datstr, datstr1, datstr2, crahs) char (16) aligned,
     upt fixed bin (71) init (0),
    (i, n) fixed bin,
     ap ptr,
     al fixed bin,
     ec fixed bin (35),
    (p1, q1) ptr;

dcl  TCMave_eligible_loc fixed bin (18);
dcl  TCMavequeue_loc fixed bin (18);
dcl  TCMcumulative_memory_usage_loc fixed bin (18);
dcl  TCMidle_loc fixed bin (18);
dcl  TCMinitialize_time_loc fixed bin (18);
dcl  TCMlast_time_loc fixed bin (18);
dcl  TCMmp_idle_loc fixed bin (18);
dcl  TCMprocessor_time_loc fixed bin (18);
dcl  TCMresponse_count_loc fixed bin (18);
dcl  TCMresponse_time_loc fixed bin (18);
dcl  TCMzero_idle_loc fixed bin (18);
dcl  offset fixed bin (18);

dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  ring0_get_$definition entry (ptr, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     date_time_ entry (fixed bin (71), char (*) aligned),
     com_err_ entry options (variable);

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


dcl (addr, addrel, null, substr, divide, mod) builtin;

%include stat_seg;

dcl  heading char (120) aligned int static init
    ("^/Time^3xUnits CP Kmem MPD^2xMeter time^4xCPU time^3xAvg queue^5xResponse^7xIdle^4xZero idle Avg eligible^8xK mu");

/* ================================================================= */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "print_meters", "");
fail:	     return;
	end;
	call expand_path_ (ap, al, addr (dn), addr (en), ec);
	if ec ^= 0 then go to er;
	call hcs_$initiate (dn, en, "", 0, 1, statp, ec); /* initiate meter seg */
	if statp = null then go to er;

	call date_time_ (statistics.time_of, datstr);
	call ioa_ ("system statistics as of ^a", datstr);

	n = statistics.index;
	if statistics.wrapped ^= 0 then do;
	     call ioa_ ("statistics wrapped");
	end;

	cpu_delta, idle_delta, zidle_delta = 0;
	kmu_delta = 0e0;
	call ioa_ (heading);
	i = 1;
redoit:	q1 = addr (statistics.tcdata_contents (i, 1));
	time = statistics.time (i);
	i = i + 1;
	if i > n then go to exit;
	if statistics.time (i) < time then go to redoit;
	call date_time_ (statistics.time (i), datstr);
	tcmp = addr (statistics.tcdata_contents (i, 1));
	call ring0_get_$segptr ("", "tc_data", tcdp, ec);
	if ec ^= 0 then call error ("tc_data");
	call ring0_get_$definition (tcdp, "", "ave_eligible", offset, (0), ec);
	if ec ^= 0 then call error ("sst.ave_eligible");
	TCMave_eligible_loc = offset;
	call ring0_get_$definition (tcdp, "", "avequeue", offset, (0), ec);
	if ec ^= 0 then call error ("sst.avequeue");
	TCMavequeue_loc = offset;
	call ring0_get_$definition (tcdp, "", "cumulative_memory_usage", offset, (0), ec);
	if ec ^= 0 then call error ("sst.cumulative_memory_usage");
	TCMcumulative_memory_usage_loc = offset;
	call ring0_get_$definition (tcdp, "", "idle", offset, (0), ec);
	if ec ^= 0 then call error ("sst.idle");
	TCMidle_loc = offset;
	call ring0_get_$definition (tcdp, "", "mp_idle", offset, (0), ec);
	if ec ^= 0 then call error ("sst.mp_idle");
	TCMmp_idle_loc = offset;
	call ring0_get_$definition (tcdp, "", "response_count", offset, (0), ec);
	if ec ^= 0 then call error ("sst.response_count");
	TCMresponse_count_loc = offset;
	call ring0_get_$definition (tcdp, "", "response_time", offset, (0), ec);
	if ec ^= 0 then call error ("sst.response_time");
	TCMresponse_time_loc = offset;
	call ring0_get_$definition (tcdp, "", "last_time", offset, (0), ec);
	if ec ^= 0 then call error ("sst.last_time");
	TCMlast_time_loc = offset;
	call ring0_get_$definition (tcdp, "", "initialize_time", offset, (0), ec);
	if ec ^= 0 then call error ("sst.initialize_time");
	TCMinitialize_time_loc = offset;
	call ring0_get_$definition (tcdp, "", "processor_time", offset, (0), ec);
	if ec ^= 0 then call error ("sst.processor_time");
	TCMprocessor_time_loc = offset;
	call ring0_get_$definition (tcdp, "", "zero_idle", offset, (0), ec);
	if ec ^= 0 then call error ("sst.zero_idle");
	TCMzero_idle_loc = offset;
	call ring0_get_$definition (tcdp, "", "mp_idle", offset, (0), ec);
	if ec ^= 0 then call error ("sst.mp_idle");
	TCMmp_idle_loc = offset;

	meter_time = addrel (tcmp, TCMlast_time_loc) -> double - addrel (tcmp, TCMinitialize_time_loc) -> double;
	kmu_delta = addrel (tcmp, TCMcumulative_memory_usage_loc) -> double / 1e6 - kmu;
	kmu = addrel (tcmp, TCMcumulative_memory_usage_loc) -> double / 1e6;
	cpu_delta = addrel (tcmp, TCMprocessor_time_loc) -> double - cpu_time;
	cpu_time = addrel (tcmp, TCMprocessor_time_loc) -> double;
	idle_delta = addrel (tcmp, TCMidle_loc) -> double - idle_val;
	idle_val = addrel (tcmp, TCMidle_loc) -> double;
	zidle_delta = addrel (tcmp, TCMzero_idle_loc) -> double - zero_idle_val;
	zero_idle_val = addrel (tcmp, TCMzero_idle_loc) -> double;
	responseval = addrel (tcmp, TCMresponse_time_loc) -> double / 1e6;
	if addrel (tcmp, TCMresponse_count_loc) -> single > 0 then
	     responseval = responseval / addrel (tcmp, TCMresponse_count_loc) -> single;
	else responseval = -1e0;
	if uptime (i) ^= upt then do;
	     upt = statistics.uptime (i);
	     call date_time_ (upt, datstr1);
	     if i = 1 then do;
xtx:		call ioa_ ("^/^a up at ^a", statistics.sysid (i), datstr1);
	     end;
	     else do;
		if statistics.crashtime (i-1) = 0 then go to xtx;
		call date_time_ (statistics.crashtime (i-1), datstr2);
		crahs = statistics.erfno (i-1);
		if crahs = "" then crahs = "shutdown";
		call ioa_ ("^/^a up at ^a after ^a at ^a",
		     statistics.sysid (i), datstr1, crahs, datstr2);
	     end;
	     cpu_delta, idle_delta, zidle_delta = 0;
	     kmu_delta = 0e0;
	end;
	call ioa_ ("^6a ^5.1f ^2d ^4d ^3.1f ^12a ^12a ^9.2f ^12.3f ^12a ^12a ^10.3f ^12.3f",
	     substr (datstr, 11, 6), statistics.units (i) / 1e1,
	     statistics.ncpu (i), statistics.kmem (i),
	     statistics.kbulk (i) / 1024e0,
	     tcv (meter_time), tcv (cpu_delta),
	     addrel (tcmp, TCMavequeue_loc) -> scaled, responseval,
	     tcv (idle_delta), tcv (zidle_delta),
	     addrel (tcmp, TCMave_eligible_loc) -> scaled, kmu_delta);
	go to redoit;

exit:	call ioa_ ("^/^/END");
	call hcs_$terminate_noname (statp, ec);

tcv:	proc (x) returns (char (12) aligned);

dcl (sec, min, hr, junk) fixed bin,
     rs char (12) aligned;

dcl  x float bin;

	     sec = x * 1e-6;
	     min = divide (sec, 60, 17, 0);
	     hr = divide (min, 60, 17, 0);
	     min = mod (min, 60);
	     sec = mod (sec, 60);
	     call ioa_$rsnnl ("^4d^3d^3d", rs, junk, hr, min, sec);
	     substr (rs, 5, 1) = ":";
	     substr (rs, 8, 1) = ":";
	     if substr (rs, 6, 1) = " " then substr (rs, 6, 1) = "0";
	     if substr (rs, 9, 1) = " " then substr (rs, 9, 1) = "0";
	     return (rs);
	end;

error:	proc (x);

dcl  x char (*);

	     call com_err_ (ec, "print_meters", "cannot locate ^a", x);
	     go to fail;

	end error;

     end print_meters;




		    proj_mtd.pl1                    07/13/88  1122.2r w 07/13/88  0941.2       41958



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


/* format: style4 */
proj_mtd: proc;

/* PROJ_MTD - month-to-date project usage report */
/* Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. */
/* Modified June 1982 by E. N. Kittlitz for user_attributes.incl.pl1 conversion. */

dcl  pdtp ptr,					/* ptr to pdt */
     pdtep ptr,					/* ptr to pdt entry */
     pp ptr,
     dkrate float bin,
     ft float bin,
     dummy (0:7) float bin,
     dcg float bin,
     regp float bin,
     (i, ec) fixed bin;
dcl  rs_number fixed bin;				/* rate structure index */
dcl  rs_count fixed bin;

dcl  get_wdir_ entry () returns (char (168) aligned),
     com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
	fixed bin, fixed bin, ptr, fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable);
dcl  search_sat_$rs_number entry (char (*), fixed bin, fixed bin);
dcl  search_sat_$clean_up entry;
dcl  system_info_$prices_rs entry (fixed bin,
	(0:7) float bin, (0:7) float bin, (0:7) float bin, (0:7) float bin, float bin, float bin);
dcl  system_info_$max_rs_number entry (fixed bin);

dcl  (null, index, addr) builtin;

dcl  ff float bin init (0e0),
     kl fixed bin init (0),
     jj fixed bin,
     kk fixed bin init (0),
     ap ptr,
     al fixed bin,
     bchr char (al) unal based (ap),
     test char (12),
     star char (1) aligned,
     dirname char (168) aligned,
     pdt_dir char (168) aligned,
     pdt_name char (32) aligned;

/* ================================================= */

	call system_info_$max_rs_number (rs_count);	/* see if site has multiple rate structures */
	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then go to err;
	test = bchr;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec = 0 then dirname = bchr;
	else dirname = "safe_pdts";
	call expand_path_ (addr (dirname), index (dirname, " ") - 1, addr (pdt_dir), null, ec);
	if ec ^= 0 then go to err;

	dirname = get_wdir_ ();
	call ioa_$rsnnl ("^a.pdt", pdt_name, i, test);
	call hcs_$initiate (pdt_dir, pdt_name, "", 0, 1, pdtp, ec);
	if pdtp = null then do;
err:	     call com_err_ (ec, "proj_mtd", "");
	     return;
	end;
	call hcs_$initiate (dirname, "projfile", "", 0, 1, pp, ec);
	if pp = null then go to err;
	do jj = 1 to projfile.nproj;
	     if id (jj) = test then go to found;
	end;
	call com_err_ (0, "proj_mtd", "projfile entry for ""^a"" missing", test);
	return;
found:
	if rs_count > 0 then do;			/* only if site has multiple rate structures */
	     call search_sat_$rs_number (test, rs_number, ec); /* get rate index */
	     if ec ^= 0 then do;
		call com_err_ (0, "proj_mtd", "While searching sat for project ""^a"".  pdt rate structure index (^d) used.",
		     test, pdt.rs_number);
		rs_number = pdt.rs_number;		/* if we cannot get the sat we'll go for second best */
	     end;
	end;
	else rs_number = 0;
	call system_info_$prices_rs (rs_number, dummy, dummy, dummy, dummy, dkrate, regp);
	call ioa_ ("Month to date report for project ^a", test);
	call ioa_ ("^/Name^25xlogins^5xcharge^/");
	do i = 1 to pdt.current_size;
	     pdtep = addr (pdt.user (i));
	     if user.state = 0 then go to skip;
	     if user.state = 2 then star = "*"; else star = " ";
	     call ioa_ ("^1a^29a^5d $^10.2f", star, user.person_id, user.logins, user.dollar_charge);
	     kk = kk + user.logins;
	     kl = kl + 1;
	     ff = ff + user.dollar_charge;
skip:	end;
	call hcs_$terminate_noname (pdtp, ec);
	call ioa_ ("^/^5d users^19x^5d $^10.2f", kl, kk, ff);

	ft = kl * regp;
	call ioa_ ("^/registration^24x$^10.2f", ft);

	dcg = disk_psec (jj) * dkrate;
	call ioa_ ("misc^32x$^10.2f", misc_charges (jj));
	call ioa_ ("disk^32x$^10.2f", dcg);
	call ioa_ ("^/Total^31x$^10.2f", ff + ft + misc_charges (jj) + dcg);
	call ioa_ ("");
	call hcs_$terminate_noname (pp, ec);

	if rs_count > 0 then call search_sat_$clean_up;	/* tidy up */
%page;
%include pdt;
%page;
%include projfile;
%page;
%include user_attributes;

     end;




		    rename_proj.pl1                 07/13/88  1122.2r w 07/13/88  0941.2      168120



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





/****^  HISTORY COMMENTS:
  1) change(86-09-05,Parisek), approve(87-06-17,MCR7570),
     audit(87-06-17,Hirneisen), install(87-08-06,MR12.1-1066):
     Create a dummy SAT entry for the old (renamed) project id to be used by
     up_sat_ to recognize a renamed project so it can flag the corresponding
     system SAT entry as renamed for billing purposes.  Also update pdt
     elements not previously updated (project_dir & home_dir).
     Also revise ACLs of project admins on renamed project, and ACLs for
     individual users of their own home dirs.
                                                   END HISTORY COMMENTS */



rename_proj: proc;

/* RENAME_PROJ - Used by user accounts to rename a project.

   THVV */
/* Modified March 1982 by E. N. Kittlitz to eliminate proj_admin_seg. */

dcl dn char (168) aligned,
     en char (32) aligned,
    (reqi, projj) fixed bin,
    (i, j, k, ai) fixed bin,
     sat_count fixed bin,
     mylock bit (1) init ("0"b),
     movelen fixed bin (24),
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin (35);

dcl (old_name, new_name) char (12) aligned;
dcl (old_alias, new_alias) char (8) aligned;
dcl (old_pdt, new_pdt) char (32) aligned;

dcl  (tp, tpp) ptr;

dcl  myname char (24),
     myproj char (12);

dcl 1 add_dir_acl (4) aligned,
    2 user char (32),
    2 mode bit (36),
    2 code fixed bin (35);
dcl 1 add_seg_acl (4) aligned,
    2 user char (32),
    2 mode bit (36),
    2 mbz fixed bin (35),
    2 code fixed bin (35);
dcl 1 del_acl (4) aligned,
    2 user char (32),
    2 code fixed bin (35);
dcl 1 add_user_dir_acl aligned,			/* for setting ACLs of users home_dirs for themselves */
    2 user char (32),
    2 mode bit (36),
    2 code fixed bin (35);
dcl 1 del_user_acl aligned,
    2 user char (32),
    2 code fixed bin (35);				/* for users own home_dirs */
dcl  old (4) char (32), new (4) char (32);

dcl  USERRING fixed bin (3) init (4);
dcl  special_project bit (1) init ("0"b);

dcl  n_acladd fixed bin init (0),
     n_acldel fixed bin init (0),
     udd char (64) aligned int static init (">user_dir_dir"),
     sc1_pdt char (64) aligned int static init (">system_control_1>pdt"),
     sc1 char (64) aligned int static init (">system_control_1");
dcl  pp ptr,					/* ptr to projfile */
     qp ptr,					/* ptr to reqfile */
     satp ptr,					/* ptr to sat */
     sadp ptr,					/* ptr to sys_admin_data */
     satep ptr,					/* ptr to sat entry. */
    (pdtp, pdtep) ptr,
    (pp1, pp2) ptr,
    (qp1, qp2) ptr;

dcl  set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)),
     set_lock_$unlock entry (bit (36) aligned, fixed bin (35)),
     error_table_$locked_by_this_process fixed bin (35) ext,
     error_table_$invalid_lock_reset fixed bin (35) ext;

dcl (addr, null, substr, index, verify, rtrim) builtin;

dcl  user_info_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     get_wdir_ entry () returns (char (168) aligned),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     com_err_ entry options (variable);

dcl  hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));
dcl  hcs_$add_dir_inacl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (3),
     fixed bin (35));
dcl  hcs_$chname_file entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));
dcl  hcs_$delete_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));
dcl  hcs_$delete_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));
dcl  hcs_$delete_dir_inacl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (3),
     fixed bin (35));
dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2),
     ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));

dcl 1 movetable based aligned,
    2 moveary (movelen) fixed bin (35);

%include user_attributes;
%include sys_admin_data;
%include pdt;
%include projfile;
%include reqfile;
%include sat;
%include terminate_file;

dcl 1 Nsate aligned like project;

dcl 1 Nprojfile aligned,
    2 id char (12),					/* project ID */
    2 title char (52),				/* project title */
    2 inv char (32),				/* name of principal investigator */
    2 inv_addr char (32),				/* address */
    2 sup char (32),				/* name of supervisor */
    2 sup_addr char (32),				/* address */
    2 sup_phone char (16),				/* telephone */
    2 on fixed bin (71),				/* date on */
    2 off fixed bin (71),				/* date off */
    2 disk_psec fixed bin (71),			/* project disk page-seconds */
    2 disk_quota fixed bin (35),			/* project disk quota */
    2 disk_use fixed bin (35),			/* current project disk occupancy */
    2 disk_infs fixed bin (35),			/* number of inferior directories on proj */
    2 misc_charges float bin,				/* manuals, etc */
    2 n_misc fixed bin,				/* number of entries */
    2 processed fixed bin;				/* temp for usage-report */

dcl 1 Nreqfile aligned,
    2 acctid char (12),				/* account id. usually same as Proj */
    2 mitacct char (12),				/* MIT account no. */
    2 reqno char (12),				/* requisition or PO no. */
    2 qflag char (8),				/* class & activity */
    2 procssd fixed bin,				/* temp for usage report */
    2 qdn fixed bin (71),				/* date on for account */
    2 qdf fixed bin (71),				/* date off */
    2 billing_name char (32),				/* where to send bill */
    2 billing_addr char (32),
    2 chg_mo float bin (63),				/* charges this month */
    2 chg_tr float bin (63),				/* charges this req */
    2 req_amt float bin (63),				/* req face value */
    2 cutoff fixed bin (71);				/* term date for req */

dcl  LEGAL char (71) int static init			/* Legal chars for project ID. */
    ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'_`^~/-abcdefghijklmnopqrstuvwxyz ");

/* ======================================================== */

	dn = get_wdir_ ();
	en = "sys_admin_data";
	call hcs_$initiate (dn, en, "", 0, 1, sadp, ec);
	if sadp = null then go to er1;
	call set_lock_$lock (sys_admin_data.lock, 60, ec);
	if ec ^= 0 then
	     if ec = error_table_$locked_by_this_process then mylock = "1"b;
	     else if ec ^= error_table_$invalid_lock_reset then do;
		call com_err_ (ec, "rename_proj", "Sys_admin_data is locked by ^a", sys_admin_data.locker);
		go to exit1;
	     end;
	call user_info_ (myname, myproj);
	sys_admin_data.locker = myname;
	en = "smf.cur.sat";
	call hcs_$initiate (dn, en, "", 0, 1, satp, ec);
	if satp = null then do;
er1:	     call com_err_ (ec, "rename_proj", en);
	     go to abend;
	end;
	en = "projfile";
	call hcs_$initiate (dn, en, "", 0, 1, pp, ec);
	if pp = null then go to er1;
	en = "reqfile";
	call hcs_$initiate (dn, en, "", 0, 1, qp, ec);
	if qp = null then go to er1;

	call cu_$arg_ptr (1, ap, al, ec);		/* was Project ID supplied */
	if ec ^= 0 then go to er1;
	old_name = bchr;				/* Get old name of project */
	Nsate.project_id = old_name;

	do i = 1 to sat.current_size;
	     satep = addr (sat.project (i));
	     if project.state = 1 then
		if project.project_id = old_name then go to satfnd;
	end;
	call com_err_ (0, "rename_proj", "Project ""^a"" is not registered.", old_name);
	go to abend;

satfnd:	do reqi = 1 to reqfile.nacts while (old_name ^= reqfile.acctid (reqi)); end;
	if reqi > reqfile.nacts then do;
	     call com_err_ (0, "rename_proj", "Project ""^a"" is not in reqfile.", old_name);
	     return;
	end;
	if reqfile.qdf (reqi) ^= 0 then call ioa_ ("Warning: Project ""^a"" deleted from reqfile.",
	     old_name);
	do projj = 1 to projfile.nproj while (old_name ^= projfile.id (projj)); end;
	if projj > projfile.nproj then do;
	     call com_err_ (0, "rename_proj", "Project ""^a"" is not in projfile.", old_name);
	     return;
	end;
	if projfile.off (projj) ^= 0 then call ioa_ ("Warning: project ""^a"" deleted from projfile.",
	     old_name);

/* Get the new name */

	call cu_$arg_ptr (2, ap, al, ec);		/* was Project ID supplied */
	if ec ^= 0 then go to er1;
	new_name = bchr;				/* Get desired new name */
	if verify (new_name, LEGAL) ^= 0 then do;
	     call ioa_ ("rename_proj: illegal character in new project ID ""^a""", new_name);
	     go to abend;
	end;
	if index (substr (LEGAL, 1, 36), substr (new_name, 1, 1)) = 0 then do;
	     call ioa_ ("rename_proj: New project ID does not begin with capital letter or digit.");
	     go to abend;
	end;
	if new_name ^= old_name then
	     do i = 1 to sat.current_size;
	     tp = addr (sat.project (i));
	     if tp -> project.state ^= 0 then
		if tp -> project.project_id = new_name then do;
		     call com_err_ (0, "rename_proj", "Project ""^a"" already exists.", new_name);
		     go to abend;
		end;
	end;

	call ioa_$rsnnl ("^a.pdt", new_pdt, i, new_name);
	call ioa_$rsnnl ("^a.pdt", old_pdt, i, old_name);

	old_alias = project.alias;
	call cu_$arg_ptr (3, ap, al, ec);		/* Get new alias */
	if ec ^= 0 then new_alias = "";
	else do;
	     new_alias = bchr;
	     if new_alias ^= old_alias then
		do i = 1 to sat.current_size;
		tp = addr (sat.project (i));
		if tp -> project.state = 1 then
		     if tp -> project.alias = new_alias then do;
			call com_err_ (0, "rename_proj", "Alias ^a is already used by project ^a",
			     new_alias, tp -> project.project_id);
			go to abend;
		     end;
	     end;
	end;

/* Copy the project data so we can edit it. */

	Nsate = project;				/* Copy whole SAT entry. */

	movelen = lope;				/* Copy projfile entry. */
	pp1 = addr (projfile.projfiletab (projj));
	pp2 = addr (Nprojfile);
	pp2 -> movetable = pp1 -> movetable;

	movelen = loqe;				/* Copy whole reqfile entry. */
	qp1 = addr (reqfile.reqfiletab (reqi));
	qp2 = addr (Nreqfile);
	qp2 -> movetable = qp1 -> movetable;

/* Renaming of project */

	Nsate.project_id = new_name;
	Nsate.alias = new_alias;
	Nprojfile.id = new_name;
	Nreqfile.acctid = new_name;

/* Fix Nsate.admin (i) and Nsate.project_dir */

	do i = 1 to 4;
	     k = index (Nsate.admin (i).userid, ".");
	     if substr (Nsate.admin (i).userid, k+1) = old_name then
		substr (Nsate.admin (i).userid, k+1) = new_name;
	end;

	call ioa_$rsnnl ("^a>^a", Nsate.project_dir, i, udd, new_name);

/* Now adjust ACLs if any changes were made. */

	do i = 1 to 4;
	     old (i) = project.admin (i).userid;
	     new (i) = Nsate.admin (i).userid;
	end;
	do i = 1 to 4;
	     do j = 1 to 4;
		if old (i) = new (j) then do;
		     old (i), new (j) = "";
		     go to okacl;
		end;
	     end;
okacl:	end;
	do i = 1 to 4;
	     if old (i) ^= "" then do;
		n_acldel = n_acldel + 1;
		j = index (old (i), " ");
		del_acl (n_acldel).user = substr (old (i), 1, j-1) || ".*";
	     end;
	     if new (i) ^= "" then do;
		n_acladd = n_acladd + 1;
		j = index (new (i), " ");
		add_seg_acl (n_acladd).user = substr (new (i), 1, j-1) || ".*";
		add_seg_acl (n_acladd).mode = "100"b;
		add_seg_acl (n_acladd).mbz = 0;
		add_dir_acl (n_acladd).user = add_seg_acl (n_acladd).user;
		add_dir_acl (n_acladd).mode = "111"b;
	     end;
	end;
	n_acldel = n_acldel + 1;
	call ioa_$rsnnl ("*.^a.*", del_acl (n_acldel).user, i, old_name);
	n_acladd = n_acladd + 1;
	call ioa_$rsnnl ("*.^a.*", add_dir_acl (n_acladd).user, i, new_name);
	add_dir_acl (n_acladd).mode = "100"b;		/* "S" access for others on project */

	call hcs_$delete_dir_acl_entries (sc1, "update", addr (del_acl), n_acldel-1, ec);
	call hcs_$delete_acl_entries (sc1_pdt, old_pdt, addr (del_acl), n_acldel-1, ec);
	call hcs_$delete_dir_inacl_entries (udd, old_name, addr (del_acl), n_acldel, USERRING, ec);
	call hcs_$delete_dir_acl_entries (udd, old_name, addr (del_acl), n_acldel, ec);
	call hcs_$add_acl_entries (sc1_pdt, old_pdt, addr (add_seg_acl), n_acladd-1, ec);
	if ec ^= 0 then do i = 1 to n_acladd-1;
	     if add_seg_acl (i).code ^= 0 then
		call com_err_ (add_seg_acl (i).code, "rename_proj", "Cannot add ^a to ACL of ^a",
		add_seg_acl (i).user, old_pdt);
	end;
	call hcs_$add_dir_inacl_entries (udd, old_name, addr (add_dir_acl), n_acladd, USERRING, ec);
	if ec ^= 0 then do i = 1 to n_acladd-1;
	     if add_dir_acl (i).code ^= 0 then
		call com_err_ (add_dir_acl (i).code, "rename_proj", "Cannot add ^a to initial ACL of ^a>^a",
		add_dir_acl (i).user, udd, old_name);
	end;
	call hcs_$add_dir_acl_entries (udd, old_name, addr (add_dir_acl), n_acladd, ec);
	if ec ^= 0 then do i = 1 to n_acladd;
	     if add_dir_acl (i).code ^= 0 then
		call com_err_ (add_dir_acl (i).code, "rename_proj", "Cannot add ^a to ACL of ^a>^a",
		add_dir_acl (i).user, udd, old_name);
	end;
	n_acladd = n_acladd - 1;
	do i = 1 to n_acladd;
	     add_dir_acl (i).mode = "001"b;
	end;
	call hcs_$add_dir_acl_entries (sc1, "update", addr (add_dir_acl), n_acladd, ec);
	if ec ^= 0 then do i = 1 to n_acladd;
	     if add_dir_acl (i).code ^= 0 then
		call com_err_ (add_dir_acl (i).code, "rename_proj", "Cannot add ^a to ACL of ^a>^a",
		add_dir_acl (i).user, sc1, "update");
	end;

/* Rename the project directory. */

	call hcs_$chname_file (udd, old_name, old_name, new_name, ec);
	if ec ^= 0 then
	     call com_err_ (ec, "rename_proj", "Cannot add name ^a to ^a>^a", new_name, udd, old_name);
	if old_alias ^= "" then
	     call hcs_$chname_file (udd, old_alias, old_alias, new_alias, ec);
	if ec ^= 0 then
	     call com_err_ (ec, "rename_proj", "Cannot add alias ^a to ^a>^a", new_alias, udd, old_alias);

/* Fix up the project's PDT, and then rename it */

	en = old_pdt;
	call hcs_$initiate (sc1_pdt, en, "", 0, 1, pdtp, ec);
	if pdtp = null then go to er2;
	pdt.project_name = new_name;			/* update pdt entries */
	pdt.project_dir = rtrim(udd) || ">" || rtrim(new_name);
	call hcs_$chname_file (sc1_pdt, old_pdt, old_pdt, new_pdt, ec);
	if ec ^= 0 then do;
er2:	     call com_err_ (ec, "rename_proj", "Cannot add name ^a to ^a>^a", new_pdt, sc1_pdt, old_pdt);
	end;
	do ai = 1 to n_acladd;
	     add_dir_acl (ai).mode = "111"b;
	end;
	add_user_dir_acl.mode = "111"b;		/* for user's own home_dir */
	do i = 1 to pdt.current_size;
	     tpp = addr (pdt.user (i));
	     tpp -> user.home_dir = rtrim(pdt.project_dir) || ">" || rtrim(tpp -> user.person_id);
	     call hcs_$add_dir_acl_entries (pdt.project_dir, tpp -> user.person_id, addr (add_dir_acl), n_acladd, ec);
	     if ec ^= 0 then do ai = 1 to n_acladd;
		if add_dir_acl (ai).code ^= 0 then
		     call com_err_ (add_dir_acl (ai).code, "rename_proj", "Cannot add ^a to ACL of ^a>^a", add_dir_acl (ai).user, rtrim(pdt.project_dir), tpp -> user.home_dir);
	     end;
	     call hcs_$delete_dir_acl_entries (pdt.project_dir, tpp -> user.person_id, addr (del_acl), n_acldel, ec);
	     if ec ^= 0 then do ai = 1 to n_acldel;
		if del_acl (ai).code ^= 0 then
		     call com_err_ (del_acl (ai).code, "rename_proj", "Cannot delete ^a from ACL of ^a>^a", del_acl (ai).user, rtrim(pdt.project_dir), tpp -> user.home_dir);
	     end;
	     add_user_dir_acl.user = rtrim(tpp -> user.person_id) || "." || rtrim(new_name) || ".*";
	     del_user_acl.user = rtrim(tpp -> user.person_id) || "." || rtrim(old_name) || ".*";
	     call hcs_$add_dir_acl_entries (pdt.project_dir, rtrim(tpp -> user.person_id), addr (add_user_dir_acl), 1, ec);
	     if ec ^= 0 then do;
		if add_user_dir_acl.code ^= 0 then
		     call com_err_ (add_user_dir_acl.code, "rename_proj", "Cannot add ^a to ACL of ^a", add_user_dir_acl.user, tpp -> user.home_dir);
	     end;
	     call hcs_$delete_dir_acl_entries (pdt.project_dir, rtrim(tpp -> user.person_id), addr (del_user_acl), 1, ec);
	     if ec ^= 0 then do ai = 1 to n_acldel;
		if del_acl (ai).code ^= 0 then
		     call com_err_ (del_acl (ai).code, "rename_proj", "Cannot delete ^a from ACL of ^a>^a", del_acl (ai).user, rtrim(pdt.project_dir), tpp -> user.home_dir);
	     end;
	end;
	tpp = null;

/* Copy the data back. */

	project = Nsate;

/* Create a dummy SAT entry for the old project name.  This entry will be 
   used by up_sat_ to recognize a renamed project based on the state = 3  */

	sat_count = sat.current_size + 1;
	satep = addr (sat.project (sat_count));
	Nsate.state = 3;                                  /* renamed state */
	Nsate.project_id = old_name;                      /* previous name */
	Nsate.project_dir, Nsate.cutoff,
	     Nsate.alias, Nsate.group = "";
	Nsate.pdt_ptr = null ();
	Nsate.max_users, Nsate.n_users,
	     Nsate.min_ring, Nsate.max_ring,
	     Nsate.grace_max, Nsate.days_to_cutoff,
	     Nsate.pct_balance, Nsate.pdir_quota,
	     Nsate.max_foreground, Nsate.max_background,
	     Nsate.abs_foreground_cpu_limit,
	     Nsate.rs_number, Nsate.satpad1,
	     Nsate.chain = 0;
	Nsate.at = ""b;
	do i = 1 to 4;
	     Nsate.admin.userid (i) = "";
	     Nsate.admin.pad (i) = "";
	end;
	Nsate.audit, Nsate.project_authorization,
	     Nsate.satpad = ""b;
	Nsate.groups = "";
	Nsate.dollars_to_cutoff = 0e0;

	project = Nsate;				/* append the dummy */
	sat.current_size = sat_count;                     /* increment size of SAT to
                                                               include dummy entry */

	movelen = lope;
	pp1 -> movetable = pp2 -> movetable;

	movelen = loqe;
	qp1 -> movetable = qp2 -> movetable;

/* Terminate all segments. */

abend:	call hcs_$terminate_noname (pp, ec);
	call hcs_$terminate_noname (pdtp, ec);
	call hcs_$terminate_noname (qp, ec);
/*	call hcs_$terminate_noname (satp, ec);*/
	call terminate_file_ (satp, 36 * (SAT_header_lth + sat.current_size *
	     SAT_entry_lth), TERM_FILE_TRUNC_BC_TERM, (0));
exit1:	if ^mylock then call set_lock_$unlock (sys_admin_data.lock, ec);
	call hcs_$terminate_noname (sadp, ec);
	return;

test:	entry (asc1, audd, asc1p);
dcl (asc1, audd, asc1p) char (*);

	sc1 = asc1;
	udd = audd;
	sc1_pdt = asc1p;
	return;

     end rename_proj;




		    reset_disk_meters.pl1           04/26/88  1220.7rew 04/26/88  1214.7      133974



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



/****^  HISTORY COMMENTS:
  1) change(87-10-06,Parisek), approve(88-02-03,MCR7845),
     audit(88-04-05,Lippard), install(88-04-26,MR12.2-1043):
     Implement multi_segment file application for possible >256K disk_stat
     segment.
                                                   END HISTORY COMMENTS */


/* format: style5,ind5 */

reset_disk_meters:
     procedure options (variable);

/* This program reads the disk usage from "disk_stat" and subtracts the
   value found with the specified directory's tpp.  It is run once a
   month after disk usage has been billed. */

/* Written by THVV.
   Modified on 5 June 1975 by J. C. Whitmore to set system_privileges if possible
   Modified April 1976 by T. Casey to reset directory page tpp as well as segent page tpp.
   Modified 1985-02-20 by E. Swenson to work with the new directory control.
*/

     sp = null ();				      /* for cleanup handler */
     undop = null ();			      /* ditto */
     set_privileges = "0"b;			      /* ditto */
     forced_access = "0"b;			      /* we haven't yet */
     on condition (cleanup) call CLEAN_UP ();

     acla.userid = get_group_id_ ();
     dacl.userid = acla.userid;
     acla.mode = SMA_ACCESS;
     path = "disk_stat";			      /* Find the disk statistics file. */

     an = 0;				      /* set argument index to 0, initially */
     more_args = "1"b;			      /* initially */
     do while (more_args);
	an = an + 1;			      /* bump argument number */
	call cu_$arg_ptr (an, ap, al, ec);
	if ec ^= 0 then
	     more_args = "0"b;
	else
	     do;
	     if bchr = "-brief" then
		brief_sw = "1"b;
	     else if bchr = "-bf" then
		brief_sw = "1"b;
	     else if substr (bchr, 1, 1) = "-" then
		call com_err_ (error_table_$badopt, ME, "^a", bchr);
	     else
		path = bchr;
	     end;
     end;

     ti = 0;

     call expand_pathname_ (path, dn, en, ec);
     if ec ^= 0 then
	do;
	call com_err_ (ec, ME, "^a", path);
	return;
	end;

     call msf_manager_$open (dn, en, fcbp, ec);	
     if ec ^= 0 then
	do;
	call com_err_ (ec, ME, "Cannot open msf.");
	return;
	end;
     acpx, cpx = 0;	
cpx_loop:
     call msf_manager_$get_ptr (fcbp, cpx, "0"b, cp_array (cpx), 0, ec);
     if ec = 0 then do;
	cpx = cpx + 1;
	goto cpx_loop;
     end;
     
     working_dir = get_wdir_ ();
     call initiate_file_ (working_dir, "projfile", RW_ACCESS, pp, (0), ec);
     if ec ^= 0 then
	do;
	call com_err_ (ec, ME, "^a", pathname_ (working_dir, "projfile"));
	call CLEAN_UP ();
	return;
	end;

     call get_temp_segment_ (ME, undop, ec);
     if ec ^= 0 then
	do;
	call com_err_ (ec, ME, "Getting temporary segment.");
	call CLEAN_UP ();
	return;
	end;

     sp = cp_array (0);	
     n = disk_stat.dents;			      /* Get number of entries. */

     call check_gate_access_ ("system_privilege_", codeptr (reset_disk_meters),
         ec);
     if ec ^= 0 then
	call com_err_ (ec, ME,
	    "system_privilege_.  Cannot enable directory privileges.  Access to storage system may not be complete"
	    );
     else
	do;
	call system_privilege_$dir_priv_on (priv_set_already);
	if priv_set_already = 1 then
	     set_privileges = "1"b;
	end;


     call ioa_ ("^a: Resetting disk for ^d directories.", ME, n);

     last_n = n;
comp_loop:
     do i = 1 to last_n;				/* Loop through all directories. */
	dn = spth (i);				/* Get the name of the directory. */

	call get_quota ("segment");
	if code ^= 0 then
	     xqta = 0;			      /* avoid trying to reset it */
	call get_quota ("directory");
	if code ^= 0 then
	     dir_xqta = 0;			      /* avoid trying to reset it */

	if xqta > 0 then
	     call reset_quota ("segment", xtpp, disk_stat.stpp (i));
	if dir_xqta > 0 then
	     call reset_quota ("directory", dir_xtpp, disk_stat.dtpp (i));

/**** The following call will terminate the specified directory in some
      cases and is helpful in cleaning up the address space.  It is not
      guaranteed to work in all cases, so we ignore the error code. */

	call hcs_$terminate_file (dn, "", 0, (0));

	if (lodh + (i+1) * lode) > sys_info$max_seg_size then do;
	     ti = ti + i;		
	     last_n = n - ti;
	     acpx = acpx + 1;
	     sp = cp_array (acpx);
	     goto comp_loop;
	end;
     end;

/**** Now reset the field in the projfile which corresponds to disk
      usage */

     do i = 1 to projfile.nproj;
	projfile.projfiletab (i).disk_psec = 0;
     end;

     sp = cp_array (0);
     disk_stat.dreset = disk_stat.dtime;
     disk_stat.dtime = clock ();

     call ioa_ ("^a: Disk usage reset.", ME);

     call CLEAN_UP ();
     return;
%page;
CLEAN_UP:
     procedure ();

     if set_privileges then
	call system_privilege_$dir_priv_off ((0));

     if fcbp ^= null () then
	call msf_manager_$close (fcbp);

     if sp ^= null () then sp = null ();

     if undop ^= null then
	do;
	if forced_access | (n_undo > 0) then
	     do i = n_undo to 1 by -1;
		call hcs_$delete_dir_acl_entries ((undo (i).dir),
		    (undo (i).ent), addr (dacl), 1, code);
		if code ^= 0 then
		     call com_err_ (code, ME,
		         "Could not reset access to ^a",
		         pathname_ ((undo (i).dir), (undo (i).ent)));
	     end;


	call release_temp_segment_ (ME, undop, (0));
	undop = null ();
	end;

     return;
     end CLEAN_UP;
%page;
get_quota:
     procedure (Seg_dir);

     dcl	   Seg_dir	       char (*) parameter;

     dcl	   i		       fixed bin (17);
     dcl	   try_again	       bit (1) aligned;

     try_again = "1"b;
     do i = 1 to 2 while (try_again);
	if Seg_dir = "segment" then
	     call hcs_$quota_read (dn, xqta, xtpp, (""b), (""b), (0), (0),
	         code);
	else
	     call hcs_$dir_quota_read (dn, dir_xqta, dir_xtpp, (""b), (""b),
	         (0), (0), code);
	if code = 0 then
	     try_again = "0"b;		      /* no need */
	else if i = 1 then			      /* if we haven't tried to force access yet */
	     do;
	     call force_access (dn, code);
	     if code ^= 0 then
		try_again = "0"b;		      /* no sense */
	     end;
     end;

     if code ^= 0 then
	call com_err_ (code, ME, "Cannot get ^a quota for ^a", Seg_dir, dn);
     return;

     end get_quota;
%page;
force_access:
     procedure (Dir, Code) recursive;

     dcl	   Dir		       char (168);
     dcl	   Code		       fixed bin (35);

     dcl	   td		       char (168);
     dcl	   te		       char (32);
     dcl	   i		       fixed bin;
     dcl	   j		       fixed bin;
     dcl	   try_again	       bit (1) aligned;

     if code ^= error_table_$moderr then
	if code ^= error_table_$no_info then
	     if code ^= error_table_$incorrect_access then
		return;

     j = 168;
     do while (substr (Dir, j, 1) ^= ">");
	j = j - 1;
     end;

     td = substr (Dir, 1, j - 1);
     te = substr (Dir, j + 1);

     n_undo = n_undo + 1;
     undo (n_undo).dir = td;
     undo (n_undo).ent = te;

     try_again = "1"b;
     if ^brief_sw then
	call ioa_ ("^a: Now forcing access to ^a", ME, Dir);
     do i = 1 to 2 while (try_again);
	call hcs_$add_dir_acl_entries (td, te, addr (acla), 1, code);
	if code = 0 then
	     do;
	     if forced_access = "0"b then
		forced_access = "1"b;
	     try_again = "0"b;		      /* no need */
	     end;
	else
	     do;				      /* could not set access */
	     call force_access (td, code);	      /* recurse */
	     if code ^= 0 then
		try_again = "0"b;		      /* wouldn't do any good */
	     end;
     end;
     end force_access;
%page;
reset_quota:
     procedure (Seg_dir, Cur_tpp, Reset_tpp);

     dcl	   Seg_dir	       char (*) parameter;
     dcl	   Cur_tpp	       fixed bin (71) parameter;
     dcl	   Reset_tpp	       fixed bin (71) parameter;

     dcl	   i		       fixed bin;
     dcl	   try_again	       bit (1) aligned;

     if Cur_tpp < Reset_tpp then
	if ^brief_sw then
	     call com_err_ (0, ME,
	         "^a would get negative ^a tpp ^.1f - ignored", dn, Seg_dir,
	         (Cur_tpp - Reset_tpp) / 86400e0);
	else
	     ;

     else
	do;
	try_again = "1"b;
	do i = 1 to 2 while (try_again);
	     call RESET_TPP (Seg_dir, dn, Reset_tpp, code);
	     if code = 0 then
		try_again = "0"b;		      /* no need */
	     else if i = 1 then		      /* if we haven't tried to force access yet */
		do;
		call force_access (dn, code);
		if code ^= 0 then
		     try_again = "0"b;	      /* no sense */
		end;
	end;

	if code ^= 0 then
	     call com_err_ (code, ME, "Cannot reset ^a tpp on ^a", Seg_dir,
	         dn);
	end;
     return;

     end reset_quota;
%page;
RESET_TPP:
     procedure (Seg_dir, Dir_name, Reset_tpp, Code);

     dcl	   Seg_dir	       char (*) parameter;
     dcl	   Dir_name	       char (*) parameter;
     dcl	   Reset_tpp	       fixed bin (71) parameter;
     dcl	   Code		       fixed bin (35) parameter;

     if ^debugging then
	do;
	if Seg_dir = "segment" then
	     call hphcs_$get_reset_quota (dn, Reset_tpp, Code);
	else
	     call hphcs_$dir_get_reset_quota (dn, Reset_tpp, Code);
	end;
     else
	Code = 0;
     return;
     end RESET_TPP;
%page;
/* Declarations */

/* Automatic */

     dcl     acpx                    fixed bin;         /* msf counter */
     dcl	   path		       char (168);
     dcl	   dn		       char (168);
     dcl	   en		       char (32);
     dcl	   ec		       fixed bin (35);    /* status code */
     dcl	   code		       fixed bin (35);    /* status code */
     dcl     cpx                     fixed bin;         /* msf counter */
     dcl     fcbp                    ptr;
     dcl	   ap		       ptr;	      /* argument pointer */
     dcl	   al		       fixed bin (21);    /* argument length */
     dcl	   brief_sw	       bit (1) aligned initial ("0"b);
     dcl	   an		       fixed bin;	      /* argument number */
     dcl	   pp		       ptr;	      /* pointer to projfile */
     dcl	   undop		       ptr;	      /* pointer to table of directories to undo access for */
     dcl	   xqta		       fixed bin (18);
     dcl	   dir_xqta	       fixed bin (18);
     dcl	   xtpp		       fixed bin (71);
     dcl	   dir_xtpp	       fixed bin (71);
     dcl	   i		       fixed bin;	      /* index */
     dcl	   n		       fixed bin;	      /* index */
     dcl	   set_privileges	       bit (1) aligned;
     dcl	   more_args	       bit (1) aligned;
     dcl	   priv_set_already	       fixed bin (35);
     dcl	   working_dir	       char (168);
     dcl	   forced_access	       bit (1) aligned;   /* whether we have or not */
     dcl     last_n                  fixed bin;
     dcl     ti                      fixed bin;

     dcl	   1 acla		       aligned,
	     2 userid	       char (32),
	     2 mode	       bit (36),
	     2 rcode	       fixed bin (35);

     dcl	   1 dacl		       aligned,
	     2 userid	       char (32),
	     2 rcode	       fixed bin (35);

     dcl     cp_array                (0:4) ptr;


/* Conditions */

     dcl	   cleanup	       condition;

/* Based */

     dcl	   bchr		       char (al) based (ap) unaligned;
					      /* argument */
     dcl	   1 undoseg	       based (undop) aligned,
	     2 n_undo	       fixed bin,
	     2 upad	       (7) fixed bin,
	     2 undo	       (100),
	       3 dir	       char (168),
	       3 ent	       char (32);

/* Builtin */

     dcl	   addr		       builtin;
     dcl	   clock		       builtin;
     dcl     codeptr                 builtin;
     dcl	   null		       builtin;
     dcl	   substr		       builtin;

/* External */

     dcl	   error_table_$badopt     fixed bin (35) external;
     dcl	   error_table_$incorrect_access
			       fixed bin (35) external;
     dcl	   error_table_$no_info    fixed bin (35) external;
     dcl	   error_table_$moderr     fixed bin (35) external;

     dcl     sys_info$max_seg_size   fixed bin (35) external static;

/* Entries */

     dcl	   check_gate_access_      entry (char (*), ptr, fixed bin (35));
     dcl	   com_err_	       entry options (variable);
     dcl	   cu_$arg_ptr	       entry (fixed bin, ptr, fixed bin (21),
			       fixed bin (35));

     dcl	   expand_pathname_	       entry (char (*), char (*), char (*),
			       fixed bin (35));

     dcl	   get_group_id_	       entry returns (char (32) aligned);
     dcl	   get_temp_segment_       entry (char (*), ptr, fixed bin (35));
     dcl	   get_wdir_	       entry () returns (char (168));
     dcl	   hcs_$add_dir_acl_entries
			       entry (char (*), char (*), ptr, fixed bin,
			       fixed bin (35));
     dcl	   hcs_$delete_dir_acl_entries
			       entry (char (*), char (*), ptr, fixed bin,
			       fixed bin (35));
     dcl	   hcs_$quota_read	       entry (char (*), fixed bin (18),
			       fixed bin (71), bit (36) aligned, bit (36),
			       fixed bin (1), fixed bin (18),
			       fixed bin (35));
     dcl	   hcs_$dir_quota_read     entry (char (*), fixed bin (18),
			       fixed bin (71), bit (36) aligned, bit (36),
			       fixed bin (1), fixed bin (18),
			       fixed bin (35));
     dcl	   hcs_$terminate_file     entry (char (*), char (*), fixed bin (1),
			       fixed bin (35));
     dcl	   hphcs_$get_reset_quota  entry (char (*), fixed bin (71),
			       fixed bin (35));
     dcl	   hphcs_$dir_get_reset_quota
			       entry (char (*), fixed bin (71),
			       fixed bin (35));
     dcl	   initiate_file_	       entry (char (*), char (*), bit (*), ptr,
			       fixed bin (24), fixed bin (35));
     dcl	   ioa_		       entry options (variable);
     dcl     msf_manager_$close      entry (ptr);
     dcl     msf_manager_$get_ptr    entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
     dcl     msf_manager_$open       entry (char (*), char (*), ptr, fixed bin (35));
     dcl	   pathname_	       entry (char (*), char (*))
			       returns (char (168));
     dcl	   release_temp_segment_   entry (char (*), ptr, fixed bin (35));
     dcl	   system_privilege_$dir_priv_on
			       entry (fixed bin (35));
     dcl	   system_privilege_$dir_priv_off
			       entry (fixed bin (35));

/* Constants */

     dcl	   debugging	       bit (1) aligned initial ("0"b)
			       internal static options (constant);
     dcl	   ME		       char (32)
			       initial ("reset_disk_meters")
			       internal static options (constant);

/* format: off */
%page; %include access_mode_values;
%page; %include disk_stat;
%page; %include projfile;
/* format: on */

     end reset_disk_meters;




		    reset_proj.pl1                  07/13/88  1122.2r w 07/13/88  0941.2       74493



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


/* Procedure to subtract resource usage from a PDT in an admin directory from resource usage info
   in the system copy of a PDT: this procedure modifies the system copy only.
   See the "reset_usage" command for a command which does all pdt's listed in a SAT.

   This procedure takes two arguments:

   1) path of system copy of Project Definition Table (PDT)
   2) path of admin copy of PDT

   THVV 7/73
   Janice B. Phillipps, April 14, 1972
   Modified by R. McDonald May 1980 to include page charges.
*/


reset_proj: procedure;

dcl (argp, hp, sp, pp, cp, cpdtp, pdtp, pdtep, satp, satep, csatp) ptr,
    (arglg, code, i, j, k, kk) fixed bin,
     delta fixed bin,
     doubledelta fixed bin (71),
     doubletime fixed bin (71),
     deltafloat float bin,
     twodays fixed bin (35) int static init (2880000000);

dcl (addr, null, divide) builtin;

dcl  c32 char (32) aligned,
     pdt_name char (32) aligned,
     pdt_dir char (168) aligned,
     cpdt_dir char (168) aligned;

dcl  clock_ entry () returns (fixed bin (71)),
     com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     hcs_$delentry_file entry (char (*) aligned, char (*) aligned, fixed bin),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     hcs_$truncate_seg entry (ptr, fixed bin, fixed bin),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin),
     set_lock_$unlock entry (bit (36) aligned, fixed bin);

dcl  error_table_$lock_wait_time_exceeded fixed bin ext;



%include user_attributes;
%include pdt;


/* ======================================================= */

	doubletime = clock_ ();			/* get time for PDT time_last_update */

	call cu_$arg_ptr (1, argp, arglg, code);
	if code ^= 0 then do;
error:	     call com_err_ (code, "reset_proj", "");
	     return;
	end;
	call expand_path_ (argp, arglg, addr (pdt_dir), addr (pdt_name), code);
	if code ^= 0 then go to error;
	call cu_$arg_ptr (2, argp, arglg, code);
	if code ^= 0 then go to error;
	call expand_path_ (argp, arglg, addr (cpdt_dir), addr (pdt_name), code);
	if code ^= 0 then go to error;

	call hcs_$initiate (cpdt_dir, pdt_name, "", 0, 0, cpdtp, code); /* initiate admin copy of PDT */
	if cpdtp = null then go to error;
	call hcs_$initiate (pdt_dir, pdt_name, "", 0, 0, pdtp, code); /*  get ptr to sys version of the PDT */
	if pdtp = null then go to error;

	do j = 1 to pdt.current_size;			/* loop thru each PDT to reset all users */
	     sp = addr (pdtp -> pdt.user (j));		/* system copy of PDT */
	     cp = addr (cpdtp -> pdt.user (j));		/* admin copy of PDT */
	     if sp -> user.state = 2 then do;		/* if user was deleted during month, free up slot on chain */
		sp -> user.state = 0;
		sp -> user.chain = pdtp -> pdt.freep;
		pdtp -> pdt.freep = j;		/* index of freed slot on chain */
	     end;
	     else if sp -> user.state = 1 then do;

		if sp -> user.person_id ^= cp -> user.person_id then do;
		     call com_err_ (0, "reset_proj",
			"copy of ^a is out of phase; name in system copy: ^a name in admin copy: ^a; Continuing to next user.",
			pdt_name, sp -> user.person_id, cp -> user.person_id);
		     go to skip1;			/* set next user */
		end;

		call set_lock_$lock (sp -> user.lock, 600, code); /* lock data base while resetting */
		if code = error_table_$lock_wait_time_exceeded then do;
		     call com_err_ (code, "reset_proj", "^a ^a", pdt_name, sp -> user.person_id);
		     go to locked;
		end;
		if doubletime - sp -> user.time_last_reset < twodays then do;
		     call com_err_ (code, "reset_proj",
			"Warning, reset_proj has been run within last two days!",
			"Skipping over ^a.^a", sp -> user.person_id, pdt_name);
		     go to skip1;
		end;

		deltafloat = sp -> user.dollar_charge - cp -> user.dollar_charge; /* total user charge */
		if deltafloat >= 0 then
		     sp -> user.dollar_charge = deltafloat;

		delta = sp -> user.logins - cp -> user.logins;
		if delta >= 0 then
		     sp -> user.logins = delta;	/* number of logins */
		delta = sp -> user.crashes - cp -> user.crashes; /* sessions abnormally terminated */
		if delta >= 0 then
		     sp -> user.crashes = delta;


		do k = 0 to 7;			/* interactive use shifts 0 - 7 */
		     deltafloat = sp -> user.interactive.charge (k) - cp -> user.interactive.charge (k);
		     if deltafloat >= 0e0 then
			sp -> user.interactive.charge (k) = deltafloat; /* total dollar charge this shift */

		     doubledelta = sp -> user.interactive.cpu (k) - cp -> user.interactive.cpu (k);
		     if doubledelta >= 0 then
			sp -> user.interactive.cpu (k) = doubledelta; /* cpu usage in microseconds */

		     doubledelta = sp -> user.interactive.core (k) - cp -> user.interactive.core (k);
		     if doubledelta >= 0 then
			sp -> user.interactive.core (k) = doubledelta;

		     doubledelta = sp -> user.interactive.connect (k) - cp -> user.interactive.connect (k);
		     if doubledelta >= 0 then
			sp -> user.interactive.connect (k) = doubledelta; /* total console time in microseconds */

		     doubledelta = sp -> user.interactive.io_ops (k) - cp -> user.interactive.io_ops (k);
		     if doubledelta >= 0 then
			sp -> user.interactive.io_ops (k) = doubledelta; /* total io_ops time in microsecs */
		end;

		do k = 1 to 4;			/* absentee use of queues 1 - 4 */
		     deltafloat = sp -> user.absentee.charge (k) - cp -> user.absentee.charge (k);
		     if deltafloat >= 0 then
			sp -> user.absentee.charge (k) = deltafloat; /* dollar charge this queue */

		     delta = sp -> user.absentee.jobs (k) - cp -> user.absentee.jobs (k); /* jobs submitted */
		     if delta >= 0 then
			sp -> user.absentee.jobs (k) = delta;

		     doubledelta = sp -> user.absentee.cpu (k) - cp -> user.absentee.cpu (k); /* time in usecs */
		     if doubledelta >= 0 then
			sp -> user.absentee.cpu (k) = doubledelta;

		     doubledelta = sp -> user.absentee.memory (k) - cp -> user.absentee.memory (k);
		     if doubledelta >= 0 then
			sp -> user.absentee.memory (k) = doubledelta;

		end;

		do k = 1 to 4;			/* io daemon use queues 1 - 4 */
		     deltafloat = sp -> user.iod.charge (k) - cp -> user.iod.charge (k); /* $ charge this queue */
		     if deltafloat >= 0e0 then
			sp -> user.iod.charge (k) = deltafloat;

		     delta = sp -> user.iod.pieces (k) - cp -> user.iod.pieces (k);
		     if delta >= 0 then
			sp -> user.iod.pieces (k) = delta;

		     doubledelta = sp -> user.iod.pages (k) - cp -> user.iod.pages (k);
		     if doubledelta >= 0 then
			sp -> user.iod.pages (k) = doubledelta;

		     doubledelta = sp -> user.iod.lines (k) - cp -> user.iod.lines (k);
		     if doubledelta >= 0 then
			sp -> user.iod.lines (k) = doubledelta;

		end;

		do k = 1 to 16;			/* device charges */
		     deltafloat = sp -> user.devices (k) - cp -> user.devices (k);
		     if deltafloat >= 0 then
			sp -> user.devices (k) = deltafloat;
		end;

		sp -> user.time_last_reset = doubletime;
		call set_lock_$unlock (sp -> user.lock, code);
	     end;


	     go to skip1;
locked:	     call ioa_ ("Continuing on to next user.");
	     go to skip1;
neg_delta:     if sp -> user.state ^= 0 then do;
		call com_err_ (code, "reset_proj", "Warning, encountered a negative delta for ^a.^a",
		     sp -> user.person_id, pdt_name);
	     end;
skip1:	end;					/* end of user loop */
	call hcs_$terminate_noname (pdtp, code);
	call hcs_$terminate_noname (cpdtp, code);

     end reset_proj;




		    reset_usage.pl1                 07/13/88  1122.2r w 07/13/88  0941.2      161757



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




/****^  HISTORY COMMENTS:
  1) change(86-09-26,Parisek), approve(87-06-17,MCR7570),
     audit(87-06-15,Hirneisen), install(87-08-06,MR12.1-1066):
     Free renamed projects (state = 3) in the SAT also.
                                                   END HISTORY COMMENTS */



/* format: style5,ind5 */

reset_usage:
     procedure () options (variable);

/**** This program substracts the resource usage in the saved admin
      copy of the PDTs (copied via the crank) from the resource usage
      figures in the real, live copy of the corresponding PDT.

      This program MODIFIES the system copy of the PDTs and in the case
      of delete projects, the SAT as well.

      This program takes four arguments:

      1) pathname of system copy of the SAT
      2) pathname of system copy of the directory containing PDTs
      3) pathname of the admin copy of the SAT (not used)
      4) pathname of the admin copy of the directory containing PDTs. */

/* Written by Janice B. Phillipps, April 14, 1972
   Revised 8/3/72 J. Phillipps
   Modified by R. McDonald May 1980 to include page charges
   Modified 1894-07-11 BIM for cleanup handler!
   Modified 1984-10-31 by E. Swenson to not attempt to terminate PDTs
   that were not initiated.  Also use current declaration of external
   entries.
   Modified 1985-04-10 by E. Swenson to work if a user has been added to
   the PDT after the crank has copied the PDTs.  Also re-written to use
   modern programming techniques and routines.  Fixed cleanup handler
   introduced above.
*/

/* Automatic */

     dcl	   argument_lth	       fixed bin (21);
     dcl	   argument_ptr	       ptr;
     dcl	   code		       fixed bin (35);
     dcl	   cpdt_dir	       char (168);	      /* location of admin copy of PDTs */
     dcl	   n_arguments	       fixed bin;
     dcl	   pdt_dir	       char (168);	      /* location of system copy of PDTs */
     dcl	   pdt_name	       char (32);	      /* entryname of the pdt directory */
     dcl	   sat_dir	       char (168);	      /* location of system copy of sat */
     dcl	   sat_name	       char (32);	      /* entryname of the sat */
     dcl	   sci_ptr	       ptr;	      /* pointer to subsystem invocation */
     dcl	   sp		       ptr;
     dcl	   cp		       ptr;
     dcl	   cpdtp		       ptr;
     dcl	   pdtp		       ptr;
     dcl	   pdtep		       ptr;
     dcl	   satp		       ptr;
     dcl	   satep		       ptr;
     dcl	   (i, j, k, kk)	       fixed bin;
     dcl	   delta		       fixed bin;
     dcl	   doubledelta	       fixed bin (71);
     dcl	   current_time	       fixed bin (71);    /* time of this PDT update */
     dcl	   deltafloat	       float bin;
     dcl	   twodays	       fixed bin (35) int static
			       init (2880000000);
     dcl	   baderrct	       fixed bin;
     dcl	   locked_pdtep	       pointer;

/* Based */

     dcl	   argument	       char (argument_lth) based (argument_ptr);

/* Conditions */

     dcl	   cleanup	       condition;

/* Builtin */

     dcl	   addr		       builtin;
     dcl	   clock		       builtin;
     dcl	   null		       builtin;
     dcl	   unspec		       builtin;

/* Constant */

     dcl	   ME		       char (32) initial ("reset_usage")
			       internal static options (constant);

/* External Entries */

     dcl	   absolute_pathname_      entry (char (*), char (*), fixed bin (35));
     dcl	   com_err_	       entry () options (variable);
     dcl	   cu_$arg_list_ptr	       entry () returns (ptr);
     dcl	   delete_$path	       entry (char (*), char (*),
			       bit (36) aligned, char (*), fixed bin (35))
			       ;
     dcl	   expand_pathname_	       entry (char (*), char (*), char (*),
			       fixed bin (35));
     dcl	   get_lock_id_	       entry returns (bit (36) aligned);
     dcl	   initiate_file_	       entry (char (*), char (*), bit (*), ptr,
			       fixed bin (24), fixed bin (35));
     dcl	   ioa_$rsnnl	       entry options (variable);
     dcl	   pathname_	       entry (char (*), char (*))
			       returns (char (168));
     dcl	   ssu_$abort_line	       entry () options (variable);
     dcl	   ssu_$arg_count	       entry (ptr, fixed bin);
     dcl	   ssu_$arg_ptr	       entry (ptr, fixed bin, ptr, fixed bin (21))
			       ;
     dcl	   ssu_$destroy_invocation entry (ptr);
     dcl	   ssu_$print_message      entry () options (variable);
     dcl	   ssu_$standalone_invocation
			       entry (ptr, char (*), char (*), ptr, entry,
			       fixed bin (35));
     dcl	   set_lock_$lock	       entry (bit (36) aligned, fixed bin,
			       fixed bin (35));
     dcl	   set_lock_$unlock	       entry (bit (36) aligned, fixed bin (35));
     dcl	   terminate_file_	       entry (ptr, fixed bin (24), bit (*),
			       fixed bin (35));

/* External Static */

     dcl	   error_table_$lock_wait_time_exceeded
			       fixed bin ext;
%page;

/* Program */

     sci_ptr = null ();
     locked_pdtep = null ();
     satp = null ();
     pdtp = null ();
     cpdtp = null ();

     on condition (cleanup) call CLEAN_UP ();

     call ssu_$standalone_invocation (sci_ptr, ME, "1.0", cu_$arg_list_ptr (),
         SSU_ABORT, code);
     if code ^= 0 then
	do;
	call com_err_ (code, ME, "Unable to create subsystem invocation.");
	return;
	end;

     call PROCESS_ARGUMENTS ();

     current_time = clock ();			      /* get time for PDT time_last_update */

/**** Set up delete_options structure in case we need it for delete_. */

     unspec (delete_options) = ""b;
     delete_options.force = "1"b;		      /* ignore safety switch */
     delete_options.segment = "1"b;		      /* pdts are segments */
     delete_options.raw = "1"b;		      /* use hcs_ to delete, not fs_util_ */

/**** Loop through all the projects in the SAT. */

     do i = 1 to satp -> sat.current_size;
	satep = addr (satp -> sat.project (i));	      /* locate a PDT */
	call ioa_$rsnnl ("^a.pdt", pdt_name, kk, satep -> project.project_id);
	call PROCESS_PROJECT ();
     end;

ABORT_LABEL:
     call CLEAN_UP ();
     return;
%page;
PROCESS_ARGUMENTS:
     procedure ();

/**** This internal procedure processes the arguments of reset_usage.  It
      ensures that all required arguments are present and initiates the
      system copy of the sat. */

     call ssu_$arg_count (sci_ptr, n_arguments);
     if n_arguments ^= 4 then
	call ssu_$abort_line (sci_ptr, 0,
	    "Usage: ^a system_sat system_pdt_dir admin_sat_copy admin_pdt_copy_dir",
	    ME);

     call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth);
     call expand_pathname_ (argument, sat_dir, sat_name, code);
     if code ^= 0 then
	call ssu_$abort_line (sci_ptr, code, "^a", argument);

     call ssu_$arg_ptr (sci_ptr, 2, argument_ptr, argument_lth);
     call absolute_pathname_ (argument, pdt_dir, code);
     if code ^= 0 then
	call ssu_$abort_line (sci_ptr, code, "^a", argument);

/**** Note that we do not use the admin copy of the SAT.  For
      compatibility, we do not change the calling sequence. */

     call ssu_$arg_ptr (sci_ptr, 4, argument_ptr, argument_lth);
     call absolute_pathname_ (argument, cpdt_dir, code);
     if code ^= 0 then
	call ssu_$abort_line (sci_ptr, code, "^a", argument);

/**** Now initiate the system copy of the SAT. */

     call initiate_file_ (sat_dir, sat_name, RW_ACCESS, satp, (0), code);
     if code ^= 0 then
	call ssu_$abort_line (sci_ptr, code, "^a",
	    pathname_ (sat_dir, sat_name));

     end PROCESS_ARGUMENTS;
%page;
PROCESS_PROJECT:
     procedure ();

     if satep -> project.state = 1 then
	do;				      /* if project active */
/**** Initiate admin copy of PDT. */

	call initiate_file_ (cpdt_dir, pdt_name, R_ACCESS, cpdtp, (0), code);
	if code ^= 0 then
PDT_INIT_ERROR:
	     do;
	     call ssu_$print_message (sci_ptr, 0, "Could not initiate ^a.",
	         pathname_ (cpdt_dir, pdt_name));
	     return;			      /* skip this PDT entry */
	     end;

	call initiate_file_ (pdt_dir, pdt_name, RW_ACCESS, pdtp, (0), code);
	if code ^= 0 then
	     do;
	     call terminate_file_ (cpdtp, 0, TERM_FILE_TERM, (0));
	     goto PDT_INIT_ERROR;
	     end;

/**** Now go through each entry in the PDT. */

	do j = 1 to pdtp -> pdt.current_size;	      /* loop thru each PDT to reset all users */

/**** The following check ensures that the system PDT entry we are examining
      has not been added since the PDT copy was made.  Actually, another
      check in PROCESS_USER makes another check for the same reason */

	     if j ^> cpdtp -> pdt.current_size then
		do;
		sp = addr (pdtp -> pdt.user (j));   /* system copy of PDT */
		cp = addr (cpdtp -> pdt.user (j));  /* admin copy of PDT */
		call PROCESS_USER ();
		end;
	end;

	if pdtp ^= null () then
	     call terminate_file_ (pdtp, 0, TERM_FILE_TERM, (0));
	if cpdtp ^= null () then
	     call terminate_file_ (cpdtp, 0, TERM_FILE_TERM, (0));
	end;
     else if satep -> project.state = 2 | satep -> project.state = 3 then
	do;
	satep -> project.state = 0;		      /* free slot of deleted project */
	satep -> project.chain = satp -> sat.freep;
	satp -> sat.freep = i;		      /* index of free slot on chain */
					      /* threaded slot of deleted project on free list */
	call delete_$path (pdt_dir, pdt_name, unspec (delete_options), ME,
	    (0));
	end;
     else if satep -> project.state = 0 then	      /* no project here */
	;
     else
	do;				      /* Well what is it then? */
	call ssu_$print_message (sci_ptr, 0,
	    "project.state (^d) invalid for project ^a", project.state,
	    project.project_id);
	end;
     return;

     end PROCESS_PROJECT;
%page;
PROCESS_USER:
     procedure ();

     if sp -> user.state = 0 then
	;				      /* state = 0, no user entry */
     else if sp -> user.state = 1 then
	do;				      /* user active -- subtract usage */
/**** But first, some consistency checks */
	if cp -> user.state = 0 then		      /* person added after copy */
	     return;			      /* no usage since he is new */
	if sp -> user.person_id ^= cp -> user.person_id then
	     do;
	     call ssu_$print_message (sci_ptr, 0,
	         "Admin copy of ^a is out of phase with system copy.  System copy = ^a, Admin copy = ^a.",
	         satep -> project.project_id, sp -> user.person_id,
	         cp -> user.person_id);
	     return;
	     end;

	baderrct = 0;			      /* no errors yet */

	call RESET_USER_USAGE ();

	if baderrct > 0 then		      /* any errors? */
	     do;
	     call ssu_$print_message (sci_ptr, 0,
	         "Warning:  Encountered a negative delta for user ^a on project ^a.",
	         sp -> user.person_id, satep -> project.project_id);
	     end;
	end;
      else if sp -> user.state = 2 then
	do;				      /* user deleted -- add entry to free chain */
	sp -> user.state = 0;		      /* make entry unused */
	sp -> user.chain = pdtp -> pdt.freep;	      /* add to free chain */
	pdtp -> pdt.freep = j;		      /* index of freed slot on chain */
	end;
     else					      /* invalid state */
	call ssu_$print_message (sci_ptr, 0,
	    "Warning: Invalid state (^d) for user ^a on project ^a.",
	    sp -> user.state, sp -> user.person_id,
	    satep -> project.project_id);

     return;

     end PROCESS_USER;
%page;
RESET_USER_USAGE:
     procedure ();

     call LOCK_PDT ();
     if code ^= 0 then
	return;				      /* message already printed */

     if (current_time - sp -> user.time_last_reset < twodays) then
	do;
	call ssu_$print_message (sci_ptr, code,
	    "Warning: PDT usage has been reset within the last two days.  Skipping user ^a on project ^a.",
	    sp -> user.person_id, satep -> project.project_id);
	call UNLOCK_PDT ();
	return;
	end;

     deltafloat = sp -> user.dollar_charge - cp -> user.dollar_charge;
					      /* total user charge */
     if deltafloat >= 0 then
	sp -> user.dollar_charge = deltafloat;
     else
	baderrct = baderrct + 1;

     delta = sp -> user.logins - cp -> user.logins;
     if delta >= 0 then
	sp -> user.logins = delta;		      /* number of logins */
     else
	baderrct = baderrct + 1;

     delta = sp -> user.crashes - cp -> user.crashes;   /* sessions abnormally terminated */
     if delta >= 0 then
	sp -> user.crashes = delta;
     else
	baderrct = baderrct + 1;

     do k = 0 to 7;				      /* interactive use shifts 0 - 7 */
	deltafloat =
	    sp -> user.interactive.charge (k)
	    - cp -> user.interactive.charge (k);
	if deltafloat >= 0e0 then
	     sp -> user.interactive.charge (k) = deltafloat;
					      /* total dollar charge this shift */
	else
	     baderrct = baderrct + 1;

	doubledelta =
	    sp -> user.interactive.cpu (k) - cp -> user.interactive.cpu (k);
	if doubledelta >= 0 then
	     sp -> user.interactive.cpu (k) = doubledelta;
					      /* cpu usage in microseconds */
	else
	     baderrct = baderrct + 1;

	doubledelta =
	    sp -> user.interactive.core (k) - cp -> user.interactive.core (k);
	if doubledelta >= 0 then
	     sp -> user.interactive.core (k) = doubledelta;
	else
	     baderrct = baderrct + 1;

	doubledelta =
	    sp -> user.interactive.connect (k)
	    - cp -> user.interactive.connect (k);
	if doubledelta >= 0 then
	     sp -> user.interactive.connect (k) = doubledelta;
					      /* total console time in microseconds */
	else
	     baderrct = baderrct + 1;

	doubledelta =
	    sp -> user.interactive.io_ops (k)
	    - cp -> user.interactive.io_ops (k);
	if doubledelta >= 0 then
	     sp -> user.interactive.io_ops (k) = doubledelta;
					      /* total io_ops time in microsecs */
	else
	     baderrct = baderrct + 1;

     end;					      /* end processing interactive usage */

     do k = 1 to 4;				      /* absentee use of queues 1 - 4 */
	deltafloat =
	    sp -> user.absentee.charge (k) - cp -> user.absentee.charge (k);
	if deltafloat >= 0 then
	     sp -> user.absentee.charge (k) = deltafloat;
					      /* dollar charge this queue */
	else
	     baderrct = baderrct + 1;

	delta = sp -> user.absentee.jobs (k) - cp -> user.absentee.jobs (k);
					      /* jobs submitted */
	if delta >= 0 then
	     sp -> user.absentee.jobs (k) = delta;
	else
	     baderrct = baderrct + 1;

	doubledelta =
	    sp -> user.absentee.cpu (k) - cp -> user.absentee.cpu (k);
					      /*  usecs */
	if doubledelta >= 0 then
	     sp -> user.absentee.cpu (k) = doubledelta;
	else
	     baderrct = baderrct + 1;

	doubledelta =
	    sp -> user.absentee.memory (k) - cp -> user.absentee.memory (k);
	if doubledelta >= 0 then
	     sp -> user.absentee.memory (k) = doubledelta;
	else
	     baderrct = baderrct + 1;

     end;					      /* end processing absentee usage */

/**** Process I/O daemon queue use */

     do k = 1 to 4;				      /* io daemon use queues 1 - 4 */
	deltafloat = sp -> user.iod.charge (k) - cp -> user.iod.charge (k);
					      /* $ charge this queue */
	if deltafloat >= 0e0 then
	     sp -> user.iod.charge (k) = deltafloat;
	else
	     baderrct = baderrct + 1;

	delta = sp -> user.iod.pieces (k) - cp -> user.iod.pieces (k);
	if delta >= 0 then
	     sp -> user.iod.pieces (k) = delta;
	else
	     baderrct = baderrct + 1;

	doubledelta = sp -> user.iod.pages (k) - cp -> user.iod.pages (k);
	if doubledelta >= 0 then
	     sp -> user.iod.pages (k) = doubledelta;
	else
	     baderrct = baderrct + 1;

	doubledelta = sp -> user.iod.lines (k) - cp -> user.iod.lines (k);
	if doubledelta >= 0 then
	     sp -> user.iod.lines (k) = doubledelta;
	else
	     baderrct = baderrct + 1;

     end;					      /* end processing io daemon queues */

/**** Process device charges */

     do k = 1 to 16;			      /* device charges */
	deltafloat = sp -> user.devices (k) - cp -> user.devices (k);
	if deltafloat >= 0 then
	     sp -> user.devices (k) = deltafloat;
	else
	     baderrct = baderrct + 1;
     end;					      /* end processing device charges */


/**** Update last reset time in PDT entry */
     sp -> user.time_last_reset = current_time;

     call UNLOCK_PDT ();
     return;

     end RESET_USER_USAGE;
%page;
LOCK_PDT:
     procedure ();

     locked_pdtep = sp;
     call set_lock_$lock (sp -> user.lock, 600, code);  /* lock data base while resetting */
     if code = error_table_$lock_wait_time_exceeded then
	call ssu_$print_message (sci_ptr, code,
	    "The PDTE entry for ^a on project ^a is locked.  Continuing onto next user.",
	    sp -> user.person_id, satep -> project.project_id);
     return;
     end LOCK_PDT;
%page;
UNLOCK_PDT:
     procedure ();

     call set_lock_$unlock (sp -> user.lock, code);
     locked_pdtep = null ();
     return;
     end UNLOCK_PDT;
%page;
SSU_ABORT:
     procedure ();

     goto ABORT_LABEL;
     end SSU_ABORT;
%page;
CLEAN_UP:
     procedure ();

     if locked_pdtep ^= null () then
	do;
	if locked_pdtep -> user.lock = get_lock_id_ () then
	     call set_lock_$unlock (locked_pdtep -> user.lock, (0));
	locked_pdtep = null ();
	end;

/**** Note that terminate_file_ returns if ptr is null. */

     call terminate_file_ (pdtp, 0, TERM_FILE_TERM, (0));
     call terminate_file_ (cpdtp, 0, TERM_FILE_TERM, (0));
     call terminate_file_ (satp, 0, TERM_FILE_TERM, (0));

     if sci_ptr ^= null () then
	call ssu_$destroy_invocation (sci_ptr);
     return;

     end CLEAN_UP;
%page;

/* format: off */
%page; %include access_mode_values;
%page; %include delete_options;
%page; %include pdt;
%page; %include sat;
%page; %include terminate_file;
%page; %include user_attributes;

     end reset_usage;




		    reset_use_totals.pl1            04/09/85  1438.3r w 04/08/85  1133.5       79533



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


/* format: style3 */
reset_use_totals:
     procedure options (variable);

/* Modified June 1981 by C. Hornig to be compatible with new use_totals include file.
   Modified August 1981 by T. Casey to set rate structure number for bin.
   Modified 1984-08-31 by BIM for V3 use_totals.
*/

/* RESET_USE_TOTALS - reset month-to-date usage totals */

dcl	(dn, xdn)		char (168),
	(en, xen)		char (32),
	line		char (120),
	pj		char (12),
	cc		char (24),
	(i, j, k, l, m, n, mm)
			fixed bin,
	tt		char (8),
	bitc		fixed bin (24),
	ap		ptr,
	al		fixed bin (21),
	ec		fixed bin (35),
	p		ptr;

dcl	rsn		fixed bin;		/* rate structure number */
dcl	rs_count		fixed bin;		/* number of rate structures at site */
dcl	created		bit (1) aligned;
dcl	arg_count		fixed bin;
dcl	arg		char (al) based (ap);

dcl	bcs		char (131071) based (p);

dcl	NL		char (1) int static init ("
");

dcl	(addr, null, substr, index, size, length, bit, fixed, divide, mod, abs)
			builtin;

dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	expand_pathname_$add_suffix
			entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl	com_err_$suppress_name
			entry () options (variable);
dcl	com_err_		entry options (variable);

dcl	initiate_file_$create
			entry (character (*), character (*), bit (*), pointer, bit (1) aligned, fixed binary (24),
			fixed binary (35));
dcl	initiate_file_	entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35))
			;
dcl	terminate_file_	entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl	pathname_		entry (character (*), character (*)) returns (character (168));

dcl	search_sat_$rs_number
			entry (char (*), fixed bin, fixed bin (35));
dcl	search_sat_$clean_up
			entry;
dcl	system_info_$max_rs_number
			entry (fixed bin);

dcl	cleanup		condition;
dcl	ME		char (32) init ("reset_use_totals") int static options (constant);
%page;
%include access_mode_values;
%include terminate_file;
%include use_totals;



	call cu_$arg_count (arg_count, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME);
		return;
	     end;
	if arg_count ^= 2
	then do;
		call com_err_$suppress_name (0, ME, "Usage: reset_use_totals USE_TOTALS CONTROL_FILE");
		return;
	     end;

	created = "0"b;
	use_totals_ptr, p = null ();
	on cleanup call clean_up;

	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_$add_suffix (arg, "use_totals", xdn, xen, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "Invalid use_totals pathname ^a.", arg);
		return;
	     end;

	call initiate_file_$create (xdn, xen, RW_ACCESS, use_totals_ptr, created, (0), ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a", pathname_ (xdn, xen));
		return;
	     end;

	call cu_$arg_ptr (2, ap, al, (0));
	call expand_pathname_$add_suffix (arg, "control", dn, en, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "Invalid control file pathname ^a.", arg);
		go to ERROR;
	     end;
	call initiate_file_ (dn, en, R_ACCESS, p, bitc, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a", pathname_ (dn, en));
		go to ERROR;
	     end;

	n = divide (bitc, 9, 17, 0);			/* char count */

	call system_info_$max_rs_number (rs_count);	/* see if site has multiple rate structures */

	do j = 1 to hbound (use_totals.bin_data, 1);
	     use_totals.bin_data (j).select_proj = "";
	     use_totals.bin_data (j).select_ut = 0;
	end;
	do j = lbound (use_totals.ut, 1) to hbound (use_totals.ut, 1);
	     use_totals.ut (j).dollar_charge = 0e0;
	     use_totals.ut (j).logins = 0;
	     use_totals.ut (j).crashes = 0;
	     use_totals.ut (j).nproj = 0;
	     use_totals.ut (j).nusers = 0;
	     use_totals.ut (j).disk_psec = 0;
	     use_totals.ut (j).disk_quota = 0;
	     use_totals.ut (j).disk_usage = 0;
	     use_totals.ut (j).misc = 0e0;
	     use_totals.ut (j).flag, use_totals.ut (j).flag1 = "";
	     do i = 0 to 7;
		use_totals.ut (j).interactive.charge (i) = 0e0;
		use_totals.ut (j).interactive.cpu (i) = 0;
		use_totals.ut (j).interactive.core (i) = 0;
		use_totals.ut (j).interactive.connect (i) = 0;
		use_totals.ut (j).interactive.io_ops (i) = 0;
	     end;
	     do i = 1 to 4;
		use_totals.ut (j).absentee.charge (i) = 0e0;
		use_totals.ut (j).absentee.jobs (i) = 0;
		use_totals.ut (j).absentee.cpu (i) = 0;
		use_totals.ut (j).absentee.memory (i) = 0;
	     end;
	     do i = 1 to 4;
		use_totals.ut (j).iod.charge (i) = 0e0;
		use_totals.ut (j).iod.pieces (i) = 0;
		use_totals.ut (j).iod.pages (i) = 0;
		use_totals.ut (j).iod.lines (i) = 0;
	     end;
	     do i = 1 to 16;
		use_totals.ut (j).devices (i) = 0e0;
	     end;
	end;

	use_totals.version = USE_TOTALS_VERSION_3;
	generated = clock ();
	if use_totals.period_end = 0
	then use_totals.period_begin = clock ();
	else use_totals.period_begin = use_totals.period_end;
	use_totals.period_end = use_totals.period_begin;

	use_totals.uptime = 0;
	use_totals.sys_starts = 0;
	use_totals.sys_crash = 0;
	use_totals.cpu_avail = 0;
	use_totals.idle = 0;
	use_totals.initializer = 0;
	use_totals.total_cpu = 0;
	use_totals.zidle = 0;
	use_totals.mpidle = 0;

	use_totals.ntypes = 1;			/* this will cause us to skip slot one */
						/* unless there is an explicit "other" line in the control file */
	use_totals.n_select = 0;
	use_totals.utype (1) = "all other users";	/* this is the default for 1 */
	use_totals.flag (1) = "$";
	use_totals.origin = 0;
	use_totals.max_day_log = 0;
	use_totals.max_qhour = 0;
	begin;
declare	1 a_quarter_hour	aligned like use_totals.daylog.qh;
	     a_quarter_hour.time = 0;
	     a_quarter_hour.sysid = "";
	     a_quarter_hour.dump_number = 0;
	     a_quarter_hour.shutdown = "0"b;
	     a_quarter_hour.nunits = 0;
	     a_quarter_hour.cpu = 0;
	     a_quarter_hour.kmem = 0;
	     use_totals.daylog (*).qh (*) = a_quarter_hour;
	end;

	k = 1;

/**** LINE :== <comment> NL | <spec> NL
      <comment> :== "*" | "*" <anything>
      <spec> :== <project> , <description> , <flag>
      <spec> :== <project> , <description>
*/

scan:
	do i = k to n;
	     if substr (bcs, i, 1) = NL
	     then do;
		     line = substr (bcs, k, i - k);
		     if substr (line, 1, 1) = "*"
		     then go to scan1;
		     m = index (line, ",");
		     pj = substr (line, 1, m - 1);
		     tt = "";
		     mm = index (substr (line, m + 1), ",");
		     if mm ^= 0
		     then do;
			     cc = substr (line, m + 1, mm - 1);
			     tt = substr (line, m + mm + 1);
			end;
		     else do;
			     cc = substr (line, m + 1);
			     tt = " ";
			end;
		     if pj = "other"
		     then do;
			     use_totals.ut (1).utype = cc;
			     use_totals.ut (1).flag = tt;
			     go to scan1;
			end;
		     do l = 1 to use_totals.ntypes;
			if cc = use_totals.ut (l).utype
			then go to scan2;
		     end;
		     use_totals.ntypes, l = use_totals.ntypes + 1;

/* Set rate structure of the new bin to the rate structure of the first project that is put into it */

		     rsn = 0;			/* default rate structure number */
		     if rs_count > 0
		     then do;			/* only if site has multiple rate structures */
			     call search_sat_$rs_number ((pj), rsn, ec);
						/* get rate structure number of this project */
			     if ec ^= 0
			     then rsn = 0;		/* be quiet about any problems; use default */
			end;
		     use_totals.ut (l).rs_number = rsn; /* set bin's rate structure number */

		     use_totals.ut (l).utype = cc;
		     use_totals.ut (l).flag = tt;
scan2:
		     use_totals.n_select = use_totals.n_select + 1;
		     use_totals.bin_data (n_select).select_proj = pj;
		     use_totals.bin_data (n_select).select_ut = l;
scan1:
		     k = i + 1;
		     go to scan;
		end;
	end;

	call terminate_file_ (p, (0), TERM_FILE_TERM, (0));
	call terminate_file_ (use_totals_ptr, 36 * size (use_totals), TERM_FILE_TRUNC_BC_TERM, (0));
	if rs_count > 0
	then call search_sat_$clean_up;		/* tidy up */
	return;

ERROR:
	call clean_up;
	return;

clean_up:
     procedure;

	if use_totals_ptr ^= null ()
	then if created
	     then call terminate_file_ (use_totals_ptr, (0), TERM_FILE_TERM | TERM_FILE_DELETE, (0));
	     else call terminate_file_ (use_totals_ptr, (0), TERM_FILE_TERM, (0));
	if p ^= null ()
	then call terminate_file_ (use_totals_ptr, (0), TERM_FILE_TERM, (0));
	return;
     end clean_up;

     end reset_use_totals;




		    send_admin_command.pl1          10/28/86  1548.2r w 10/28/86  1024.7      121230



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

/* format: style2 */
send_admin_command:
sac:
     procedure options (variable);

/* SEND_ADMIN_COMMAND - send command to initializer */
/* Modified May 1982, E. N. Kittlitz. tidied up. */
/* Modified December 1982, E. N. Kittlitz. version 2 communications. encrypt admin password. */
/* Modified 1984-10-08 BIM for as_request mechanism */
/* Modified 1984-12-20 BIM to turn off "send-start" when waiting for completion */

	dcl     com_err_		 entry () options (variable);
	dcl     com_err_$suppress_name entry () options (variable);
	dcl     command_query_$yes_no	 entry () options (variable);
	dcl     cu_$arg_list_ptr	 entry returns (ptr);
	dcl     requote_string_	 entry (character (*)) returns (character (*));
	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$standalone_invocation
				 entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	dcl     ssu_$destroy_invocation
				 entry (ptr);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);

	dcl     mail_system_$free_address
				 entry (pointer, fixed bin (35));

	dcl     mlsys_utils_$format_address_field
				 entry (char (*) varying, pointer, fixed bin, pointer, fixed bin (21),
				 fixed bin (21), fixed bin (35));
	dcl     mlsys_utils_$parse_address_control_args
				 entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$nnl		 entry () options (variable);
	dcl     ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$delete_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$block		 entry (ptr, ptr, fixed bin (35));

	dcl     request_id_		 entry (fixed binary (71)) returns (character (19));
	dcl     send_as_request_$block entry (pointer, fixed binary, bit (72) aligned, bit (72) aligned,
				 fixed binary (35));
	dcl     send_as_request_$no_block
				 entry (pointer, fixed binary, bit (72) aligned, fixed binary (35));


	dcl     al		 fixed bin (21);
	dcl     ap		 pointer;
	dcl     code		 fixed bin (35);
	dcl     non_control_arg	 bit (1) aligned;
	dcl     first_non_control_arg	 fixed bin;
	dcl     address_ptr		 pointer;
	dcl     address_string	 char (500);
	dcl     argx		 fixed bin;
	dcl     arg_count		 fixed bin;
	dcl     message_id		 bit (72) aligned;
	dcl     message_id_clock	 fixed bin (71);
	dcl     query_flag		 bit (1) aligned;
	dcl     request_id		 char (19);
	dcl     reply_bits		 bit (72) aligned;
	dcl     sci_ptr		 pointer;
	dcl     stringx		 fixed bin (21);
	dcl     argument		 char (al) based (ap) unal;
	dcl     wait_flag		 fixed bin;
	dcl     send_it		 bit (1) aligned;
	dcl     1 flags		 aligned,
		2 notify_message	 bit,
		2 notify_mail	 bit,
		2 query		 bit,
		2 explicit_address	 bit,
		2 brief		 bit,
		2 brief_query	 bit;

	dcl     MAX_LENGTH		 fixed bin init (20000) int static options (constant);
						/* will fit in a message segment */

	dcl     (
	        NONE		 init (0),
	        START		 init (1),
	        FINISH		 init (2)
	        )			 fixed bin int static options (constant);

	dcl     (unspec, null, substr) builtin;
	dcl     ME		 char (32) init ("send_admin_command") int static options (constant);

	dcl     error_table_$bigarg	 fixed bin (35) ext static;
	dcl     error_table_$noarg	 fixed bin (35) ext static;
	dcl     error_table_$badopt	 fixed bin (35) ext static;

%include as_requests;
%include as_request_header;
%include event_wait_channel;
%include event_wait_info;
	declare 1 EWI		 aligned like event_wait_info;
%include mlsys_data;
%include mlsys_parse_ca_options;
	dcl     1 PCAO		 aligned like parse_ca_options;

	declare cleanup		 condition;


	sci_ptr = null ();
	asr_admin_command_info_ptr = null ();
	event_wait_channel.channel_id (1) = 0;
	on cleanup call clean_up;

	call ssu_$standalone_invocation (sci_ptr, ME, "1.0", cu_$arg_list_ptr (), SSU_ABORT, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "Failed to create ssu_ invocation.");
		return;
	     end;

	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count = 0
	then do;
		call com_err_$suppress_name (0, ME, "Usage: send_admin_command UNQUOTED_COMMAND_LINE");
		go to ABORT;
	     end;

	address_string = "";
	call mlsys_utils_$format_address_field ("", mlsys_data_$user_mail_table_address, -1, addr (address_string),
	     length (address_string), (0), code);
	if code ^= 0
	then address_string = "";

	non_control_arg = "0"b;
	first_non_control_arg = 0;
	flags = "0"b;				/* aggregate */
	wait_flag = FINISH;				/* default */
	do argx = 1 to arg_count while (^non_control_arg);
	     call ssu_$arg_ptr (sci_ptr, argx, ap, al);
	     if index (argument, "-") ^= 1		/* non-control */
	     then do;
		     first_non_control_arg = argx;
		     non_control_arg = "1"b;
		end;
	     else if argument = "-cp" | argument = "-cpw" | argument = "-chpass"
	     then call ssu_$abort_line (sci_ptr, 0,
		     "The admin mode password is stored in the PNT. Use set_special_password operator_admin_mode");
	     else if argument = "-no_wait" | argument = "-nwt"
	     then wait_flag = NONE;
	     else if argument = "-wait" | argument = "-wt"
	     then do;
		     if argx = arg_count
		     then wait_flag = FINISH;
		     else do;
			     argx = argx + 1;
			     call ssu_$arg_ptr (sci_ptr, argx, ap, al);
			     if index (argument, "-") = 1
			     then do;
				     argx = argx - 1;
				     wait_flag = FINISH;
				end;
			     else if argument = "start"
			     then wait_flag = START;
			     else if argument = "finish"
			     then wait_flag = FINISH;
			     else call ssu_$abort_line (sci_ptr, error_table_$badopt,
				     "The wait code must be ""start"" or ""finish"", not ""^a""", argument);
			end;
		end;
	     else if argument = "-notify_message" | argument = "-ntmsg"
	     then flags.notify_message = "1"b;
	     else if argument = "-no_notify_message" | argument = "-nntmsg"
	     then flags.notify_message = "0"b;
	     else if argument = "-notify_mail" | argument = "-ntmail"
	     then flags.notify_mail = "1"b;
	     else if argument = "-no_notify_mail" | argument = "-nntmail"
	     then flags.notify_mail = "0"b;
	     else if argument = "-address"
	     then do;
		     if argx = arg_count
		     then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "-address must be followed by a mail system address.");

		     flags.explicit_address = "1"b;
		     argx = argx + 1;
		     unspec (PCAO) = ""b;
		     PCAO.version = PARSE_CA_OPTIONS_VERSION_1;
		     PCAO.logbox_creation_mode = QUERY_TO_CREATE_MAILBOX;
		     PCAO.savebox_creation_mode = QUERY_TO_CREATE_MAILBOX;
		     PCAO.flags.abort_on_errors = "1"b;
		     PCAO.flags.validate_addresses = "1"b;

		     call mlsys_utils_$parse_address_control_args (sci_ptr, argx, addr (PCAO), address_ptr, code);
		     argx = argx - 1;		/* back up */
		     address_string = "";
		     call mlsys_utils_$format_address_field ("", address_ptr, -1, addr (address_string),
			length (address_string), (0), code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code,
			     "Invalid address returned by mlsys_utils_$parse_address_control_args");
		end;
	     else if argument = "-string"
	     then do;
		     first_non_control_arg = argx + 1;
		     non_control_arg = "1"b;
		end;
	     else if argument = "-query" | argument = "-qy"
	     then flags.query = "1"b;
	     else if argument = "-no_query" | argument = "-nqy"
	     then flags.query = "0"b;
	     else if argument = "-brief" | argument = "-bf"
	     then flags.brief = "1"b;
	     else if argument = "-long" | argument = "-lg"
	     then flags.brief = "0"b;
	     else if argument = "-brief_query" | argument = "-bfqy"
	     then do;
		     flags.brief_query = "1"b;
		     flags.query = "1"b;
		end;
	     else if argument = "-long_query" | argument = "-lgqy"
	     then do;
		     flags.brief_query = "0"b;
		     flags.query = "1"b;
		end;

	     else call ssu_$abort_line (sci_ptr, error_table_$badopt, "Unrecognized control argument ^a", argument);
	end;

	if first_non_control_arg > arg_count
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "No command line given.");

	asr_ac_length = 0;
	do argx = first_non_control_arg to arg_count;
	     call ssu_$arg_ptr (sci_ptr, argx, (null ()), al);
	     asr_ac_length = asr_ac_length + al + 1;	/* space on the end */
	end;
	asr_ac_length = asr_ac_length - 1;
	if asr_ac_length <= 0
	then call ssu_$abort_line (sci_ptr, 0, "Null command line, not sent.");
	if asr_ac_length > MAX_LENGTH
	then call ssu_$abort_line (sci_ptr, error_table_$bigarg, "Command line exceeds ^d characters in length.",
		MAX_LENGTH);

	asr_admin_command_info_ptr = null ();
	allocate asr_admin_command_info;
	asr_admin_command_info.header.version = as_request_version_1;
	asr_admin_command_info.header.type = ASR_ADMIN_COMMAND;

	stringx = 1;
	do argx = first_non_control_arg to arg_count;
	     call ssu_$arg_ptr (sci_ptr, argx, ap, al);
	     substr (asr_admin_command_info.command, stringx, al + 1) = argument || " ";
	     stringx = stringx + al + 1;
	end;

	if flags.query
	then do;
		if flags.brief_query
		then call command_query_$yes_no (send_it, 0, ME,
			"If you answer ""yes"", the command line will be sent to the Initializer.",
			"^a -- Send it? ", requote_string_ (asr_admin_command_info.command));
		else call command_query_$yes_no (send_it, 0, ME,
			"If you answer ""yes"", the command line will be sent to the Initializer.",
			"Do you want to send the command line:^/ ^a^/to the Initializer^[ and wait for it to ^[start^;finish^]^;^s^]^[ and be notified ^[by message^;by mail^[ to address ^a^]^]^]? "
			, requote_string_ (asr_admin_command_info.command), wait_flag ^= NONE, wait_flag,
			flags.notify_message | flags.notify_mail, flags.notify_message, flags.explicit_address,
			address_string);
		if ^send_it
		then do;
			free asr_admin_command_info;
			call ioa_ ("send_admin_command: Command not sent.");
			return;
		     end;
	     end;

	if wait_flag ^= NONE
	then call ipc_$create_ev_chn (asr_admin_command_info.header.reply_channel, code);
	else asr_admin_command_info.header.reply_channel = 0;
	event_wait_channel.channel_id (1) = asr_admin_command_info.header.reply_channel;
						/* save for destruction */
	asr_admin_command_info.version = ASR_AC_VERSION_1;
	asr_admin_command_info.command = "";
	asr_admin_command_info.mail_destination = address_string;
	asr_admin_command_info.flags.send_start_wakeup = (wait_flag > NONE);
	asr_admin_command_info.flags.send_completion_wakeup = (wait_flag = FINISH);
	asr_admin_command_info.flags.send_completion_message = flags.notify_message;
	asr_admin_command_info.flags.send_completion_mail = flags.notify_mail;
	stringx = 1;
	do argx = first_non_control_arg to arg_count;
	     call ssu_$arg_ptr (sci_ptr, argx, ap, al);
	     substr (asr_admin_command_info.command, stringx, al + 1) = argument || " ";
	     stringx = stringx + al + 1;
	end;

	if wait_flag > NONE
	then do;
		call send_as_request_$block (asr_admin_command_info_ptr, currentsize (asr_admin_command_info),
		     message_id, reply_bits, code);
	     end;
	else call send_as_request_$no_block (asr_admin_command_info_ptr, currentsize (asr_admin_command_info),
		message_id, code);
	if wait_flag ^= FINISH
	then do;
		unspec (message_id_clock) = message_id;
		request_id = request_id_ (message_id_clock);
		if ^flags.brief
		then call ioa_ ("send_admin_command: ID ^a^[, execution started^].", request_id, wait_flag = START);
	     end;
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "Error sending AS Request message.");

	if wait_flag ^= NONE
	then do;
		asr_replyp = addr (reply_bits);
		if asr_reply_admin_command.code ^= 0
		then call ssu_$abort_line (sci_ptr, asr_reply_admin_command.code);
	     end;
	if wait_flag = FINISH			/* We expect one more wakeup */
	then do;
		if ^flags.brief
		then call ioa_$nnl ("send_admin_command: Execution started ... ");
		call ipc_$block (addr (event_wait_channel), addr (EWI), code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Failed to block to wait for completion.");
		if ^flags.brief
		then call ioa_ ("completed.");
		asr_replyp = addr (EWI.message);
		if asr_reply_admin_command.code ^= 0 | asr_reply_admin_command.flags.command_aborted
		     | asr_reply_admin_command.command_had_errors
		then call ssu_$abort_line (sci_ptr, asr_reply_admin_command.code,
			"^[ Command line aborted by error.^]^[ Command completed with errors.^]",
			asr_reply_admin_command.flags.command_aborted, asr_reply_admin_command.command_had_errors);

	     end;
	call clean_up;

	return;

SSU_ABORT:
     procedure;

	goto ABORT;
     end SSU_ABORT;
ABORT:
	call clean_up;
	return;

clean_up:
     procedure;

	call ssu_$destroy_invocation (sci_ptr);
	if asr_admin_command_info_ptr ^= null
	then free asr_admin_command_info;
	if event_wait_channel.channel_id (1) ^= 0
	then call ipc_$delete_ev_chn (event_wait_channel.channel_id (1), (0));
	return;
     end clean_up;
     end send_admin_command;




		    send_daemon_command.pl1         12/12/91  2135.9r w 12/12/91  2132.9       85473



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1991   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(91-03-11,Vu), approve(91-03-11,MCR8242), audit(91-12-06,Zimmerman),
     install(91-12-12,MR12.5-1008):
     Confusing error message for the command send_daemon_command
                                                   END HISTORY COMMENTS */


/* format: style2 */

send_daemon_command:
     procedure options (variable);

/**** Created 1985-02-19, BIM, from send_admin_command */
/**** Modified 1985-03-14, E. Swenson, to allow passing of login arguments */
/**** Modified 1985-04-03, E. Swenson to use keywords. */

/* Entries */

	dcl     com_err_		 entry () options (variable);
	dcl     com_err_$suppress_name entry () options (variable);
	dcl     cu_$arg_list_ptr	 entry returns (ptr);
	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$standalone_invocation
				 entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	dcl     ssu_$destroy_invocation
				 entry (ptr);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);

	dcl     send_as_request_$block entry (pointer, fixed binary, bit (72) aligned, bit (72) aligned,
				 fixed binary (35));

/* Automatic */

	dcl     al		 fixed bin (21);
	dcl     ap		 pointer;
	dcl     code		 fixed bin (35);
	dcl     argx		 fixed bin;
	dcl     arg_count		 fixed bin;
	dcl     first_request_argument fixed bin;
	dcl     reply_bits		 bit (72) aligned;
	dcl     sci_ptr		 pointer;
	dcl     stringx		 fixed bin (21);
	dcl     argument		 char (al) based (ap) unal;
	dcl     source_seen		 bit (1) aligned;
	dcl     a_action		 fixed bin;
	dcl     a_source_name	 char (32);
	dcl     a_user_name		 char (32);
	dcl     a_project_name	 char (32);
	dcl     1 flags		 aligned,
		2 brief		 bit;

/* Constant */

	dcl     MAX_LENGTH		 fixed bin init (20000) int static options (constant);
	dcl     ME		 char (32) init ("send_daemon_command") int static options (constant);

/* Builtin */

          dcl     addr                   builtin;
          dcl     after                  builtin;
          dcl     before                 builtin;
          dcl     byte                   builtin;
          dcl     currentsize            builtin;
          dcl     index                  builtin;
          dcl     max                    builtin;
	dcl     null		 builtin;
	dcl     substr		 builtin;

/* External */

	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$bigarg	 fixed bin (35) ext static;
	dcl     error_table_$insufficient_access
				 fixed bin (35) ext static;
	dcl     error_table_$noarg	 fixed bin (35) ext static;

/* Conditions */

	dcl     cleanup		 condition;
%page;

/* Program */

	sci_ptr = null ();
	asr_daemon_command_info_ptr = null ();
	on cleanup call clean_up;

	call ssu_$standalone_invocation (sci_ptr, ME, "1.0", cu_$arg_list_ptr (), SSU_ABORT, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "Failed to create ssu_ invocation.");
		return;
	     end;

	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count = 0
	then do;
		call com_err_$suppress_name (0, ME,
		     "Usage: send_daemon_command (login|logout|reply|quit) source_name {arguments}");
		go to ABORT;
	     end;

/**** First argument to send_daemon_command is an action keyword.  This
      is a required, positional argument.  The existence of this argument
      has already been determined by the above check. */

	call ssu_$arg_ptr (sci_ptr, 1, ap, al);

	if argument = "login"
	then a_action = ASR_DC_LOGIN;
	else if argument = "logout"
	then a_action = ASR_DC_LOGOUT;
	else if argument = "reply"
	then a_action = ASR_DC_REPLY;
	else if argument = "quit"
	then a_action = ASR_DC_QUIT;
	else call ssu_$abort_line (sci_ptr, 0, "Invalid keyword ^a.", argument);

/**** We next parse all control arguments to the send_daemon_command 
      command.  The end of the control arguments is signalled by an
      argument which does not begin with a "-".   This argument must
      be the source_id. */

	a_user_name, a_project_name = "";
	flags = "0"b;				/* aggregate */

	source_seen = "0"b;				/* not yet */
	first_request_argument = -1;			/* none found yet */

	do argx = 2 to arg_count while (first_request_argument = -1);
	     call ssu_$arg_ptr (sci_ptr, argx, ap, al);
	     if index (argument, "-") ^= 1		/* non-control */
	     then do;
		     if ^source_seen
		     then do;
			     a_source_name = argument;
			     source_seen = "1"b;
			end;
		     else first_request_argument = argx;
		end;
	     else if argument = "-brief"
	     then flags.brief = "1"b;
	     else if argument = "-long"
	     then flags.brief = "0"b;
	     else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", argument);
	end;


	if ^source_seen
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "No source_name specified.");

	if a_action = ASR_DC_LOGIN
	then /* login */
	     if first_request_argument = -1
	     then /* didn't say who */
		call ssu_$abort_line (sci_ptr, error_table_$noarg, "User.Project must be specified.");
	     else do;
		     call ssu_$arg_ptr (sci_ptr, first_request_argument, ap, al);

		     a_user_name = before (argument, ".");
		     a_project_name = after (argument, ".");
		     if a_user_name = "" | a_project_name = "" | index (a_user_name, ".") > 0
			| index (a_project_name, ".") > 0
		     then call ssu_$abort_line (sci_ptr, error_table_$badopt,
			     "^/Usage: ^a login channel User.Project", ME);
/**** The Personid.Projectid argument did not really count as a request
      argument.  Update things to reflect this. */

		     first_request_argument = first_request_argument + 1;
		     if first_request_argument > arg_count
		     then first_request_argument = -1;
		end;

	if first_request_argument = -1 & a_action = ASR_DC_REPLY
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "No reply command line given.");

	asr_dc_length = 0;
	if first_request_argument ^= -1
	then do;
		if (a_action = ASR_DC_QUIT | a_action = ASR_DC_LOGOUT)
		then call ssu_$abort_line (sci_ptr, 0, "No additional arguments are valid for logout or quit.");

/**** Establish length of command line */

		do argx = first_request_argument to arg_count;
		     call ssu_$arg_ptr (sci_ptr, argx, (null ()), al);
		     asr_dc_length = asr_dc_length + al + 1;
						/* space on the end */
		end;

		if a_action ^= ASR_DC_REPLY
		then /* leave room for the NL */
		     asr_dc_length = asr_dc_length - 1;
		asr_dc_length = max (0, asr_dc_length);

		if asr_dc_length > MAX_LENGTH
		then call ssu_$abort_line (sci_ptr, error_table_$bigarg,
			"Command line exceeds ^d characters in length.", MAX_LENGTH);
	     end;

	asr_daemon_command_info_ptr = null ();
	allocate asr_daemon_command_info;
	asr_daemon_command_info.header.version = as_request_version_1;
	asr_daemon_command_info.header.type = ASR_DAEMON_COMMAND;
	asr_daemon_command_info.version = ASR_DC_INFO_VERSION_1;
	asr_daemon_command_info.action_code = a_action;
	asr_daemon_command_info.command = "";
	asr_daemon_command_info.source_name = a_source_name;
	asr_daemon_command_info.user_name = a_user_name;
	asr_daemon_command_info.project_name = a_project_name;

	if first_request_argument ^= -1
	then do;
		stringx = 1;
		do argx = first_request_argument to arg_count;
		     call ssu_$arg_ptr (sci_ptr, argx, ap, al);
		     if argx < arg_count
		     then do;
			     substr (asr_daemon_command_info.command, stringx, al + 1) = argument || " ";
			     stringx = stringx + al + 1;
			end;
		     else if a_action = ASR_DC_REPLY
		     then substr (asr_daemon_command_info.command, stringx, al + 1) = argument || byte (10);
		     else substr (asr_daemon_command_info.command, stringx, al) = argument;
		end;
	     end;

	call send_as_request_$block (asr_daemon_command_info_ptr, currentsize (asr_daemon_command_info), (""b),
	     reply_bits, code);

	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "Failed to send request to answering service.");

	asr_reply_dc_ptr = addr (reply_bits);
	if asr_reply_daemon_command.code ^= 0
	then do;
		if asr_reply_daemon_command.no_access_to_daemon
		then call ssu_$abort_line (sci_ptr, error_table_$insufficient_access, "On daemon source ""^a"".",
			a_source_name);
		else if asr_reply_daemon_command.command_refused
		then call ssu_$abort_line (sci_ptr, error_table_$insufficient_access, "Cannot send daemon commands.");
		else if asr_reply_daemon_command.no_such_daemon
		then call ssu_$abort_line (sci_ptr, 0, "No daemon logged in over daemon source ""^a"".",
			a_source_name);
		else call ssu_$abort_line (sci_ptr, asr_reply_daemon_command.code);
	     end;

	call clean_up ();
	return;
%page;
SSU_ABORT:
     procedure ();

	goto ABORT;
     end SSU_ABORT;
ABORT:
	call clean_up ();
	return;

clean_up:
     procedure ();

	call ssu_$destroy_invocation (sci_ptr);
	if asr_daemon_command_info_ptr ^= null
	then free asr_daemon_command_info;
	return;
     end clean_up;

/* format: off */
%page; %include asr_daemon_command;
%page; %include as_request_header;

     end send_daemon_command;




		    set_admin_data_.pl1             01/26/85  1302.0r w 01/22/85  1240.9       27855



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

set_admin_data_: proc;

/* originally coded by K.Willis 3/26/71 */

%include sys_admin_data;

dcl  sadp ptr int static init (null),			 /* ptr to sys_admin_data */
     null builtin,
     ec fixed bin,
     user_info_ entry options (variable),
     myname char (32) aligned,			 /* name of caller */
     myproj char (9),				 /* project of caller */
     get_wdir_ entry returns (char (168) aligned),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin),
     com_err_ entry options (variable),
     ioa_ entry options (variable),
     set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin),
     set_lock_$unlock entry (bit (36) aligned, fixed bin);

dcl  error_table_$invalid_lock_reset fixed bin ext,
     error_table_$locked_by_this_process fixed bin ext;

/* this entry unlocks sys_admin_data only if called by the locker */
unlock:	entry;
	if sadp = null then call setup;
	call set_lock_$unlock (sadp -> lock, ec);
	return;



/* If sys_admin_data was locked by the same caller since system initialization, this entry returns the value 2.
   If sys_admin_data was locked by a different caller since the system was initialized, this entry returns
   the value 1 indicating that the caller should not use the table.  Otherwise it locks the table
   and returns the value 0 indicating that the caller may use sys_admin_data_ but noe one else
   will be permitted to use it until the caller unlocks it.  */


lock:	entry returns (fixed bin);
	if sadp = null then call setup;		 /* get pointer to sys_admin_data */
	call set_lock_$lock (sadp -> lock, 1, ec);
	if ec = 0 then do;
ok:	     call user_info_ (myname, myproj);		 /* get name of caller */
	     sadp -> locker = myname;			 /* fill in locker's name */
	     return (0);				 /* show success */
	end;
	else if ec = error_table_$invalid_lock_reset then go to ok;
	else if ec = error_table_$locked_by_this_process then do;
	     return (2);
	end;
	else do;
	     call ioa_ ("sys_admin_data is locked by ^a", sadp -> locker);
	     return (1);
	end;

setup:	proc;

	     call hcs_$initiate ((get_wdir_ ()), "sys_admin_data", "", 0, 1, sadp, ec);
	     if sadp = null then call com_err_ (ec, "set_admin_data_", "sys_admin_data");

	end setup;

     end set_admin_data_;




		    set_tpp.pl1                     11/12/82  1412.9rew 11/12/82  1110.5      120960



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


set_tpp: stpp: proc;

/* Procedure to print and set the time-page-product of a directory.
   To be used by system administrators to repair clobbered directories,
   avoiding loss of disk storage revenue, and keeping the diskreport job happy.

   Usage: set_tpp directory -control_args-

   directory	is the pathname of the directory to be operated upon.

   control_args	may be chosen from the following and may appear in any order:

   -print, -pr		causes the current tpp and equivalent dollar charge to be printed.
   -long, -lg	causes the above, plus the quota, used time-tpp-updated, sons lvid, and quota switch to be printed.
   -directory, -dr	sets command to operate on directory page figures.
   -segment, -sm	sets the command to operate on segment page figures. This is the default.
   -set value	causes the tpp to be modified as specified by value

   value can be in dollars and cents (preceeded by a "$") or in page-seconds.
   It can have a "+" or "-" sign preceeding it, indicating a change
   to the current tpp, or be unsigned, indicating an absolute value to be set,
   replacing the current tpp. Setting of an absolute value is only approximate, since
   the tpp is growing while the command is being executed, and the
   primitive that makes the change only accepts relative values, to modify
   the current tpp.


   Written by T. Casey, April 1976
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.

*/

/* Ext Entries */

dcl  com_err_ entry options (variable);
dcl  command_query_ entry options (variable);
dcl  cv_dec_check_ entry (char (*) aligned, fixed bin (35)) returns (fixed bin (35));
dcl  cv_float_ entry (char (*) aligned, fixed bin (35)) returns (float bin (27));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  date_time_$fstime entry (bit (36), char (*));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$quota_read entry (char (*), fixed bin (18), fixed bin (71), bit (36), bit (36), fixed bin (1), fixed bin (18),
     fixed bin (35));
dcl  hcs_$dir_quota_read entry (char (*), fixed bin (18), fixed bin (71), bit (36), bit (36), fixed bin (1),
     fixed bin (18), fixed bin (35));
dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  hphcs_$get_reset_quota entry (char (*), fixed bin (71), fixed bin (35));
dcl  hphcs_$dir_get_reset_quota entry (char (*), fixed bin (71), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  system_info_$prices_rs entry (fixed bin, (0:7)float bin, (0:7)float bin, (0:7)float bin,
    (0:7) float bin, float bin, float bin);
dcl  system_info_$max_rs_number entry (fixed bin);
dcl  search_sat_$rs_number entry (char (*), fixed bin, fixed bin (35));
dcl  search_sat_$clean_up entry;
dcl  error_table_$noentry external fixed bin (35);

/* Bit */

dcl (dollar_sw, expecting_val, got_path, long_sw, print_sw, set_sw) bit (1) aligned init (""b);
dcl (slvid, uptime) bit (36);

/* Fixed bin */

dcl (del_tpp, set_val, tpp) fixed bin (71);
dcl  code fixed bin (35);
dcl (quota, used) fixed bin (18);
dcl  rs_number fixed bin;
dcl  rs_count fixed bin;
dcl (aix, argl, argno, i, nargs) fixed bin;
dcl  operation fixed bin;
dcl  ADD fixed bin int static init (1);
dcl  SUBTRACT fixed bin int static init (2);
dcl  SET fixed bin int static init (3);
dcl  quota_sw fixed bin (1);

/* Float Bin */

dcl  dummy (0:7) float bin;
dcl (cur_charge, del_charge, disk_price, dollar_val, dummy1) float bin;

/* Char */

dcl  path char (168) init ("");
dcl  message char (168) init ("^a");
dcl  aligned_arg char (32) aligned;
dcl  date char (16);
dcl  dir_seg char (9) init ("segment");
dcl  me char (8) init ("set_tpp");
dcl  inc_dec char (8);
dcl  answer char (3) varying;

/* Ptr */

dcl (argp, dummy_ptr, segp) ptr init (null);

/* Based */

dcl  arg char (argl) based (argp);

/* Builtin */

dcl (addr, after, before, index, null, ptr, substr, verify) builtin;

/* Condition */

dcl  linkage_error condition;

/* Ext */

dcl (error_table_$bad_arg, error_table_$badopt, error_table_$noarg) ext fixed bin (35);

/* Include */

%include query_info;

/* Procedure */

	call cu_$arg_count (nargs);
	if nargs = 0 then do;
	     call com_err_ (0, me, "Usage: set_tpp path -print/-long -dr/-sm -set N/+N/-N/$N/$+N/$-N");
	     return;
	end;

	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 then do;
		message = "";
		goto call_com_err;
	     end;

	     if expecting_val then do;		/* previous argument was -set */
		expecting_val = ""b;
		aix = 1;				/* scan for + - or $ starting at char 1 */
		operation = SET;			/* default, if + or - not given */
val_loop:		if verify (substr (arg, aix), "0123456789.") = 0 /* if nothing but those chars in rest of arg */
		then goto numeric;			/* then go convert it */
		i = index ("+-", substr (arg, aix, 1)); /* see if next char is + or - */
		if i ^= 0 then do;			/* it was one of them */
		     operation = i;			/* 1 = ADD, 2 = SUBTRACT */
		     aix = aix + 1;			/* skip to next char */
		     goto val_loop;			/* and go see if it is special */
		end;

		if substr (arg, aix, 1) = "$" then do;
		     dollar_sw = "1"b;
		     aix = aix + 1;			/* go to next char */
		     goto val_loop;			/* and go see if it is special */
		end;
bad_val:		message = "Error converting decimal argument: ""^a""";
		code = 0;
		goto arg_err;

numeric:		aligned_arg = substr (arg, aix);	/* copy rest of arg to aligned string */
		if dollar_sw then
		     dollar_val = cv_float_ (aligned_arg, code); /* convert to float bin */
		else set_val = cv_dec_check_ (aligned_arg, code); /* convert to fixed bin */
		if code ^= 0 then goto bad_val;
	     end;					/* end expecting */

	     else if substr (arg, 1, 1) ^= "-" then do;	/* not ctl arg */
		if ^got_path then do;
		     call expand_path_ (argp, argl, addr (path), null (), code);
		     if code ^= 0 then do;
arg_err:			path = arg;
call_com_err:		call com_err_ (code, me, message, path);
			return;
		     end;
		     got_path = "1"b;		/* remember we already got the dir path */
		end;

		else do;				/* we already have the path. this arg is no good */
		     code = error_table_$bad_arg;
		     goto arg_err;
		end;
	     end;					/* end not ctl arg */

/* must be control arg */

	     else if arg = "-print" | arg = "-pr" then print_sw = "1"b;
	     else if arg = "-s" | arg = "-sm" | arg = "-seg" | arg = "-segment" then dir_seg = "segment";
	     else if arg = "-d" | arg = "-dr" | arg = "-dir" | arg = "-directory" then dir_seg = "directory";
	     else if arg = "-lg" | arg = "-long" then print_sw, long_sw = "1"b;
	     else if arg = "-set" then set_sw, expecting_val = "1"b;
	     else do;
		code = error_table_$badopt;
		goto arg_err;
	     end;

	end;					/* and loop thru args */
	if ^got_path then do;
	     message = "directory path";
noarg_err:     code = error_table_$noarg;
	     goto call_com_err;
	end;

	if expecting_val then do;
	     message = "after -set";
	     goto noarg_err;
	end;

/* Now do the work */
	call system_info_$max_rs_number (rs_count);	/* see if site has multiple rate structures */
	if rs_count > 0 then			/* if it does, */
	     call get_rs_number (path, rs_number);	/* we must get the correct rate_structure */
	else rs_number = 0;				/* if not, use the default (the only one at the site) */
	call system_info_$prices_rs (rs_number, dummy, dummy, dummy, dummy, disk_price, dummy1); /* get disk price */
	call get_quota;				/* int proc to get dir or seg quota */
	if code ^= 0 then goto call_com_err;

	cur_charge = tpp * disk_price;		/* compute current charge for the dir */

	if ^print_sw & ^set_sw then			/* if user said neither -print nor -set */
	     print_sw = "1"b;			/* presumably he did want us to do something */
	if print_sw then do;			/* if printing current values */
	     if long_sw then do;
		call date_time_$fstime (uptime, date);
		call ioa_ ("q=^d,u=^d,tpp=^d ($^.2f),updt=^a,slvid=^w,qsw=^d",
		     quota, used, tpp, cur_charge, date, slvid, quota_sw);
	     end;
	     else if quota_sw = 1 then		/* if dir has a quota and tpp */
		call ioa_ ("tpp=^d ($^.2f)", tpp, cur_charge);
	     else call ioa_ ("no quota or tpp on this directory");
	end;					/* end printing current values */

	if set_sw then do;				/* if setting new values */
	     on linkage_error goto no_hphcs;		/* see if user has hphcs_ access, before querying him */
	     call hcs_$make_ptr (null (), "hphcs_", "get_reset_quota", dummy_ptr, code);
	     if code = 0 then goto yes_hphcs;
no_hphcs:	     call com_err_ (code, me, "The set operation requires access to the hphcs_ gate");
	     return;
yes_hphcs:     revert linkage_error;

	     if dollar_sw then			/* compute tpp from given dollar value */
		set_val = dollar_val/disk_price;	/* floating point division, assigned to fixed bin */

	     if operation = SET then			/* user wants to set absolute value */
		del_tpp = tpp - set_val;		/* we can only approximate that */
	     else if operation = ADD then
		del_tpp = -set_val;			/* but we can make a +/- change exactly */
	     else del_tpp = set_val;

	     del_charge = - del_tpp * disk_price;

/* The apparent sign reversal error here is not an error.
   The confusion arises from the fact that the reset primitive subtracts del_tpp from the current tpp. */

	     if del_charge < 0e0 then
		inc_dec = "DECREASE";
	     else inc_dec = "INCREASE";
	     query_info.yes_or_no_sw = "1"b;
	     call command_query_ (addr (query_info), answer, me,
		"This operation will ^a the ^a page charge on ^a by $^.2f,to ^d ($^.2f). Do you want to do that?",
		inc_dec, dir_seg, path, del_charge, tpp-del_tpp, cur_charge+del_charge);
	     if answer = "no" then return;

	     if dir_seg = "directory" then
		call hphcs_$dir_get_reset_quota (path, del_tpp, code);
	     else call hphcs_$get_reset_quota (path, del_tpp, code);
	     if code ^= 0 then
		call com_err_ (code, me, "trying to reset tpp of ^a", path);

	     call get_quota;			/* look at result of what we did */
	     if code ^= 0 then goto call_com_err;
	     cur_charge = tpp * disk_price;
	     call ioa_ ("tpp is now ^d ($^.2f)", tpp, cur_charge);
	end;					/* end setting new values */
	return;

get_quota: proc;
	     if dir_seg = "directory" then
		call hcs_$dir_quota_read (path, quota, tpp, uptime, slvid, quota_sw, used, code);
	     else call hcs_$quota_read (path, quota, tpp, uptime, slvid, quota_sw, used, code);
	     return;
	end get_quota;

get_rs_number: proc (path, rs_number);

dcl (path, work) char (168);
dcl  rs_number fixed bin;

dcl (code, sat_code) fixed bin (35);
dcl (entry, project_entry) char (32);
dcl  area area based (area_ptr);
dcl (area_ptr, name_ptr init (null)) ptr;
dcl  primary_name char (32) aligned based (name_ptr);

dcl 1 status aligned,				/* status info structure */
   (2 type bit (2),
    2 nnames fixed bin (15),
    2 nrp bit (18),					/* rel ptr to names */
    2 dtm bit (36),
    2 dtu bit (36),
    2 mode bit (5),
    2 pad bit (13),
    2 records fixed bin (17)) unaligned;

dcl  get_system_free_area_ entry returns (ptr);
dcl  hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));

	     rs_number,
		sat_code = 0;

	     work = after (path, ">");		/* get rid of root */
	     entry = before (work, ">");		/* and grab 1st level directory */
	     if entry ^= "udd" then
		if entry ^= "UDD" then
		     if entry ^= "user_dir_dir" then return; /* doesn't belong to a project */
	     work = after (work, ">");
	     entry = before (work, ">");		/* finally - the project name (one of them) */
	     project_entry = entry;
	     if entry = "" then return;		/* sorry - not a project */

	     area_ptr = get_system_free_area_ ();	/* get some working space */
	     call hcs_$status_ (">udd", (entry), 0, addr (status), area_ptr, code); /* we want the primary name */
	     if code = 0 & status.nrp ^= "0"b then do;
		name_ptr = ptr (area_ptr, status.nrp);	/* find the names array */
		project_entry = primary_name;		/* get the primary name */
		free primary_name in (area);		/* clean up */
		call search_sat_$rs_number ((project_entry), rs_number, sat_code); /* try for the rate */
		call search_sat_$clean_up;		/* tidy up */
		if sat_code = 0 then return;		/* home run */
	     end;

	     call search_sat_$rs_number ((entry), rs_number, sat_code); /* try the name given to us */
	     call search_sat_$clean_up;		/* tidy up */
	     if sat_code = 0 then return;		/* 1-0 for the good guys */
	     if code ^= 0 then			/* We tried! Heaven knows, we tried!! */
		call com_err_ (code, me, "Attempting to access project directory >udd>^a.", entry);
	     if sat_code = error_table_$noentry then
		call com_err_ (sat_code, me, "Trying to locate project ""^a"".  Default rates will be used.",
		project_entry);
	     else call com_err_ (sat_code, me, "Accessing the sat.  Default rates will be used");
	     return;
	end get_rs_number;

     end set_tpp;




		    sort_projfile.pl1               09/19/84  0911.6rew 09/18/84  0759.0       26946



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

sort_projfile: proc;

dcl  (path, dn) char (168) aligned,
     en char (32) aligned,
    (i, j, k, l, m, n) fixed bin,
     movelen fixed bin,
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin,
    (p, q, p1, q1, pp, hp) ptr;

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     com_err_ entry options (variable);

dcl (addr, null, substr) builtin;

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin),
     hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     hcs_$delentry_seg entry (ptr, fixed bin),
     hcs_$truncate_seg entry (ptr, fixed bin, fixed bin);

dcl  idsort_ entry ((*) char (32) aligned, (*) fixed bin, fixed bin);

dcl 1 movetable based aligned,
    2 moveary (movelen) fixed bin (35);

%include projfile;

/* ====================================================== */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
	     path = "projfile";
	     al = 8;
	end;
	else path = bchr;
	call expand_path_ (addr (path), al, addr (dn), addr (en), ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "sort_projfile", path);
	     return;
	end;

	call hcs_$initiate (dn, en, "", 0, 1, pp, ec);
	if pp = null then go to er;

	call hcs_$make_seg ("", "", "", 1011b, p, ec);
	if p = null then go to er;

	movelen = loph;
	p -> movetable = pp -> movetable;

	movelen = lope;

	m = nproj;

	begin;

dcl  key (m) char (32) aligned;
dcl  ord (m) fixed bin;

	     do i = 1 to m;
		key (i) = id (i);
		ord (i) = i;
	     end;

	     call idsort_ (key, ord, m);

	     do i = 1 to m;
		p1 = addr (projfiletab (ord (i)));
		q1 = addr (p -> projfiletab (i));
		q1 -> movetable = p1 -> movetable;
	     end;

	end;

	movelen = loph + m * lope;

	call hcs_$truncate_seg (pp, 0, ec);
	pp -> movetable = p -> movetable;

	call hcs_$terminate_noname (pp, ec);
	call hcs_$delentry_seg (p, ec);

     end;




		    sort_reqfile.pl1                09/19/84  0911.6rew 09/18/84  0759.0       27018



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

sort_reqfile: proc;

dcl  (path, dn) char (168) aligned,
     en char (32) aligned,
    (i, j, k, l, m, n) fixed bin,
     movelen fixed bin,
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin,
    (p, q, p1, q1, qp) ptr;

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     idsort_ entry ((*) char (32) aligned, (*) fixed bin, fixed bin),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     com_err_ entry options (variable);

dcl  (addr, null, substr) builtin;

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin),
     hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin),
     hcs_$delentry_seg entry (ptr, fixed bin),
     hcs_$truncate_seg entry (ptr, fixed bin, fixed bin);


dcl 1 movetable based aligned,
    2 moveary (movelen) fixed bin (35);

%include reqfile;

/* ====================================================== */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
	     path = "reqfile";
	     al = 7;
	end;
	else path = bchr;
	call expand_path_ (addr (path), al, addr (dn), addr (en), ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "sort_reqfile", path);
	     return;
	end;

	call hcs_$initiate (dn, en, "", 0, 1, qp, ec);
	if qp = null then go to er;

	call hcs_$make_seg ("", "", "", 1011b, p, ec);
	if p = null then go to er;

	movelen = loqh;
	p -> movetable = qp -> movetable;

	movelen = loqe;

	m = nacts;
	begin;

dcl  key (m) char (32) aligned;
dcl  ord (m) fixed bin;

	     do i = 1 to m;
		key (i) = mitacct (i) || reqno (i);
		ord (i) = i;
	     end;

	     call idsort_ (key, ord, m);

	     do i = 1 to m;
		p1 = addr (reqfiletab (ord (i)));
		q1 = addr (p -> reqfiletab (i));
		q1 -> movetable = p1 -> movetable;
	     end;

	end;

	movelen = loqh + m * loqe;

	call hcs_$truncate_seg (qp, 0, ec);
	qp -> movetable = p -> movetable;

	call hcs_$terminate_noname (qp, ec);
	call hcs_$delentry_seg (p, ec);

     end;




		    sweep.pl1                       04/26/88  1220.7rew 04/26/88  1214.5      139509



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




/****^  HISTORY COMMENTS:
  1) change(87-10-06,Parisek), approve(88-02-03,MCR7845),
     audit(88-04-12,Lippard), install(88-04-26,MR12.2-1043):
     Implement multi-segment file application for possible >256K disk_stat
     segment.
                                                   END HISTORY COMMENTS */


/* format: style4 */
sweep:
     procedure options (variable);

/* This procedure does a "getquota" on all directories and puts the returned values in a file.
   The quota, used, and time-page product figures for both segments and directories are recorded.
   Output segment is "disk_stat" unless "-of PATH" is specified.
   Root node is ">" unless a non-control arg is encountered.
   If a directory has no quota, the subtree under it is not scanned, since quota must be in an
   unbroken chain (so we need not look at all directories).
   The program attempts to give itself access as needed and clean up later.
   THVV
*/

/* Modified June 1975 by J. C. Whitmore for setting directory privilege. */
/* Modified April 1976 by THVV and TAC to implement recording of directory pages used under NSS */
/* Modified December 1980 by C. Hornig for connection failures */
/* Modified 83-09-25 by E. N. Kittlitz, per SGH (UNCA) to clean up AST if privileged */

dcl  path char (168) init (">");
dcl  dn char (168) init (get_wdir_ ());
dcl  pdir char (168) init (get_pdir_ ());
dcl  en char (32) init ("disk_stat");
dcl  areap ptr;
dcl  fcbp ptr;
dcl  (quota, tot_dquota, tot_squota) fixed bin (35) init (0); /* GLOBAL variables, total quota */
dcl  (used, tot_dused, tot_sused) fixed bin (35) init (0);	/* GLOBAL variables, total use */
dcl  hpriv bit (1) aligned;
dcl  ppriv bit (1) aligned;
dcl  seg_ptr ptr;
dcl  uid bit (36) aligned;
dcl  (n, tn) fixed bin;				/* GLOBAL variable, number of dirs */
dcl  bitc fixed bin (24);
dcl  an fixed bin;
dcl  ap ptr;					/* ptr to arg */
dcl  al fixed bin;					/* lth of arg */
dcl  bchr char (al) based (ap) unaligned;
dcl  ec fixed bin (35);				/* err code */
dcl  starting_level fixed bin;			/* level in hierarchy where the sweep starts (root = 0) */
dcl  (i, j) fixed bin;
dcl  bfsw bit (1) aligned init ("1"b);			/* default to brief mode */
dcl  pddsw bit (1) aligned init ("0"b);			/* default is to omit >pdd from the sweep */
dcl  priv_off bit (1) aligned;			/* flag to tell that system privileges are off */
dcl  priv_set fixed bin (35);				/* this will be zero if we set system privileges */
dcl  cpx fixed bin;

dcl  (addr, clock, index, null, rtrim, substr, sum) builtin;

dcl  (cleanup, linkage_error, seg_fault_error) condition;

%include disk_stat;

dcl  com_err_ entry options (variable);
dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  get_system_free_area_ entry () returns (ptr);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  (get_pdir_, get_wdir_) entry () returns (char (168));
dcl  get_group_id_ entry () returns (char (32));
dcl  hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed bin (35));
dcl  hcs_$quota_read
	entry (char (*), fixed bin, fixed bin (71), fixed bin (35), bit (36), fixed bin (1), fixed bin, fixed bin (35));
dcl  hcs_$dir_quota_read
	entry (char (*), fixed bin, fixed bin (71), fixed bin (35), bit (36), fixed bin (1), fixed bin, fixed bin (35));
dcl  hphcs_$quota_read
	entry (char (*), fixed bin, fixed bin (71), fixed bin (35), bit (36), fixed bin (1), fixed bin, fixed bin (35));
dcl  hphcs_$dir_quota_read
	entry (char (*), fixed bin, fixed bin (71), fixed bin (35), bit (36), fixed bin (1), fixed bin, fixed bin (35));
dcl  hphcs_$deactivate entry (bit (36) aligned, fixed bin (35));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$msf_get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35));
dcl  system_privilege_$dir_priv_on entry (fixed bin (35));
dcl  system_privilege_$dir_priv_off entry (fixed bin (35));
dcl  phcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  phcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$delete_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35));
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hphcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));

dcl  (
     error_table_$badopt,
     error_table_$noarg
     ) ext fixed bin (35);

dcl  1 acla aligned,
       2 userid char (32),
       2 mode bit (36),
       2 rcode fixed bin (35);

dcl  1 acld aligned,
       2 userid char (32),
       2 rcode fixed bin (35);
dcl  cp_array (0:4) ptr;

%page;
	ec = 0;
	do an = 1 by 1 while (ec = 0);
	     call cu_$arg_ptr (an, ap, al, ec);
	     if ec = 0 then do;
		if /* case */ substr (bchr, 1, 1) ^= "-" then do;
		     call absolute_pathname_ (bchr, path, ec);
		     if ec ^= 0 then do;
			call com_err_ (ec, "sweep", "^a", bchr);
			return;
		     end;
		end;
		else if bchr = "-bf" then bfsw = "1"b;
		else if bchr = "-brief" then bfsw = "1"b;
		else if bchr = "-lg" then bfsw = "0"b;
		else if bchr = "-long" then bfsw = "0"b;
		else if bchr = "-pdd" then pddsw = "1"b;
		else if bchr = "-of" | bchr = "-output_file" then do;
		     an = an + 1;
		     call cu_$arg_ptr (an, ap, al, ec);
		     if ec ^= 0 then do;
			call com_err_ (error_table_$noarg, "sweep", "after ""-output_file""");
			return;
		     end;
		     call expand_pathname_ (bchr, dn, en, ec);
		     if ec ^= 0 then do;
			call com_err_ (ec, "sweep", "^a", bchr);
			return;
		     end;
		end;
		else do;
		     call com_err_ (error_table_$badopt, "sweep", "^a", bchr);
		     return;
		end;
	     end;
	end;

	priv_off = "1"b;				/* assume that we don't have dir privilege */
	priv_set = 1;				/* and that we did not set dir priv */
	hpriv = "0"b;
	ppriv = "0"b;
	on cleanup
	     begin;				/* so we can undo what we did */
		if priv_set = 0 then call system_privilege_$dir_priv_off (priv_set);
	     end;

/*	Now we will try to set dir privilege so we can look at each dir in the system. */

	on linkage_error go to revert_handler;		/* in case of no access to system_privilege_ */

	call system_privilege_$dir_priv_on (priv_set);	/* try to set it */
	priv_off = "0"b;				/* privileges are on now for sure */
revert_handler:
	revert linkage_error;			/* it was only to catch system_privilege_ error */
	on linkage_error go to revert1;
	call hphcs_$star_ (">", "**", 0, null (), 0, null (), null (), 0);
	hpriv = "1"b;				/* Didn't fault, so im super */
revert1:
	revert linkage_error;

	on linkage_error goto revert2;
	call phcs_$initiate (">", "", "", 0, 0, null (), 0);
	ppriv = "1"b;
revert2:	revert linkage_error;

	if priv_off then do;			/* see if we now have the dir priv */
	     if bfsw
	     then call com_err_ (0, "sweep",		/* give this message if we supress others */
		     "Unable to set directory privilege. Access to storage system may not be complete.");
	     priv_set = 1;				/* just to be safe */
	end;

	cp_array (*), fcbp, sp = null ();
	cpx = 0;
	call msf_manager_$open (dn, en, fcbp, ec);
	if fcbp = null () then do;
	     call com_err_ (ec, "sweep", "");
	     return;
	end;

	call msf_manager_$get_ptr (fcbp, cpx, "1"b, cp_array (0), 0, ec);
	if cp_array (0) = null () then do;
	     call com_err_ (ec, "sweep", "^a", en);
	     return;
	end;
	if ec ^= 0 then do;
	     call com_err_ (ec, "sweep", "");
	     return;
	end;

	sp = cp_array (0);
	n, tn = 0;				/* Start with no directories. */

	acla.userid = get_group_id_ ();
	acld.userid = acla.userid;
	acla.mode = "111"b;

	areap = get_system_free_area_ ();

/* Compute starting level, so that a given directory will always have the same level number,
   no matter where the sweep starts */

	i = 2;					/* skip the leading ">" since the root is level zero */
	j = 1;					/* just to get past the "while" the first time */
	do starting_level = -1 by 1			/* count ">"s in path */
	     while (j ^= 0);			/* and quit when there are no more */
	     j = index (substr (path, i), ">");		/* look for one */
	     if j ^= 0
	     then					/* if there was one */
		i = i + j;			/* move past it */
	end;					/* increment starting_level, then go test j */
						/* for root, we fall thru after setting starting_level to zero */

	call process (path, starting_level);		/* Looks innocent ... */

	if cpx > 0 then do;
	     sp = cp_array (0);
	     tn = tn + n;
	end;
	else tn = n;				/* to set dents below */
	disk_stat.dtime = clock ();			/* read clock */
	quota = tot_dquota + tot_squota;
	used = tot_dused + tot_sused;
	call ioa_ ("^d/^d", quota, used);		/* type total */
	call ioa_ ("dir: ^d/^d", tot_dquota, tot_dused);
	call ioa_ ("seg: ^d/^d", tot_squota, tot_sused);
	disk_stat.dents = tn;
	if fcbp ^= null then call msf_manager_$close (fcbp);
	bitc = 36 * (lodh + tn * lode);		/* Compute bit count. */
	call hcs_$set_bc (dn, en, bitc, ec);		/* ... */

	if priv_set = 0 then call system_privilege_$dir_priv_off (priv_set);
						/* reset if we did it */

	return;					/* Done. */
%page;
process:
     procedure (apth, lvl);

/* internal doit procedure */

dcl  apth char (168),				/* path of tree to process */
     lvl fixed bin;					/* recursion level */

dcl  npth char (168),				/* new path for recursion */
     ddn char (168),				/* ... for expand */
     een char (32),					/* ... */
     error_table_$nomatch fixed bin (35) ext,
     (stpp, dtpp) fixed bin (71),			/* args for quota_read */
     updatime fixed bin (35),
     (squota, dquota, sused, dused) fixed bin,
     slvid bit (36),
     (dquota_sw, squota_sw) fixed bin (1),
     ifail fixed bin,
     ecc fixed bin (35),
     (ii, nix) fixed bin;				/* indices */
dcl  sys_info$max_seg_size fixed bin (35) ext static;

	star_entry_ptr, star_names_ptr = null ();
	on cleanup
	     begin;				/* get ready to undo everything */
		if star_names_ptr ^= null then free star_names;
		if star_entry_ptr ^= null then free star_entries;
		if ifail = 0 then call hcs_$delete_dir_acl_entries (ddn, een, addr (acld), 1, ecc);
	     end;

	call expand_pathname_ (apth, ddn, een, ecc);
	if ecc ^= 0 then do;
	     call com_err_ (ecc, "sweep", "^a", apth);
	     return;
	end;

	if hpriv
	then ifail = 2;
	else do;
	     call hcs_$add_dir_acl_entries (ddn, een, addr (acla), 1, ecc);
	     if ecc ^= 0
	     then ifail = 1;
	     else ifail = 0;
	end;

	on seg_fault_error goto pexit;

	if hpriv
	then call hphcs_$dir_quota_read (apth, dquota, dtpp, updatime, slvid, dquota_sw, dused, ecc);
	else call hcs_$dir_quota_read (apth, dquota, dtpp, updatime, slvid, dquota_sw, dused, ecc);
	if ecc ^= 0 then goto gq_err;

	if hpriv
	then call hphcs_$quota_read (apth, squota, stpp, updatime, slvid, squota_sw, sused, ecc);
	else call hcs_$quota_read (apth, squota, stpp, updatime, slvid, squota_sw, sused, ecc);
	if ecc ^= 0 then do;
gq_err:
	     if ^bfsw then call com_err_ (ecc, "sweep", "getquota on ^a", apth);
	     go to pexit;
	end;

	if dquota_sw + squota_sw ^= 0 then do;		/* if either dir quota or seg quota nonzero,
						   add it in and keep recursing */
	     tot_dused = tot_dused + dused;		/* add up global use */
	     tot_sused = tot_sused + sused;
	     tot_dquota = tot_dquota + dquota;		/* and global quota */
	     tot_squota = tot_squota + squota;

	     if (lodh + (n+1) * lode) > sys_info$max_seg_size then do;
		cpx = cpx + 1;
		call msf_manager_$msf_get_ptr (fcbp, cpx, "1"b, cp_array (cpx), 0, ec);
		if ec ^= 0 then do;
		     call com_err_ (ec, "sweep", "Cannot expand MSF for ^a", en);
		     goto pexit;
		end;
		sp = cp_array (cpx);
		tn = tn + n;
		n = 0;
	     end;
	     n = n + 1;				/* allocate a new slot */
	     disk_stat.spth (n) = apth;		/* fill in path name */
	     disk_stat.sqta (n) = squota;		/* segment quota */
	     disk_stat.dqta (n) = dquota;		/* directory quota */

	     if squota = 0 then stpp = 0;		/* clear possible garbage, in case the */
	     if dquota = 0 then dtpp = 0;		/* storage system is not careful about doing so */

	     disk_stat.suse (n) = sused;		/* segment pages used */
	     disk_stat.duse (n) = dused;		/* directory pages used */
	     disk_stat.slvid (n) = slvid;		/* son's lvid */
	     disk_stat.stpp (n) = stpp;		/* segment time-page product */
	     disk_stat.dtpp (n) = dtpp;		/* directory time-page product */
	     disk_stat.slev (n) = lvl;		/* .. recursion level */

	     if hpriv
	     then call hphcs_$star_ (apth, "**", star_BRANCHES_ONLY, areap, star_entry_count, star_entry_ptr,
		     star_names_ptr, ecc);
	     else call hcs_$star_ (apth, "**", star_BRANCHES_ONLY, areap, star_entry_count, star_entry_ptr,
		     star_names_ptr, ecc);
	     revert seg_fault_error;
	     if ecc = error_table_$nomatch then go to pexit;
						/* Get all names. If none, go. */
	     if ecc ^= 0 then do;			/* If any other error from star, name it. */
		if ^bfsw then call com_err_ (ecc, "sweep", "star on ^a", apth);
		go to pexit;
	     end;
inloop:
	     do ii = 1 to star_entry_count;		/* Now do all branches, look for sub-dirs. */
		if star_entries (ii).type = star_DIRECTORY then do;
		     nix = star_entries (ii).nindex;
		     if apth ^= ">"			/* Fabricate path name. */
		     then npth = rtrim (apth) || ">" || star_names (nix);
		     else do;			/* The root is special. */
			npth = ">" || star_names (nix);
			if ^pddsw
			then			/* unless user said to sweep >pdd */
			     if (npth = ">process_dir_dir")
						/* if this is >pdd */
				| (npth = ">pdd") | (substr (npth, 1, 6) = ">pdd.!")
			     then goto nopdir;
		     end;
		     call process (npth, lvl + 1);	/* recursion here */
nopdir:
		end;
	     end inloop;
	     free star_names;
	     free star_entries;
	end;
pexit:
	if ppriv & hpriv then			/* if privileged, prepare to clean up */
	     call phcs_$initiate (ddn, een, "", 0, 0, seg_ptr, ecc);
	else seg_ptr = null;

	if (ifail = 0) & (apth ^= pdir) & ^pddsw
	then					/* don't deny user access to his own pdir */
	     call hcs_$delete_dir_acl_entries (ddn, een, addr (acld), 1, ecc);

	if seg_ptr ^= null then do;			/* now hardcore can't possibly want to touch the thing */
	     call hcs_$get_uid_seg (seg_ptr, uid, ecc);
	     if ecc = 0 then call hphcs_$deactivate (uid, ecc);
	     call phcs_$terminate_noname (seg_ptr, ecc);
	end;
	ecc = 0;
%page;
%include star_structures;

     end process;					/* Whew. */
%include access_mode_values;
%page;

     end sweep;




		    system_daily_report.pl1         04/09/85  1438.3r w 04/08/85  1133.5       83790



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

/* format: style3 */

system_daily_report:
     procedure options (variable);

/* SYSTEM_DAILY_REPORT - Generate Multics system usage statistics. */

/* Modified 1984-08-31 BIM for V3 usage totals. */

dcl	dn		char (168),		/* Directory name */
	en		char (32),		/* Entry name */
	datstr		char (24),		/* Formatted date of start */
	datstr1		char (24),		/* Formatted date end */
	(i, j, k, l, m, n)	fixed bin,		/* indices */
	conn		fixed bin (71),		/* total connect time in microseconds today */
	nlogins		fixed bin,		/* # sessions today */
	ncshd		fixed bin,		/* # crashed sessions today */
	nabs		fixed bin,		/* # abs jobs today */
	dollar_delta	float bin,		/* charge today */
	(fract, fract1)	float bin,		/* used in percent calculation */
	(tnlogins, tncsh, tnabs, tqta, tusage, tnproj, tnusers)
			fixed bin init (0),
	tconn		fixed bin (71) init (0),
	qlim		fixed bin,
	(dayunits, munits)	fixed bin,
	(dayconfigs, mconfigs)
			fixed bin,
	(xcpu, xmem, xbulk) fixed bin,
	ztime		fixed bin (71),
	dummy		char (10),		/* dummy title */
	comp		char (120),		/* company title */
	dept		char (120),		/* department title */
	ap		ptr,			/* ptr to arg */
	al		fixed bin (21),		/* lth of arg */
	bchr		char (al) unaligned based (ap),
						/* access struc for arg */
	ec		fixed bin (35),		/* err code */
	xtotp		ptr;			/* ptr to yesterday's data */
dcl	arg_count		fixed bin;

dcl	heading		char (120) int static
			init (
			"Group^26xMonth^7xToday Logins  Crashed  Abs Jobs  Connect^4xQuota^5xUsed  Projects  Users^/"
			);

dcl	(addr, null, substr, index, unspec, length, bit, fixed, divide, mod, abs)
			builtin;

dcl	error_table_$unimplemented_version
			fixed bin (35) ext static;

dcl	system_info_$titles entry (char (*), char (*), char (*), char (*));
dcl	pathname_		entry (character (*), character (*)) returns (character (168));
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	expand_pathname_$add_suffix
			entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl	ioa_		entry options (variable);
dcl	ioa_$rsnnl	entry options (variable);
dcl	date_time_	entry (fixed bin (71), char (*));
dcl	com_err_$suppress_name
			entry () options (variable);
dcl	com_err_		entry options (variable);

dcl	initiate_file_	entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35))
			;
dcl	terminate_file_	entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl	cleanup		condition;
dcl	ME		char (32) init ("system_daily_report") int static options (constant);

%page;

%include access_mode_values;
%include terminate_file;
%include use_totals;



	use_totals_ptr, xtotp = null ();
	on cleanup call clean_up;
	call cu_$arg_count (arg_count, ec);
	if ec ^= 0
	then do;
		call com_err_ (ME, ec);
		return;
	     end;
	if arg_count ^= 2
	then do;
		call com_err_$suppress_name (0, ME,
		     "Usage: system_daily_report today.use_totals yesterday.use_totals");
		return;
	     end;
	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_$add_suffix (bchr, "use_totals", dn, en, ec);
	if ec ^= 0
	then
PN_ERROR:
	     do;
		call com_err_ (ec, ME, "Invalid use totals pathname ^a.", bchr);
		go to ERROR;
	     end;

	call initiate_file_ (dn, en, R_ACCESS, use_totals_ptr, (0), ec);
	if ec ^= 0
	then
INITIATE_ERROR:
	     do;
		call com_err_ (ec, ME, "^a", pathname_ (dn, en));
		go to ERROR; /* it might be the second seg */
	     end;

	if use_totals.version ^= USE_TOTALS_VERSION_3
	then
UT_VERSION_ERROR:
	     do;
		call com_err_ (error_table_$unimplemented_version, ME, "^a is not version 3", pathname_ (dn, en));
		go to ERROR;
	     end;

	call cu_$arg_ptr (2, ap, al, (0));
	call expand_pathname_$add_suffix (bchr, "use_totals", dn, en, ec);
	if ec ^= 0
	then go to PN_ERROR;
	call initiate_file_ (dn, en, R_ACCESS, xtotp, (0), ec);
	if ec ^= 0
	then go to INITIATE_ERROR;
	if xtotp -> use_totals.version ^= USE_TOTALS_VERSION_3
	then go to UT_VERSION_ERROR;

	call system_info_$titles (dummy, dummy, comp, dept);
						/* Get report titles */

	call ioa_ ("^-^a^/^/^-^-^a", comp, dept);	/* Start report */
	call date_time_ (xtotp -> period_end, datstr);	/* Make printable date */
	call date_time_ (use_totals.period_end, datstr1);
	call ioa_ ("^/Multics usage report from ^a^/^23xto ^a", datstr, datstr1);

	munits = 0;
	dayunits = 0;
	xcpu, xmem = -1;
	mconfigs = -1;
	dayconfigs = 0;

	do i = 1 to use_totals.max_day_log;
	     if i = use_totals.max_day_log
	     then qlim = use_totals.max_qhour;
	     else qlim = 96;
	     do j = 1 to qlim;
		ztime = use_totals.daylog (i).qh (j).time;
		if ztime = 0
		then go to skip;
		if use_totals.daylog (i).qh (j).cpu = xcpu
		then if use_totals.daylog (i).qh (j).kmem = xmem
		     then go to sameconf;

		if use_totals.daylog (i).qh (j).cpu = 0
		then go to sameconf;
		if ztime > xtotp -> use_totals.period_end
		then dayconfigs = dayconfigs + 1;
		mconfigs = mconfigs + 1;
		xcpu = use_totals.daylog (i).qh (j).cpu;
		xmem = use_totals.daylog (i).qh (j).kmem;
sameconf:
		if use_totals.daylog (i).qh (j).nunits > dayunits
		then if ztime > xtotp -> use_totals.period_end
		     then dayunits = use_totals.daylog (i).qh (j).nunits;
		if use_totals.daylog (i).qh (j).nunits > munits
		then munits = use_totals.daylog (i).qh (j).nunits;
skip:
	     end;
	end;

	call ioa_ ("^/^9xStarts  Crashes^6xUptime   CPU avail.^6x%Idle  %Overhead  Max load units  Reconfigurations");
	call ioa_ ("^/Month^3x^7d^2x^7d^5x^7a^5x^7a^5x^7.1f^4x^7.1f^9x^7.1f^11x^7d", sys_starts, sys_crash,
						/* Write month-to-date totals */
	     tcv (uptime), tcv (cpu_avail), (idle * 1e2) / cpu_avail,
	     ((cpu_avail - idle - total_cpu) * 1e2) / cpu_avail, munits / 1e1, mconfigs);
	conn = cpu_avail - xtotp -> cpu_avail;		/* Calculate CPU available today */
	if conn = 0
	then fract = 0e0;				/* Aviod zdiv in case system_total was not run */
	else fract = ((idle - xtotp -> idle) * 1e2) / conn;
	if conn = 0
	then fract1 = 0e0;
	else fract1 = ((conn - idle - total_cpu + xtotp -> idle + xtotp -> total_cpu) * 1e2) / conn;
	call ioa_ ("Today^3x^7d^2x^7d^5x^7a^5x^7a^5x^7.1f^4x^7.1f^9x^7.1f^11x^7d", sys_starts - xtotp -> sys_starts,
	     sys_crash - xtotp -> sys_crash, tcv (uptime - xtotp -> uptime), tcv (cpu_avail - xtotp -> cpu_avail),
	     fract, fract1, dayunits / 1e1, dayconfigs);
	call ioa_ ("^/^3xCurrent system: ^8a^6xMonth-to-date MTBF: ^7a^/", last_sysid,
	     tcv (divide (uptime, sys_crash + 1, 71, 0)));
	call ioa_ ("^3xCurrent disk capacity: ^6d recs, ^5.1f% full^/^/", use_totals.disk_available,
	     ((use_totals.disk_available - use_totals.disk_left) * 1e2) / use_totals.disk_available);

	call ioa_ (heading);			/* Now user statistics part of report */
	do i = 2 to ntypes, 1;			/* Put paying customers at bottom of report */
	     dollar_delta = dollar_charge (i) - xtotp -> dollar_charge (i);
	     nlogins = logins (i) - xtotp -> logins (i);	/* Calculate usage for today */
	     tnlogins = tnlogins + nlogins;
	     ncshd = crashes (i) - xtotp -> crashes (i);	/* ... */
	     tncsh = tncsh + ncshd;
	     conn = 0;				/* Must add up connect time in each shift */
	     do j = 0 to 7;				/* Loop on shifts */
		conn = conn + (connect (i, j) - xtotp -> connect (i, j));
	     end;
	     tconn = tconn + conn;
	     nabs = 0;				/* Get count of abs jobs */
	     do j = 1 to 4;				/* Loop on queues */
		nabs = nabs + absentee.jobs (i, j) - xtotp -> absentee.jobs (i, j);
	     end;
	     tnabs = tnabs + nabs;
	     tqta = tqta + disk_quota (i);
	     tusage = tusage + disk_usage (i);
	     tnproj = tnproj + nproj (i);
	     tnusers = tnusers + nusers (i);
	     call ioa_ ("^24a  ^10.2f  ^10.2f  ^5d  ^7d  ^8d  ^7a  ^7d  ^7d  ^8d  ^5d", utype (i), dollar_charge (i),
		dollar_delta, nlogins, ncshd, nabs, tcv (conn), disk_quota (i), disk_usage (i), nproj (i), nusers (i))
		;
	end;
	call ioa_ ("^/TOTAL^45x^5d  ^7d  ^8d  ^7a  ^7d  ^7d  ^8d  ^5d", tnlogins, tncsh, tnabs, tcv (tconn), tqta,
	     tusage, tnproj, tnusers);

	call ioa_ ("");				/* End of loop on bins. */

ERROR:
	call clean_up;
	return;

/* internal procedure to format time for printing */

tcv:
     proc (x) returns (char (7));

dcl	x		fixed bin (71);

dcl	(a, b, c, d)	fixed bin (35),
	cc		char (7);

	a = divide (x, 1000000, 35, 0);
	b = divide (a, 60, 35, 0);
	a = mod (a, 60);
	c = divide (b, 60, 35, 0);
	b = mod (b, 60);
	call ioa_$rsnnl ("^4d:^2d", cc, d, c, b);
	if substr (cc, 6, 1) = " "
	then substr (cc, 6, 1) = "0";
	return (cc);

     end tcv;

clean_up:
     procedure;

	if use_totals_ptr ^= null ()
	then call terminate_file_ (use_totals_ptr, (0), TERM_FILE_TERM, (0));
	if xtotp ^= null ()
	then call terminate_file_ (xtotp, (0), TERM_FILE_TERM, (0));
	return;
     end clean_up;
     end system_daily_report;




		    system_monthly_report.pl1       04/09/85  1438.3r w 04/08/85  1133.6      162522



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

/* format: style3 */

system_monthly_report:
     procedure options (variable);

/* SYSTEM_MONTHLY_REPORT - Generate Multics system usage statistics. */

/* Modified by T. Casey, March 75, to add checks for zero values of
   previous month data, to avoid division by zero in percent computations. */
/* Modified 1984-08-31 BIM for version 3 use_totals */

dcl	dn		char (168),		/* Directory name */
	en		char (32),		/* Entry name */
	datstr		char (24),		/* Formatted date of start */
	datstr1		char (24),		/* Formatted date end */
	(i, j, k, l, m, n)	fixed bin,		/* indices */
	conn		fixed bin (71),		/* total connect time in microseconds today */
	nlogins		fixed bin,		/* # sessions today */
	ncshd		fixed bin,		/* # crashed sessions today */
	nabs		fixed bin,		/* # abs jobs today */
	fract		float bin,		/* used in percent calculation */
	(tnlogins, tncsh, tnabs, tqta, tusage, tnproj, tnusers)
			fixed bin init (0),
	(xtnlogins, xtncsh, xtnabs, xtqta, xtusage, xtnproj, xtnusers)
			fixed bin init (0),
	xconn		fixed bin (71),
	(char10a, char10b)	char (10),
	(pct, xpct)	float bin,
	(totmemu, xtotmemu) fixed bin (71) init (0),
	(totprt, xtotprt)	fixed bin (71) init (0),
	(totdk, xtotdk)	fixed bin (71) init (0),
	(totrev, xtotrev)	float bin init (0e0),
	(disk_capy, xdisk_capy)
			fixed bin (35),
	xtconn		fixed bin (71) init (0),
	tconn		fixed bin (71) init (0),
	dummy		char (10),		/* dummy title */
	comp		char (120),		/* company title */
	dept		char (120),		/* department title */
	ap		ptr,			/* ptr to arg */
	al		fixed bin (21),		/* lth of arg */
	bchr		char (al) unaligned based (ap),
						/* access struc for arg */
	ec		fixed bin (35),		/* err code */
	totp		ptr,			/* ptr to today's data */
	xtotp		ptr;			/* prt to last month's data. */
dcl	arg_count		fixed bin;

dcl	bt		fixed bin (71),		/* boot time */
	ztime		fixed bin (71),		/* random sample time */
	qlim		fixed bin,
	(xcpu, xmem)	fixed bin,
	(daycrash, daystarts, dayconfigs, dayunits)
			fixed bin,
	(mcrash, mstarts, munits, mconfigs)
			fixed bin,
	daysystem		char (8);

dcl	C1		fixed bin (71) int static init (3600000000);
						/* Convert clock time to hours. */
dcl	C2		fixed bin (71) int static init (1800000000);
						/* Half-hour for rounding. */

dcl	formatd		char (32) int static init ("^5a ^3a^7d^8d^17d^16.1f  ^8a"),
	formatdt		char (32) int static init ("^/^4d days^7d^8d^17d^16.1f");

dcl	heading		char (120) int static
			init (
			"Group^25xCharge Logins  Crashed  Abs Jobs  Connect^4xQuota^5xUsed  Projects  Users^/");

dcl	(addr, null, substr, index, unspec, length, bit, fixed, divide, mod, abs)
			builtin;

dcl	error_table_$unimplemented_version
			fixed bin (35) ext static;

dcl	pathname_		entry (character (*), character (*)) returns (character (168));
dcl	system_info_$titles entry (char (*), char (*), char (*), char (*));
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	com_err_$suppress_name
			entry () options (variable);
dcl	expand_pathname_$add_suffix
			entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl	ioa_		entry options (variable);
dcl	ioa_$rsnnl	entry options (variable);
dcl	date_time_	entry (fixed bin (71), char (*));
dcl	com_err_		entry options (variable);
dcl	initiate_file_	entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35))
			;
dcl	terminate_file_	entry (pointer, fixed binary (24), bit (*), fixed binary (35));

dcl	cleanup		condition;
dcl	ME		char (32) init ("system_monthly_report") int static options (constant);
%page;

%include access_mode_values;
%include terminate_file;
%include use_totals;


	use_totals_ptr, xtotp = null ();
	on cleanup call clean_up;
	call cu_$arg_count (arg_count, ec);
	if ec ^= 0
	then do;
		call com_err_ (ME, ec);
		return;
	     end;
	if arg_count ^= 2
	then do;
		call com_err_$suppress_name (0, ME,
		     "Usage: system_monthly_report today.use_totals yesterday.use_totals");
		return;
	     end;
	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_$add_suffix (bchr, "use_totals", dn, en, ec);
	if ec ^= 0
	then
PN_ERROR:
	     do;
		call com_err_ (ec, ME, "Invalid use totals pathname ^a.", bchr);
		go to ERROR;
	     end;

	call initiate_file_ (dn, en, R_ACCESS, use_totals_ptr, (0), ec);
	if ec ^= 0
	then
INITIATE_ERROR:
	     do;
		call com_err_ (ec, ME, "^a", pathname_ (dn, en));
		go to ERROR;
	     end;

	if use_totals.version ^= USE_TOTALS_VERSION_3
	then
UT_VERSION_ERROR:
	     do;
		call com_err_ (error_table_$unimplemented_version, ME, "^a is not version 3", pathname_ (dn, en));
		go to ERROR;
	     end;

	call cu_$arg_ptr (2, ap, al, (0));
	call expand_pathname_$add_suffix (bchr, "use_totals", dn, en, ec);
	if ec ^= 0
	then go to PN_ERROR;

	call initiate_file_ (dn, en, R_ACCESS, xtotp, (0), ec);
	if ec ^= 0
	then go to INITIATE_ERROR;
	if xtotp -> use_totals.version ^= USE_TOTALS_VERSION_3
	then go to UT_VERSION_ERROR;


	call system_info_$titles (dummy, dummy, comp, dept);
						/* Get report titles */

	call ioa_ ("^-^a^/^/^-^-^a", comp, dept);	/* Start report */
	call date_time_ (use_totals.period_begin, datstr);/* Make printable date */
	call date_time_ (use_totals.period_end, datstr1);
	call ioa_ ("^/Multics usage report from ^a^/^23xto ^a", datstr, datstr1);

	disk_capy = use_totals.disk_available;		/* Get total disk on system. */
	if disk_capy = 0
	then disk_capy = 1;				/* Can't be zero. */
	xdisk_capy = xtotp -> use_totals.disk_available;	/* .. */
	if xdisk_capy = 0
	then xdisk_capy = disk_capy;			/* Fix so no installation problems. */

	call ioa_ ("^/^9xStarts  Crashes^6xUptime   CPU avail.^6x%Idle  %Overhead");
	call ioa_ ("^/^8x^7d  ^7d^5x^7a^5x^7a^5x^7.1f^4x^7.1f", sys_starts, sys_crash,
						/* Write month-to-date totals */
	     tcv (uptime), tcv (cpu_avail), (idle * 1e2) / cpu_avail,
	     ((cpu_avail - idle - total_cpu) * 1e2) / cpu_avail);
	call ioa_ ("^/^3xCurrent system: ^8a^20xMTBF: ^7a^/", last_sysid, tcv (divide (uptime, sys_crash + 1, 71, 0)));
	call ioa_ ("^3xCurrent disk capacity: ^10d recs, ^5.1f% full^/", disk_capy,
	     ((disk_capy - use_totals.disk_left) * 1e2) / disk_capy);

	call ioa_ (heading);			/* Now user statistics part of report */
	do i = 2 to ntypes, 1;			/* Put paying customers at bottom of report */
	     nlogins = logins (i);
	     tnlogins = tnlogins + nlogins;
	     ncshd = crashes (i);
	     tncsh = tncsh + ncshd;
	     conn = 0;				/* Must add up connect time in each shift */
	     do j = 0 to 7;				/* Loop on shifts */
		conn = conn + connect (i, j);
		totmemu = totmemu + core (i, j);
	     end;
	     tconn = tconn + conn;
	     nabs = 0;				/* Get count of abs jobs */
	     do j = 1 to 4;				/* Loop on queues */
		nabs = nabs + absentee.jobs (i, j);
		totprt = totprt + iod.lines (i, j);
		totmemu = totmemu + absentee.memory (i, j);
	     end;
	     tnabs = tnabs + nabs;
	     totdk = totdk + disk_psec (i);
	     tqta = tqta + disk_quota (i);
	     tusage = tusage + disk_usage (i);
	     tnproj = tnproj + nproj (i);
	     tnusers = tnusers + nusers (i);
	     if flag (i) = "$"
	     then totrev = totrev + dollar_charge (i);
	     call ioa_ ("^24a  ^10.2f  ^5d  ^7d  ^8d  ^7a  ^7d  ^7d  ^8d  ^5d", utype (i), dollar_charge (i), nlogins,
		ncshd, nabs, tcv (conn), disk_quota (i), disk_usage (i), nproj (i), nusers (i));
	     nlogins = xtotp -> use_totals.logins (i);
	     xtnlogins = xtnlogins + nlogins;
	     ncshd = xtotp -> use_totals.crashes (i);
	     xtncsh = xtncsh + ncshd;
	     conn = 0;				/* Must add up connect time in each shift */
	     do j = 0 to 7;				/* Loop on shifts */
		conn = conn + xtotp -> use_totals.connect (i, j);
		xtotmemu = xtotmemu + xtotp -> use_totals.ut (i).interactive (j).core;
	     end;
	     xtconn = xtconn + conn;
	     nabs = 0;				/* Get count of abs jobs */
	     do j = 1 to 4;				/* Loop on queues */
		nabs = nabs + xtotp -> use_totals.absentee.jobs (i, j);
		xtotprt = xtotprt + xtotp -> use_totals.iod.lines (i, j);
		xtotmemu = xtotmemu + xtotp -> use_totals.absentee.memory (i, j);
	     end;
	     xtnabs = xtnabs + nabs;
	     xtotdk = xtotdk + xtotp -> use_totals.disk_psec (i);
	     xtqta = xtqta + xtotp -> use_totals.disk_quota (i);
	     xtusage = xtusage + xtotp -> use_totals.disk_usage (i);
	     xtnproj = xtnproj + xtotp -> use_totals.nproj (i);
	     xtnusers = xtnusers + xtotp -> use_totals.nusers (i);
	     if xtotp -> use_totals.flag (i) = "$"
	     then xtotrev = xtotrev + xtotp -> use_totals.dollar_charge (i);
	end;
	call ioa_ ("^/TOTAL^33x^5d  ^7d  ^8d  ^7a  ^7d  ^7d  ^8d  ^5d", tnlogins, tncsh, tnabs, tcv (tconn), tqta,
	     tusage, tnproj, tnusers);

	if totrev = 0e0
	then totrev = use_totals.dollar_charge (1);
	if xtotrev = 0e0
	then xtotrev = xtotp -> use_totals.dollar_charge (1);

/* Now compare this month with last month.  */

	call ioa_ ("^/^/^44xLast Month  This Month   Change^/");
	call ioa_ ("^20xSystem hours up         ^10d  ^10d^2x^8a", divide (xtotp -> use_totals.uptime + C2, C1, 35, 0),
	     divide (use_totals.uptime + C2, C1, 35, 0), pctstr ((use_totals.uptime), (xtotp -> use_totals.uptime)));
	conn = use_totals.cpu_avail - use_totals.uptime;
	xconn = xtotp -> use_totals.cpu_avail - xtotp -> use_totals.uptime;
	call ioa_ ("^20x Two CPU hours          ^10d  ^10d^2x^8a", divide (xconn + C2, C1, 35, 0),
	     divide (conn + C2, C1, 35, 0), pctstr ((conn), (xconn)));
	conn = divide (use_totals.uptime, use_totals.sys_crash + 1, 71, 0);
	xconn = divide (xtotp -> use_totals.uptime, xtotp -> use_totals.sys_crash + 1, 71, 0);
	char10a = (3)" " || tcv (conn);
	char10b = (3)" " || tcv (xconn);
	call ioa_ ("^20xMTBF (hours)            ^10a  ^10a^2x^8a", char10b, char10a, pctstr ((conn), (xconn)));
	call ioa_ ("^20xCPU charged (hours)     ^10d  ^10d^2x^8a",
	     divide (xtotp -> use_totals.total_cpu + C2, C1, 35, 0), divide (use_totals.total_cpu + C2, C1, 35, 0),
	     pctstr ((use_totals.total_cpu), (xtotp -> use_totals.total_cpu)));
	call ioa_ ("^20xMemory units (Million)  ^10.1f  ^10.1f^2x^8a", xtotmemu / 1e9, totmemu / 1e9,
	     pctstr ((totmemu), (xtotmemu)));
	call ioa_ ("^20xPrint lines (Million)   ^10.1f  ^10.1f^2x^8a", xtotprt / 1e6, totprt / 1e6,
	     pctstr ((totprt), (xtotprt)));
	call ioa_ ("^20xTerminal hours          ^10d  ^10d^2x^8a", divide (xtconn + C2, C1, 35, 0),
	     divide (tconn + C2, C1, 35, 0), pctstr ((tconn), (xtconn)));
	call ioa_ ("^20xLogins                  ^10d  ^10d^2x^8a", xtnlogins, tnlogins,
	     pctstr ((tnlogins), (xtnlogins)));
	call ioa_ ("^20xAbsentee jobs           ^10d  ^10d^2x^8a", xtnabs, tnabs, pctstr ((tnabs), (xtnabs)));
	call ioa_ ("^20xDisk usage (page-months)^10d  ^10d^2x^8a", fixed (xtotdk / 2592e3, 35),
	     fixed (totdk / 2592e3, 35), pctstr ((totdk), (xtotdk)));
	call ioa_ ("^20xProjects                ^10d  ^10d^2x^8a", xtnproj, tnproj, pctstr ((tnproj), (xtnproj)));
	call ioa_ ("^20xUsers                   ^10d  ^10d^2x^8a", xtnusers, tnusers, pctstr ((tnusers), (xtnusers)));

	call ioa_ ("");

	call ioa_ ("^20xRevenue                 ^10d  ^10d^2x^8a", fixed (xtotrev, 35), fixed (totrev, 35),
	     pctstr (totrev, xtotrev));
	call ioa_ ("^20xCrashed sessions        ^10d  ^10d^2x^8a", xtncsh, tncsh, pctstr ((tncsh), (xtncsh)));
	pct = (tncsh * 1e2) / (tnlogins + tnabs);
	if (xtnlogins + xtnabs) <= 0e0
	then xpct = 0e0;
	else xpct = (xtncsh * 1e2) / (xtnlogins + xtnabs);
	call ioa_ ("^20x Percentage crashed     ^10.1f  ^10.1f^2x^8a", xpct, pct, pctstr (pct, xpct));

	call ioa_ ("");

	if xtotp -> use_totals.cpu_avail <= 0e0
	then xpct = 0e0;
	else xpct = xtotp -> use_totals.zidle * 1e2 / xtotp -> use_totals.cpu_avail;
	pct = use_totals.zidle * 1e2 / use_totals.cpu_avail;
	call ioa_ ("^20xZero idle               ^10.1f% ^10.1f% ^8a", xpct, pct, pctstr (pct, xpct));
	if xtotp -> use_totals.cpu_avail <= 0e0
	then xpct = 0e0;
	else xpct = xtotp -> use_totals.mpidle * 1e2 / xtotp -> use_totals.cpu_avail;
	pct = use_totals.mpidle * 1e2 / use_totals.cpu_avail;
	call ioa_ ("^20xMP idle                 ^10.1f% ^10.1f% ^8a", xpct, pct, pctstr (pct, xpct));
	conn = use_totals.idle - use_totals.zidle - use_totals.mpidle;
	xconn = xtotp -> use_totals.idle - xtotp -> use_totals.zidle - xtotp -> use_totals.mpidle;
	if xtotp -> use_totals.cpu_avail <= 0e0
	then xpct = 0e0;
	else xpct = xconn * 1e2 / xtotp -> use_totals.cpu_avail;
	pct = conn * 1e2 / use_totals.cpu_avail;
	call ioa_ ("^20xNMP idle                ^10.1f% ^10.1f% ^8a", xpct, pct, pctstr (pct, xpct));
	conn = use_totals.cpu_avail - use_totals.total_cpu - use_totals.idle;
	xconn = xtotp -> use_totals.cpu_avail - xtotp -> use_totals.total_cpu - xtotp -> use_totals.idle;
	if xtotp -> use_totals.cpu_avail <= 0e0
	then xpct = 0e0;
	else xpct = xconn * 1e2 / xtotp -> use_totals.cpu_avail;
	pct = conn * 1e2 / use_totals.cpu_avail;
	call ioa_ ("^20xOverhead                ^10.1f% ^10.1f% ^8a", xpct, pct, pctstr (pct, xpct));
	if xtotp -> use_totals.cpu_avail <= 0e0
	then xpct = 0e0;
	else xpct = xtotp -> use_totals.total_cpu * 1e2 / xtotp -> use_totals.cpu_avail;
	pct = use_totals.total_cpu * 1e2 / use_totals.cpu_avail;
	call ioa_ ("^20xCharged                 ^10.1f% ^10.1f% ^8a", xpct, pct, pctstr (pct, xpct));

	call ioa_ ("");

	call ioa_ ("^20xTotal quota             ^10d  ^10d^2x^8a", xtqta, tqta, pctstr ((tqta), (xtqta)));
	call ioa_ ("^20xDisk available          ^10d  ^10d^2x^8a", xdisk_capy, disk_capy,
	     pctstr ((disk_capy), (xdisk_capy)));
	pct = 1e2 * use_totals.disk_left / disk_capy;
	if xdisk_capy <= 0e0
	then xpct = 0e0;
	else xpct = 1e2 * xtotp -> use_totals.disk_left / xdisk_capy;
	call ioa_ ("^20x  unused                ^10.1f% ^10.1f% ^8a", xpct, pct, pctstr (pct, xpct));
	pct = (1e2 * (tusage)) / disk_capy;
	if xdisk_capy <= 0e0
	then xpct = 0e0;
	else xpct = (1e2 * (xtusage)) / xdisk_capy;
	call ioa_ ("^20x  paying                ^10.1f% ^10.1f% ^8a", xpct, pct, pctstr (pct, xpct));
	pct = (1e2 * (disk_capy - tusage - use_totals.disk_left)) / disk_capy;
	if xdisk_capy <= 0e0
	then xpct = 0e0;
	else xpct = (1e2 * (xdisk_capy - xtusage - xtotp -> use_totals.disk_left)) / xdisk_capy;
	call ioa_ ("^20x  system use            ^10.1f% ^10.1f% ^8a", xpct, pct, pctstr (pct, xpct));

/* Now put out the summary by day. */

	call ioa_ ("^|Multics usage report from ^a^/^23xto ^a^/^/^10xSummary by day", datstr, datstr1);

	call ioa_ ("^/^/Date^6xStarts Crashes Reconfigurations  Max load units  Sysid^/");

	mcrash, munits = 0;
	mstarts = -1;
	bt = -1;
	xcpu, xmem = -1;
	mconfigs, dayconfigs = -1;

	do i = 1 to use_totals.max_day_log;

	     daystarts = 0;
	     daycrash = 0;
	     daysystem = "";
	     dayunits = 0;

	     if i = use_totals.max_day_log
	     then qlim = use_totals.max_qhour;
	     else qlim = 96;

	     ztime = 0;
	     do j = 1 to qlim;
		if use_totals.daylog (i).qh (j).time = 0
		then go to skip;
		ztime = use_totals.daylog (i).qh (j).time;
		if use_totals.daylog (i).qh (j).starttime ^= bt
		then do;
			daystarts = daystarts + 1;
			mstarts = mstarts + 1;
			bt = use_totals.daylog (i).qh (j).starttime;
		     end;
		if use_totals.daylog (i).qh (j).crashtime ^= 0
		then if use_totals.daylog (i).qh (j).dump_number ^= 0
		     then do;
			     daycrash = daycrash + 1;
			     mcrash = mcrash + 1;
			end;
		if use_totals.daylog (i).qh (j).sysid > ""
		then daysystem = use_totals.daylog (i).qh (j).sysid;
		if use_totals.daylog (i).qh (j).cpu = xcpu
		then if use_totals.daylog (i).qh (j).kmem = xmem
		     then go to sameconf;
		if use_totals.daylog (i).qh (j).cpu = 0
		then go to sameconf;
		dayconfigs = dayconfigs + 1;
		mconfigs = mconfigs + 1;
		xcpu = use_totals.daylog (i).qh (j).cpu;
		xmem = use_totals.daylog (i).qh (j).kmem;
sameconf:
		if use_totals.daylog (i).qh (j).nunits > dayunits
		then dayunits = use_totals.daylog (i).qh (j).nunits;
		if use_totals.daylog (i).qh (j).nunits > munits
		then munits = use_totals.daylog (i).qh (j).nunits;
skip:
	     end;
	     if ztime = 0
	     then go to skip1;
	     call date_time_ (ztime, datstr);
	     call ioa_ (formatd, substr (datstr, 1, 5), substr (datstr, 22, 3), daystarts, daycrash, dayconfigs,
		dayunits / 1e1, daysystem);
	     if substr (datstr, 22, 3) = "Sun"
	     then call ioa_ ("");
	     dayconfigs = 0;
skip1:
	end;

	call ioa_ (formatdt, use_totals.max_day_log, mstarts, mcrash, mconfigs, munits / 1e1);

ERROR:
	call clean_up;

	return;

/* internal procedure to format time for printing */

tcv:
     proc (x) returns (char (7));

dcl	x		fixed bin (71);

dcl	(a, b, c, d)	fixed bin (35),
	cc		char (7);

	a = divide (x, 1000000, 35, 0);
	b = divide (a, 60, 35, 0);
	a = mod (a, 60);
	c = divide (b, 60, 35, 0);
	b = mod (b, 60);
	call ioa_$rsnnl ("^4d:^2d", cc, d, c, b);
	if substr (cc, 6, 1) = " "
	then substr (cc, 6, 1) = "0";
	return (cc);

     end tcv;

/* internal procedure to format percentage changes for printing (including checks for zero */

pctstr:
     proc (this_month_value, last_month_value) returns (char (8));

dcl	(this_month_value, last_month_value)
			float bin,
	cc		char (8),
	n		fixed bin;

	if last_month_value = 0e0
	then cc = "     -  ";
	else call ioa_$rsnnl ("^7.1f%", cc, n, (this_month_value - last_month_value) * 1e2 / last_month_value);
	return (cc);
     end pctstr;
clean_up:
     procedure;

	if use_totals_ptr ^= null ()
	then call terminate_file_ (use_totals_ptr, (0), TERM_FILE_TERM, (0));
	if xtotp ^= null ()
	then call terminate_file_ (xtotp, (0), TERM_FILE_TERM, (0));
	return;
     end clean_up;

     end system_monthly_report;




		    system_total.pl1                04/09/85  1438.3r w 04/08/85  1133.6      100242



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

/* format: style3 */

system_total:
     procedure options (variable);

/* SYSTEM_TOTAL - this program scans the system samples from "stat_seg" and puts them in "use_totals".

   stat_seg was created by the initializer process, which samples the system statistics every 15 minutes
   and saves the SST header, the TC_DATA header, and several other magic numbers, such as the configuration.
   These meters are kept in "stat_seg" and copied by "copy_as_meters" once a day.
   This program is then run to extract figures of lasting interest and to record them in "use_totals"
   for use by various reporting programs.

   THVV */
/* modified 4/77 to use hardcore defs THVV */
/* Modified 1984-08-31 BIM for v2 use_totals */

dcl	dn		char (168),
	en		char (32),
	statp		ptr,
	(tcmp, tcdp)	ptr,
	tot_dir		char (168),
	tot_ename		char (32),
	meter_time	float bin,
	cpu_time		float bin,
	time		float bin,
	upt		fixed bin (71) init (0),
	dayx		fixed bin init (0),
	(qlo, qhi)	fixed bin,
	last_dump		fixed bin (18),
	last_shutdown	bit (1) aligned,
	(fday, fqh)	fixed bin,
	(i, j, n)		fixed bin,
	ap		ptr,
	al		fixed bin (21),
	bchr		char (al) unaligned based (ap),
	double		fixed bin (71) aligned based,
	ec		fixed bin (35);
dcl	arg_count		fixed bin;

dcl	TCMidle_loc	fixed bin (18);
dcl	TCMinitialize_time_loc
			fixed bin (18);
dcl	TCMlast_time_loc	fixed bin (18);
dcl	TCMmp_idle_loc	fixed bin (18);
dcl	TCMprocessor_time_loc
			fixed bin (18);
dcl	TCMzero_idle_loc	fixed bin (18);
dcl	offset		fixed bin (18);

dcl	(mm, dd, yy, hh, min, ss, absda, wkd, shf, qtr)
			fixed bin;

dcl	error_table_$unimplemented_version
			fixed bin (35) ext static;

dcl	datebin_		entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
			fixed bin, fixed bin, fixed bin);
dcl	datebin_$revert	entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71));
dcl	ring0_get_$segptr	entry (char (*), char (*), ptr, fixed bin (35));
dcl	ring0_get_$definition
			entry (ptr, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35));
dcl	disk_left_	entry (fixed bin (35), fixed bin (35));

dcl	cv_dec_check_	entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	expand_pathname_$add_suffix
			entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl	com_err_$suppress_name
			entry () options (variable);
dcl	com_err_		entry options (variable);

dcl	initiate_file_	entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35))
			;
dcl	pathname_		entry (character (*), character (*)) returns (character (168));
dcl	terminate_file_	entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl	(addr, addrel, null, substr, divide, mod)
			builtin;

dcl	ME		char (32) init ("system_total") int static options (constant);

dcl	cleanup		condition;

%page;
%include access_mode_values;
%include terminate_file;
%include use_totals;
%include stat_seg;


	call cu_$arg_count (arg_count, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME);
		return;
	     end;
	if arg_count ^= 2
	then do;
		call com_err_$suppress_name (0, ME, "Usage: system_total METER_DATA USE_TOTALS");
		return;
	     end;

	statp, use_totals_ptr = null ();
	on cleanup call clean_up;

	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_$add_suffix (bchr, "", dn, en, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "Invalid meter data pathname ^a.", bchr);
		return;
	     end;
	call initiate_file_ (dn, en, R_ACCESS, statp, (0), ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a", pathname_ (dn, en));
		return;
	     end;

	call cu_$arg_ptr (2, ap, al, (0));
	call expand_pathname_$add_suffix (bchr, "use_totals", tot_dir, tot_ename, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "Invalid use_totals pathname ^a.", bchr);
		go to ERROR;
	     end;
	call initiate_file_ (tot_dir, tot_ename, RW_ACCESS, use_totals_ptr, (0), ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a", pathname_ (tot_dir, tot_ename));
		go to ERROR;
	     end;

	if use_totals.version ^= USE_TOTALS_VERSION_3
	then do;
		call com_err_ (error_table_$unimplemented_version, ME, "^a is not version 3.",
		     pathname_ (tot_dir, tot_ename));
		go to ERROR;
	     end;

/* Obtain a pointer to the ring 0 segment tc_data, and use its definitions */

	call ring0_get_$segptr ("", "tc_data", tcdp, ec);
	if ec ^= 0
	then call error ("tc_data");
	call ring0_get_$definition (tcdp, "", "last_time", offset, (0), ec);
	if ec ^= 0
	then call error ("tcm.last_time");
	TCMlast_time_loc = offset;
	call ring0_get_$definition (tcdp, "", "idle", offset, (0), ec);
	if ec ^= 0
	then call error ("tcm.idle");
	TCMidle_loc = offset;
	call ring0_get_$definition (tcdp, "", "initialize_time", offset, (0), ec);
	if ec ^= 0
	then call error ("tcm.initialize_time");
	TCMinitialize_time_loc = offset;
	call ring0_get_$definition (tcdp, "", "processor_time", offset, (0), ec);
	if ec ^= 0
	then call error ("tcm.processor_time");
	TCMprocessor_time_loc = offset;
	call ring0_get_$definition (tcdp, "", "zero_idle", offset, (0), ec);
	if ec ^= 0
	then call error ("tcm.zero_idle");
	TCMzero_idle_loc = offset;
	call ring0_get_$definition (tcdp, "", "mp_idle", offset, (0), ec);
	if ec ^= 0
	then call error ("tcm.mp_idle");
	TCMmp_idle_loc = offset;

	n = statistics.index;
	fday = use_totals.max_day_log;
	fqh = use_totals.max_qhour;
	i = 0;
redoit:
	i = i + 1;
	if i > n
	then go to exit;
	tcmp = addr (statistics.tcdata_contents (i, 1));

	if statistics.uptime (i) < clock ()
	then do;					/* Check validity */
		if statistics.uptime (i) > use_totals.time_last_boot
		then do;
			use_totals.uptime_since_boot = 0;
			use_totals.cpu_avail_since_boot = 0;
			use_totals.idle_since_boot = 0;
			use_totals.zidle_since_boot = 0;
			use_totals.mpidle_since_boot = 0;
			if use_totals.n_users_on > 0
			then use_totals.sys_crash = use_totals.sys_crash + 1;
			use_totals.sys_starts = use_totals.sys_starts + 1;
		     end;
		use_totals.time_last_boot = statistics.uptime (i);
		use_totals.time_last_sample = statistics.time (i);
		use_totals.last_sysid = statistics.sysid (i);
	     end;
	use_totals.n_users_on = statistics.users (i);
	meter_time = addrel (tcmp, TCMlast_time_loc) -> double - addrel (tcmp, TCMinitialize_time_loc) -> double;
	use_totals.uptime = use_totals.uptime + (meter_time - use_totals.uptime_since_boot);
	use_totals.uptime_since_boot = meter_time;
	cpu_time = addrel (tcmp, TCMprocessor_time_loc) -> double;
	use_totals.cpu_avail = use_totals.cpu_avail + (cpu_time - use_totals.cpu_avail_since_boot);
	use_totals.cpu_avail_since_boot = cpu_time;
	time = addrel (tcmp, TCMidle_loc) -> double;
	use_totals.idle = use_totals.idle + (time - use_totals.idle_since_boot);
	use_totals.idle_since_boot = time;
	time = addrel (tcmp, TCMzero_idle_loc) -> double;
	use_totals.zidle = use_totals.zidle + (time - use_totals.zidle_since_boot);
	use_totals.zidle_since_boot = time;
	time = addrel (tcmp, TCMmp_idle_loc) -> double;
	use_totals.mpidle = use_totals.mpidle + (time - use_totals.mpidle_since_boot);
	use_totals.mpidle_since_boot = time;
	if statistics.time (i) < clock ()
	then do;					/* Don't die if oprs set clock wrong. */
		call datebin_ (statistics.time (i), absda, mm, dd, yy, hh, min, ss, wkd, shf);
		qtr = hh * 4 + divide (min, 15, 17, 0) + 1;
		if use_totals.origin = 0
		then do;
			call datebin_$revert (mm, dd, yy, 0, 0, 0, use_totals.origin);
			dayx = 1;
		     end;
		else do;
			qtr = divide (statistics.time (i) - use_totals.origin, 900000000, 35, 0);
			dayx = divide (qtr, 96, 35, 0) + 1;
			qtr = mod (qtr, 96) + 1;
		     end;

		if dayx > hbound (use_totals.daylog, 1)
		then do;
			call com_err_ (0, ME,
			     "Billing cycle is greater than maximum ^d. No more usage statistics can be recorded.",
			     hbound (use_totals.daylog, 1));
			go to ERROR;
		     end;

		use_totals.max_day_log = dayx;
		use_totals.max_qhour = qtr;
		use_totals.daylog (dayx).qh (qtr).time = statistics.time (i);
		use_totals.daylog (dayx).qh (qtr).sysid = statistics.sysid (i);
		use_totals.daylog (dayx).qh (qtr).cpu = statistics.ncpu (i);
		use_totals.daylog (dayx).qh (qtr).kmem = statistics.kmem (i);
		use_totals.daylog (dayx).qh (qtr).nunits = statistics.units (i);
		use_totals.daylog (dayx).qh (qtr).dump_number = cv_dec_check_ ((statistics.erfno (i)), ec);
		if ec ^= 0
		then use_totals.daylog (dayx).qh (qtr).dump_number = 0;
		use_totals.daylog (dayx).qh (qtr).starttime = statistics.uptime (i);
		use_totals.daylog (dayx).qh (qtr).crashtime = statistics.crashtime (i);
	     end;
	go to redoit;

exit:
	if fday = 0
	then fday = 1;
	if fqh = 0
	then fqh = 1;
	last_dump = 0;
	last_shutdown = "0"b;
	call check ("fday", fday, 1, hbound (use_totals.daylog, 1), 1);
	call check ("dayx", dayx, 1, hbound (use_totals.daylog, 1), hbound (use_totals.daylog, 1));
	do i = fday to dayx;
	     if i = fday
	     then qlo = fqh;
	     else qlo = 1;
	     if i = dayx
	     then qhi = qtr;
	     else qhi = 96;
	     call check ("qlo", qlo, 1, hbound (use_totals.daylog.qh, 2), 1);
	     call check ("qhi", qhi, 1, hbound (use_totals.daylog.qh, 2), hbound (use_totals.daylog.qh, 2));
	     do j = qlo to qhi;
		if use_totals.daylog (i).qh (j).time = 0
		then do;
			use_totals.daylog (i).qh (j).dump_number = last_dump;
			use_totals.daylog (i).qh (j).shutdown = last_shutdown;
		     end;
		else if use_totals.daylog (i).qh (j).nunits = 0
		then do;
			use_totals.daylog (i).qh (j).shutdown = "1"b;
			use_totals.daylog (i).qh (j).dump_number = 0;
		     end;
		else do;
			last_dump = use_totals.daylog (i).qh (j).dump_number;
			last_shutdown = use_totals.daylog (i).qh (j).shutdown;
		     end;
	     end;
	end;

/* Obtain the amount of disk available and left. */

	call disk_left_ (use_totals.disk_available, use_totals.disk_left);
ERROR:
	call clean_up;

error:
     proc (x);

dcl	x		char (*);

	call com_err_ (ec, ME, "cannot locate ^a", x);
	go to ERROR;

     end error;

check:
     proc (varn, var, lo, hi, dft);

dcl	varn		char (*);
dcl	(var, lo, hi, dft)	fixed bin;

	if var >= lo & var <= hi
	then return;
	call com_err_ (0, ME, "range err: ^a = ^d, not ^d-^d. set to ^d", varn, var, lo, hi, dft);
	var = dft;

     end check;

clean_up:
     procedure;

	if statp ^= null ()
	then call terminate_file_ (statp, (0), TERM_FILE_TERM, (0));
	if use_totals_ptr ^= null ()
	then call terminate_file_ (use_totals_ptr, (0), TERM_FILE_TERM, (0));
	return;
     end clean_up;

     end system_total;




		    terminals_overseer_.pl1         11/12/82  1412.9rew 11/12/82  1044.0       47745



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


/* format: style2*/
terminals_overseer_:
     proc;

/* Special login responder for "Terminals" */
/* Modified 750501 by PG to call logout properly, convert to iox_, and fix minor bugs */
/* Modified 810121 by Benson I. Margulies for a condition wall */

/* automatic */

	dcl     buf		 char (168) varying,
	        command		 char (8),
	        code		 fixed bin (35);


/* builtins */

	dcl     (addr, before, ltrim, rtrim)
				 builtin;

/* internal static */

	dcl     nll		 label int static;
	dcl     1 search_rules	 aligned internal static options (constant),
		2 number		 fixed bin initial (5),
		2 names		 (5) char (168)
				 initial ("initiated_segments", "referencing_dir", ">system_library_standard",
				 ">system_library_1", ">system_library_tools");

/* entries */

	dcl     com_err_		 entry options (variable),
	        hcs_$initiate_search_rules
				 entry (ptr, fixed bin (35)),
	        command_query_	 entry () options (variable),
	        cu_$ready_proc	 entry (),
	        change_wdir_	 entry (char (168), fixed bin (35)),
	        user_info_$homedir	 entry (char(*)),
	        default_error_handler_$wall entry,
	        (
	        cu_$set_command_processor,
	        cu_$get_command_processor,
	        cu_$get_cl_intermediary,
	        cu_$set_cl_intermediary
	        )			 entry (entry),
	        ioa_		 entry options (variable);

	dcl     repeat_line		 entry options (variable),
	        edm		 entry options (variable),
	        runoff		 entry options (variable),
	        print		 entry options (variable),
	        logout		 entry options (variable);

/* static stuff for test entry */

	declare saved_cl		 entry variable internal static;
	declare saved_cp		 entry variable internal static;
	declare escape_permitted	 bit (1) aligned internal static initial ("0"b);

	declare ME		 char (32) init ("terminals_overseer_") int static options (constant);
	declare quit		 condition;
	declare any_other		 condition;
	declare home_dir		 char (168);

%page;
%include query_info;
%include iox_entries;


	nll = restart;

	on any_other call default_error_handler_$wall;
	call user_info_$homedir (home_dir);
	call change_wdir_ (home_dir, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "Could not set working dir to ^a.", home_dir);
	     go to GIVE_UP;
	end;
	
						/* print reasonable error messages */
	on quit call t_quit;			/* and handle quit here */

	call cu_$get_command_processor (saved_cp);	/* save this information for the test entrypoint */
	call cu_$get_cl_intermediary (saved_cl);	/* so that developer can get process back */
	call cu_$set_command_processor (cmproc);	/* make us the command processor and get_to_cl */
	call cu_$set_cl_intermediary (cl_proc);

	call hcs_$initiate_search_rules (addr (search_rules), code);
						/* set search rules */
	if code ^= 0
	then do;
		call com_err_ (code, ME, "Cannot set search rules");
GIVE_UP:
		call logout ();
	     end;

	call iox_$control (iox_$user_io, "quit_enable", null (), (0));
						/* can't fail */

	call ioa_ ("Terminals subsystem");
	query_info.version = query_info_version_4;
	query_info.suppress_name_sw = "1"b;
	query_info.cp_escape_control = "10"b;		/* we are the command processor, so .. is silly */
	query_info.suppress_spacing = "1"b;

restart:
	call cu_$ready_proc;
restart1:
	buf = "";
	call command_query_ (addr (query_info), buf, ME, "");
						/* nothing to say, just read */
	if buf = ""
	then go to restart1;

	command = before (ltrim (rtrim (buf)), " ");	/* command query does most of the work */

	if command = "echo"
	then do;
rpt:
		call repeat_line;
	     end;

	else if command = "repeat"
	then go to rpt;
	else if command = "test"
	then do;
		call runoff ("test");
	     end;
	else if command = "edm"
	then do;
		call edm;
	     end;
	else if command = "help"
	then do;
		call print ("terminals.info");
	     end;

	else if command = "logout"
	then do;
		call ioa_ ("Thank you.^/^/");
		call logout;
	     end;

	else if command = "hold"
	then do;
		call ioa_ ("Thank you.^/^/");
		call logout ("-hold");
	     end;

	else if escape_permitted & command = "return"
	then do;
		call cu_$set_command_processor (saved_cp);
						/* restore the environment, tho search rules will be broke */
		call cu_$set_cl_intermediary (saved_cl);
		return;
	     end;

	else do;
		call ioa_ ("""^a"" is not a legal command.^/Type ""help"" for instructions", command);
	     end;

	go to restart;


cl_proc:
     entry;

	call ioa_ ("Automatic restart.^/");

t_quit:
     entry;

	go to nll;				/* nonlocal go to -> automatic storage of first invocation stays */

cmproc:
     entry;

	call ioa_ ("No external command processing.");
	go to nll;

test:
     entry;
	escape_permitted = "1"b;			/* save the poor developer some pain. This should be bound away */

     end terminals_overseer_;




		    up_ctr.pl1                      09/19/84  0911.6rew 09/18/84  0801.7       17046



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

up_ctr: proc;

/* print reqfile */

dcl (path, dn) char (168) aligned,
     en char (32) aligned,
    (i, nq, ec) fixed bin,
     qp ptr,
     total float bin init (0.0e0),
     cv_$mwvf ext entry (float bin) returns (char (15)),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     ioa_ entry options (variable),
     com_err_ entry options (variable),
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin),
     hcs_$terminate_noname entry (ptr, fixed bin);


dcl  null builtin;

%include reqfile;

/* ============================================== */

	path = "reqfile";
	call expand_path_ (addr (path), 7, addr (dn), addr (en), ec);
	call hcs_$initiate (dn, en, "", 0, 1, qp, ec);
	if qp = null then do;
er:	     call com_err_ (ec, "up_ctr", path);
	     return;
	end;

	nq = qp -> reqfile.nacts;

	do i = 1 to nq;
	     chg_tr (i) = chg_tr (i) + chg_mo (i);
	     total = total + chg_mo (i);
	     chg_mo (i) = 0;
	end;

	call ioa_ ("^a", cv_$mwvf (total));

	call hcs_$terminate_noname (qp, ec);

     end;




		    urf_manager_.pl1                12/05/84  1243.5r w 12/05/84  0857.1       42372



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

/* format: style2 */
urf_manager_:
     procedure ();

	return;					/* Not an Entry */

/* Data Base Manager for User Registration File */
/* Written by C. Hornig, July 1979 */
/* Modified 1984-08-10 by E. Swenson for Version 3 MSTBs. */

	declare (
	        Pid		 character (*),
	        (Urfep, Old_urfep)	 pointer,
	        Record		 fixed bin (35),
	        Urfdir		 character (*),
	        Code		 fixed bin (35)
	        )			 parameter;

%include urf_entry;

	declare (
	        error_table_$noentry,
	        error_table_$noalloc,
	        error_table_$inconsistent,
	        error_table_$action_not_performed
	        )			 fixed bin (35) external static;

	declare ms_table_mgr_$open	 entry (character (*), character (*), character (*), pointer, pointer,
				 fixed bin (35)),
	        ms_table_mgr_$close	 entry (pointer, fixed bin (35)),
	        ms_table_mgr_$abs_entry
				 entry (ptr, fixed bin (35), char (*), bit (1) aligned, ptr, fixed bin (35),
				 fixed bin (35)),
	        ms_table_mgr_$find_entry
				 entry (ptr, char (*), ptr, bit (1) aligned, fixed bin (35), fixed bin (35)),
	        ms_table_mgr_$delete_entry
				 entry (pointer, character (*), fixed bin (35)),
	        ms_table_mgr_$new_entry
				 entry (pointer, character (*), pointer, fixed bin (35)),
	        ms_table_mgr_$update_entry
				 entry (ptr, ptr, fixed bin (35));

	declare urfdir		 init (">user_dir_dir>SysAdmin>admin") character (168) internal static;
	declare (urf_tag, urfhp)	 pointer init (null ()) internal static;
	declare initialized		 bit init ("0"b) internal static;

	dcl     NO_WRITE		 bit (1) aligned internal static options (constant) initial ("0"b);

	declare code		 fixed bin (35),
	        pid		 character (32),
	        record		 fixed bin (35),
	        user_urfep		 pointer;

	declare cleanup		 condition;

/* * * * * * * * * * GET_ABS_ENTRY * * * * * * * * * */

get_abs_entry:
     entry (Record, Pid, Urfep, Code);

	user_urfep = Urfep;
	record = Record;
	call init;
	call ms_table_mgr_$abs_entry (urf_tag, record, pid, NO_WRITE, urfep, (0), code);
	Pid = pid;
	goto get_common;

/* * * * * * * * * * GET_ENTRY * * * * * * * * * */

get_entry:
     entry (Pid, Urfep, Code);

	user_urfep = Urfep;
	call init;
	call find;
get_common:
	if user_urfep ^= null ()
	then if urfep = null ()
	     then string (user_urfep -> urf_entry) = "";
	     else user_urfep -> urf_entry = urf_entry;

return_to_caller:
	Code = code;
	return;

/* * * * * * * * * * UPDATE_ENTRY * * * * * * * * * */

update_entry:
     entry (Pid, Old_urfep, Urfep, Code);

	user_urfep = Urfep;
	call init;
	call find;
	if unspec (Old_urfep -> urf_entry) ^= unspec (urf_entry)
	then do;
		code = error_table_$inconsistent;
		goto return_to_caller;
	     end;
	if user_urfep ^= null ()
	then do;
		urf_entry = user_urfep -> urf_entry;
		call ms_table_mgr_$update_entry (urf_tag, urfep, code);
	     end;
	goto return_to_caller;

/* * * * * * * * * * ADD_ENTRY * * * * * * * * * */

add_entry:
     entry (Pid, Urfep, Code);

	user_urfep = Urfep;
	call init;
	call ms_table_mgr_$new_entry (urf_tag, pid, urfep, code);
	if code ^= 0
	then goto return_to_caller;
	urf_entry = user_urfep -> urf_entry;
	call ms_table_mgr_$update_entry (urf_tag, urfep, code);
	goto return_to_caller;

/* * * * * * * * * * REMOVE_ENTRY * * * * * * * * * */

remove_entry:
     entry (Pid, Code);

	pid = Pid;
	call init;
	call ms_table_mgr_$delete_entry (urf_tag, pid, code);
	goto return_to_caller;

/* * * * * **  * * * TEST * * * * * * * ** */

test:
     entry (Urfdir);

	urfdir = Urfdir;
	if urf_tag ^= null ()
	then call ms_table_mgr_$close (urf_tag, code);
	urf_tag = null ();
	initialized = "0"b;
	return;

/* * * * * * * * * * FIND * * * * * * * * * */

find:
     procedure;
	call ms_table_mgr_$find_entry (urf_tag, pid, urfep, NO_WRITE, (0), code);
	if urfep = null ()
	then goto return_to_caller;
     end find;

/* * * * * * * * ** * INIT * * * * * * * * * */

init:
     procedure;
	Code, code = 0;
	pid = Pid;

	if ^initialized
	then do;
		call ms_table_mgr_$open (urfdir, "URF", "URF", urf_tag, urfhp, code);
		if code ^= 0
		then goto return_to_caller;

		initialized = "1"b;
	     end;
     end init;

     end urf_manager_;




		    usage_and_revenue.pl1           04/09/85  1438.3r w 04/08/85  1133.7      776871



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

/* format: style3 */

/* This command prints out a "Multics Usage and Revenue Report." */
/* Coded October 1975 by Jim Homan
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.
   Modified August 1981 by T. Casey to eliminate reference to master_proj in bin,
   -		and change all declarations of rs_number to eliminate "(9) unsigned unaligned".
   Modified 1984-08-31 BIM for V3 use_totals, usage message.
*/

usage_and_revenue:
     proc;
dcl	(
	xtotp,					/* pointer to old use_totals segment */
	cptr,					/* pointer to control file */
	gptr,					/* pointer to groups structure */
	arg_list_ptr
	)		ptr,			/* pointer to argument list for usage_and_revenue */
	null		builtin,
	(
	ngroups,					/* # of groups in report, # of elements in groups structure */
	clen,					/* # of groups in report, # of elements in groups structure */
	i,
	j
	)		fixed bin,
	rate_ix		fixed bin,
	ec		fixed bin (35),		/* error code */
	daily		bit (1),			/* Is this daily or monthly report? */
	OK		bit (1),			/* Is it OK to continue? */
	first_time	bit (1) init ("1"b),
	short_date	char (8),
	size		condition,
	sysprint		file output stream print;	/* All output goes to sysprint */
dcl	1 titles,					/* Titles for first page */
	  2 company	char (120),		/* Company name, double spaced */
	  2 dept		char (120),		/* department name, double spaced */
	  2 report_title	char (50),		/* ...usage and revenue report */
	  2 time_span	char (42),		/* For mm/dd/yy hhmm dddto mm/dd/yy hhmm ddd */
	  2 system	char (24);		/* Current System: xxx */


declare	max_rs_number	fixed bin;
declare	P_ptr		pointer;
dcl	1 P		(0:max_rs_number) based (P_ptr),
						/* all the prices for all rate structures */
	  2 rs_name	char (32),		/* name for this rate */
	  2 abs_cpu_rates	(1:4) float bin,		/* installation price for absentee cpu time ($/hr) */
	  2 abs_memory_rates
			(1:4) float bin,		/* installation price for absentee memory usage ($/Kmu) */
	  2 connect_rates	(0:7) float bin,		/* installation price for terminal connect time ($/hr) */
	  2 memory_rates	(0:7) float bin,		/* installation price for memory usage ($/Kmu) */
	  2 disk_rates	float bin,		/* installation price for disk storage ($/page-sec) */
	  2 cpu_rates	(0:7) float bin,		/* installation price for interactive cpu time ($/hr) */
	  2 lines_rates	(1:4) float bin,		/* installation price for line printer lines ($/K-lines) */
	  2 ioops_rates	(0:7) float bin,		/* installation price for I/O operations ($/K) */
	  2 reg_rates	float bin,		/* user registration charge ($/month) */
	  2 device_table	aligned,
	    3 ndevices	fixed bin,		/* number of devices used */
	    3 dvt		(16),
	      4 device_id	char (8),
	      4 device_rates
			(0:7) float bin;		/* $/hr */
dcl	shift_table	(336) fixed bin;		/* table of shift #'s for each half hour in week */
dcl	cu_$arg_list_ptr	entry (ptr);		/* multics subroutine */
dcl	com_err_		entry options (variable);
dcl	system_info_$rs_name
			entry (fixed bin, char (*), fixed bin (35));
dcl	system_info_$max_rs_number
			entry (fixed binary);
dcl	system_info_$shift_table
			entry ((336) fixed bin);

dcl	(addr, bin, divide, hbound, index, length, lineno, max, min, mod, multiply, onloc, pageno, reverse, sign,
	substr, sum, verify)
			builtin;

/* the groups structure is filled in by the procedures parse_control_file, initial, add_bins and conversions_and_sums. */

/* structure to hold everything that gets printed in the report */

dcl	1 groups		(ngroups) based (gptr),
	  2 bins		(301) fixed bin,		/* the usage bins specified in control file for this group */
	  2 groups	(9) fixed bin,		/* the other groups specified in control file for this group */
	  2 all_bins	(301) fixed bin,		/* all the usage bins which go into this group */
	  2 title		char (24),		/* the title for this group, as specified in control file */
	  2 title_line_1	char (12),		/* first part of the title */
	  2 title_line_2	char (12),		/* second part of the title */
	  2 projects	fixed bin,		/* number of projects included in this group */
	  2 users		fixed bin,		/* number of users included in this group */
	  2 devices$	float bin,		/* device charges */
	  2 misc_dollars	float bin,		/* miscellaneous charges */
	  2 disk,					/* disk statistics */
	    3 page_days	float bin,
	    3 page_days$	float bin,		/* charge for disk storage */
	    3 quota	fixed bin (35),		/* normal storage quota */
	    3 usage	fixed bin (35),		/* pages of normal storage */
	  2 interactive,				/* interactive usage statistics */
	    3 shifts	(0:7),
	      4 cpu	float bin,		/* cpu hours */
	      4 cpu_dollars float bin,		/* charge for cpu time */
	      4 memory	float bin,		/* memory units */
	      4 memory_dollars
			float bin,		/* charge for memory */
	      4 connect	float bin,		/* connect hours */
	      4 connect_dollars
			float bin,		/* charge for connect time */
	      4 ioops	float bin,		/* terminal io ops */
	      4 ioops_dollars
			float bin,		/* total charges for shift */
	      4 total_dollars
			float bin,		/* total charges for shift */
	      4 dollars_per_hour
			float bin,		/* average cost per connect hour */
	    3 total	like groups.interactive.shifts,
						/* total for all shifts */
	    3 sessions	fixed bin,		/* number of logins */
	    3 dollars_per_session
			float bin,		/* dollars per connect hour */
	    3 hours_per_session
			float bin,		/* average session length */
	  2 absentee,				/* absentee usage statistics */
	    3 queues	(4),
	      4 cpu	float bin,		/* cpu hours */
	      4 cpu_dollars float bin,		/* charge for cpu time */
	      4 memory	float bin,		/* memory units */
	      4 memory_dollars
			float bin,		/* charge for memory */
	      4 jobs	fixed bin,		/* number of absentee jobs */
	      4 total_dollars
			float bin,		/* total charges for queue */
	      4 dollars_per_job
			float bin,		/* average cost per absentee job */
	    3 total	like groups.absentee.queues,	/* dtotal for all queues */
	  2 iod,					/* IO Daemon statistics */
	    3 queues	(4),
	      4 lines	float bin,		/* number of lines printed */
	      4 lines_dollars
			float bin,		/* print charges */
	    3 total	like groups.iod.queues,	/* total for all queues */
	  2 total,				/* overall totals */
	    3 cpu		float bin,		/* cpu hours */
	    3 cpu_dollars	float bin,		/* charge for cpu time */
	    3 memory	float bin,		/* memory units */
	    3 memory_dollars
			float bin,		/* charge for memory use */
	    3 today_dollars float bin,		/* total charges today */
	    3 month_dollars float bin;		/* total charges for month */

declare	ME		char (32) init ("usage_and_revenue") int static options (constant);

declare	cleanup		condition;
%page;
%include access_mode_values;
%include terminate_file;
%page;
%include use_totals;


	use_totals_ptr, xtotp, gptr, P_ptr = null ();
	on cleanup
	     begin;
		call clean_up (use_totals_ptr, xtotp, gptr);
	     end;
	call system_info_$max_rs_number (max_rs_number);
	allocate P set (P_ptr);
	close file (sysprint);
	open file (sysprint) linesize (300) pagesize (66);/* open sysprint with a big linesize  and a pagesize
						   larger than any of the pages in the report */
	call cu_$arg_list_ptr (arg_list_ptr);		/* get pointer to argument list */
	call process_args (arg_list_ptr, use_totals_ptr, xtotp, daily, cptr, clen, OK);
	if ^OK
	then do;
		call clean_up (use_totals_ptr, xtotp, null);
		return;
	     end;
	call parse_control_file (cptr, clen, OK);
	if ^OK
	then do;
		call clean_up (use_totals_ptr, xtotp, gptr);
error:
		return;
	     end;
	call system_info_$shift_table (shift_table);
	do rate_ix = 0 to hbound (P, 1);		/* get all the prices */
	     call system_info_$rs_name (rate_ix, P (rate_ix).rs_name, ec);
	     if ec ^= 0
	     then do;
		     P (rate_ix) = P (0);		/* assumes default will not cause an error */
		     P (rate_ix).rs_name = "";
		end;
	     else call get_prices (rate_ix, P (rate_ix));
	end;
	call make_titles (daily, titles, short_date);
	do i = 1 to ngroups;
	     call initial (i);
	     do j = 1 to hbound (groups.all_bins, 2) while (groups (i).all_bins (j) ^= 0);
		call add_bins (i, groups (i).all_bins (j), daily,
		     P (use_totals.ut (groups (i).all_bins (j)).rs_number));
	     end;
	end;
	call conversions_and_sums;
	on size
	     begin;				/* Handle size condition on output as gracefully as possible */
		call clean_up (use_totals_ptr, xtotp, gptr);
		call com_err_ (0, ME, "Number too big for output format. Error occurred in routine ^a.", onloc ());
		go to error;
	     end;
	call revenue_summary (daily, titles);
	call interactive_summary (short_date);
	call absentee_summary (short_date);
	call iod_summary (short_date);
	call system_stats (daily, short_date);
	call disk_stats ();
	if daily
	then call times_available ();
	if ^daily
	then call group_composition (short_date);
	if ^daily
	then do rate_ix = 0 to hbound (P, 1);
		if P (rate_ix).rs_name ^= ""
		then call rates_and_shifts (P (rate_ix), shift_table, short_date);
	     end;

	call footnote (short_date);
	revert size;
	call clean_up (use_totals_ptr, xtotp, gptr);

process_args:
     proc (ap, use_totals_ptr, xtotp, daily, cptr, clen, OK);

/* This procedure processes the arguments to usage_and_revenue.
   Parameters:
   ap - input - Pointer to usage_and_revenue argument list.
   use_totals_ptr - output - Pointer to current use_totals segment.
   xtotp - output - Pointer to old use_totals segment.
   daily - output -"1"b if daily report, "0"b if monthly report.
   cptr - output - Pointer to control file.
   clen - output - Length of control file (number of characters).
   OK - output - "1"b if everything ok, "0"b if error was detected and com_err_ called. */

dcl	(use_totals_ptr, xtotp, cptr, ap)
			ptr,
	count		fixed bin (24),
	clen		fixed bin,
	(daily, OK)	bit (1),
	dn		char (168),
	en		char (32),
	ec		fixed bin (35),		/* error code returned from multics subroutines */
	argptr		ptr,			/* ptr to usage_and_revenue argument */
	arglen		fixed bin (21),		/* length of usage_and_revenue argument */
	arg		char (arglen) based (argptr), /* usage_and_revenue argument */
	null		builtin;
dcl	arg_count		fixed bin;
dcl	error_table_$unimplemented_version
			external fixed bin (35);
dcl	com_err_		entry options (variable),
	cu_$arg_ptr_rel	entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl	cu_$arg_count_rel	entry (fixed bin, ptr, fixed bin (35));
dcl	com_err_$suppress_name
			entry () options (variable);

	call cu_$arg_count_rel (arg_count, ap, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME);
		OK = "0"b;
		return;
	     end;
	if arg_count < 2
	then do;
		call com_err_$suppress_name (0, ME,
		     "Usage: usage_and_revenue Control_File Current_Use_Totals.use_totals {Previous_Use_Totals.use_totals}"
		     );
		OK = "0"b;
		return;
	     end;

	OK = "1"b;
	call get_seg_from_arg (1, ap, "control", cptr, count, dn, en, OK);
	if ^OK
	then return;
	clen = divide (count, 9, 17, 0);
	call get_seg_from_arg (2, ap, "use_totals", use_totals_ptr, count, dn, en, OK);
	if ^OK
	then return;
	if use_totals.version ^= USE_TOTALS_VERSION_3
	then do;
bad_version:
		call com_err_ (error_table_$unimplemented_version, ME, "For seg ^a>^a.
Use convert_MR10_2_use_totals to convert to version 3.", dn, en);
		OK = "0"b;
		return;
	     end;
	call cu_$arg_ptr_rel (3, argptr, arglen, ec, ap);
	if ec = 0
	then do;
		call get_seg_from_arg (3, ap, "use_totals", xtotp, count, dn, en, OK);
		if ^OK
		then return;
		if xtotp -> use_totals.version ^= USE_TOTALS_VERSION_3
		then goto bad_version;
	     end;
	if xtotp = null
	then daily = "0"b;
	else daily = "1"b;


get_seg_from_arg:
     proc (argno, ap, suffix, p, count, dn, en, OK);

/* This procedure gets the pathname of a segment from an argument list and
   returns a pointer to the segment and its bit count.
   Parameters:
   argno  - input - The number of the argument to be used as pathname
   ap - input - Pointer to the argument list.
   suffix - input - required suffix on segment.
   count - output - Bit count of the segment.
   p - output - Pointer to the segment.
   OK - output - "0"b if error was detected and com_err_ called. "1"b if everything was ok. */

dcl	argno		fixed bin,
	count		fixed bin (24),
	OK		bit (1),
	(ap, p)		ptr,
	ec		fixed bin (35),		/* error code returned from multics subroutines */
	argptr		ptr,			/* ptr to usage_and_revenue argument */
	arglen		fixed bin (21),		/* length of usage_and_revenue argument */
	arg		char (arglen) based (argptr), /* usage_and_revenue argument */
	dn		char (*),			/* directory name */
	en		char (*),			/* entry name */
	null		builtin;
dcl	suffix		char (*);

dcl	cu_$arg_ptr_rel	entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl	expand_pathname_$add_suffix
			entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl	initiate_file_	entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35))
			;
dcl	com_err_		entry options (variable);
	OK = "1"b;
	call cu_$arg_ptr_rel (argno, argptr, arglen, ec, ap);
						/* get the argument */
	if ec ^= 0
	then do;
		call com_err_ (ec, ME);		/* couldn't find the argument */
		OK = "0"b;
		return;
	     end;
	call expand_pathname_$add_suffix (arg, suffix, dn, en, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a", arg);
		OK = "0"b;
		return;
	     end;
	call initiate_file_ (dn, en, R_ACCESS, p, count, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a>^a", dn, en);
		OK = "0"b;
		return;
	     end;
     end get_seg_from_arg;
     end process_args;

get_prices:
     proc (rs_number, P);

/* This procedure calls the different system_info_ entry points to get all the system rate
   and shift info.
   Parameters:
   are all input parameters */

dcl	rs_number		fixed bin;		/* rate structure to use */
dcl	1 P,
	  2 rs_name	char (32),		/* name for this rate */
	  2 abs_cpu_rates	(1:4) float bin,		/* installation price for absentee cpu time ($/hr) */
	  2 abs_memory_rates
			(1:4) float bin,		/* installation price for absentee memory usage ($/Kmu) */
	  2 connect_rates	(0:7) float bin,		/* installation price for terminal connect time ($/hr) */
	  2 memory_rates	(0:7) float bin,		/* installation price for memory usage ($/Kmu) */
	  2 disk_rates	float bin,		/* installation price for disk storage ($/page-sec) */
	  2 cpu_rates	(0:7) float bin,		/* installation price for interactive cpu time ($/hr) */
	  2 lines_rates	(1:4) float bin,		/* installation price for line printer lines ($/K-lines) */
	  2 ioops_rates	(0:7) float bin,		/* installation price for I/O operations ($/K) */
	  2 reg_rates	float bin,		/* user registration charge ($/month) */
	  2 device_table	aligned,
	    3 ndevices	fixed bin,		/* number of devices used */
	    3 dvt		(16),
	      4 device_id	char (8),
	      4 device_rates
			(0:7) float bin;		/* $/hr */

dcl	system_info_$prices_rs
			entry (fixed bin, (0:7) float bin, (0:7) float bin, (0:7) float bin, (0:7) float bin,
			float bin, float bin),	/* Gets interactive installation prices */
	system_info_$io_prices_rs
			entry (fixed bin, (4) float bin),
						/* gets daemon installation prices */
	system_info_$abs_prices_rs
			entry (fixed bin, (4) float bin, (4) float bin),
						/* gets absentee installation prices */
	system_info_$device_prices_rs
			entry (fixed bin, fixed bin, ptr);

	call system_info_$prices_rs (rs_number, P.cpu_rates, P.connect_rates, P.ioops_rates, P.memory_rates,
	     P.disk_rates, P.reg_rates);
	call system_info_$abs_prices_rs (rs_number, P.abs_cpu_rates, P.abs_memory_rates);
	call system_info_$io_prices_rs (rs_number, P.lines_rates);
	call system_info_$device_prices_rs (rs_number, P.device_table.ndevices, addr (P.device_table.dvt (1)));
     end get_prices;

parse_control_file:
     proc (cptr, clen, OK);

/* This procedure reads through the control file, determines the number of
   groups (=ngroups), allocates the groups structure  and for each element in the groups structure it fills in
   bins,groups,all_bins,title,title_line_1 and title_line_2.
   Parameters:
   cptr - input - pointer to the control file segment
   clen - input - length of the control file segment
   OK - output - "0"b if error has been detected and com_err_ called.  "1"b if everything ok */

dcl	(i, j, k, m, n)	fixed bin,
	clen		fixed bin,
	cptr		ptr,
	OK		bit (1),
	all_done		bit (1),
	ec		fixed bin (35);
dcl	com_err_		entry options (variable);
dcl	get_temp_segment_	entry (character (*), pointer, fixed binary (35));

dcl	bin		bit (1);
dcl	(start1, start2)	fixed bin;
dcl	(end_of_line, end_of_file)
			bit (1);
dcl	control		char (clen) based (cptr);
dcl	line		char (400) var,
	title		char (24);
dcl	1 more_groups	(9),
	  2 all_processed	bit (1) init ((9) (1)"0"b),
	  2 group_titles	(9) char (24) aligned init ((81) (1)""),
	  2 group_numbers	(9) fixed bin init ((81) 0),
	  2 nbins		fixed bin,
	  2 ng		fixed bin,
	  2 nall_bins	fixed bin;
	call get_temp_segment_ (ME, gptr, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME);
		OK = "0"b;
		return;
	     end;
	start1 = 1;
	call get_line (control, start1, line, end_of_file);
	if end_of_file
	then do;
		call com_err_ (0, ME, "No valid lines in control file");
		OK = "0"b;
		return;
	     end;
	ngroups = 0;
	do while (^end_of_file);
	     ngroups = ngroups + 1;
	     if ngroups > 9
	     then do;
		     call com_err_ (0, ME, "More than 9 groups specified in control file.");
		     OK = "0"b;
		     return;
		end;
	     groups (ngroups).bins (*) = 0;
	     start2 = 1;
	     call get_group_title (line, start2, title, end_of_line);
	     if end_of_line
	     then do;
		     call com_err_ (0, ME, "^a:^a", "Bad line in control file", line);
		     OK = "0"b;
		     return;
		end;
	     groups (ngroups).title = title;
	     call split_title (groups (ngroups).title, groups (ngroups).title_line_1, groups (ngroups).title_line_2);
	     call get_bin_title (line, start2, title, bin, end_of_line);
	     if end_of_line
	     then do;
		     call com_err_ (0, ME, "^a:^a", "Bad line in control file", line);
		     OK = "0"b;
		     return;
		end;
	     do while (^end_of_line);
		if bin
		then do;
			i = 1;
			do while (use_totals.ut (i).utype ^= title & i <= use_totals.ntypes);
			     i = i + 1;
			end;
			if i > use_totals.ntypes
			then do;
				call com_err_ (0, ME, "Line contains an invalid bin name: ^a", line);
				OK = "0"b;
				return;
			     end;
			else do;
				j = 1;
				do while (groups (ngroups).bins (j) ^= 0 & j <= hbound (groups.bins, 2));
				     j = j + 1;
				end;
				if j > hbound (groups.bins, 2)
				then do;
					call com_err_ (0, ME,
					     "Too many bins specified in control file line: ^a", line);
					OK = "0"b;
					return;
				     end;
				else groups (ngroups).bins (j) = i;
			     end;
		     end;
		else do;
			i = 1;
			do while (more_groups (ngroups).group_titles (i) ^= "" & i <= 9);
			     i = i + 1;
			end;
			if i > 9
			then do;
				call com_err_ (0, ME, "Too many groups specified in control file line: ^a", line);
				OK = "0"b;
				return;
			     end;
			else more_groups (ngroups).group_titles (i) = title;
		     end;
		call get_bin_title (line, start2, title, bin, end_of_line);
	     end;
	     call get_line (control, start1, line, end_of_file);
	end;
	groups (*).all_bins (*) = 0;
	groups (*).groups (*) = 0;
	do i = 1 to ngroups;
	     groups (i).all_bins (*) = groups (i).bins (*);
	     j = 1;
	     do while (groups (i).all_bins (j) > 0);
		j = j + 1;
	     end;
	     more_groups (i).nbins, more_groups (i).nall_bins = j - 1;
	     do j = 1 to 9 while (more_groups (i).group_titles (j) ^= "");
		k = 1;
		do while (more_groups (i).group_titles (j) ^= groups (k).title & k <= ngroups);
		     k = k + 1;
		end;
		if k > ngroups
		then do;
			call com_err_ (0, ME,
			     "Reference to group ""^a"" in control file, but no group by that title exists",
			     more_groups (i).group_titles (j));
			OK = "0"b;
			return;
		     end;
		else do;
			more_groups (i).group_numbers (j) = k;
			groups (i).groups (j) = k;
		     end;
	     end;
	     more_groups (i).ng = j - 1;
	     if more_groups (i).ng = 0
	     then more_groups (i).all_processed = "1"b;
	end;
	all_done = "0"b;
	do i = 1 to 9 while (^all_done);
	     all_done = "1"b;
	     do j = 1 to ngroups;
		if ^more_groups (j).all_processed
		then do k = 1 to 9;
			n = more_groups (j).group_numbers (k);
			if n > 0
			then if more_groups (n).all_processed
			     then do;
				     if more_groups (n).nall_bins + more_groups (j).nall_bins
					> hbound (groups.bins, 2)
				     then do;
					     call com_err_ (0, ME, "Too many bins specified for group ^a",
						groups (j).title);
					     OK = "0"b;
					     return;
					end;
				     do m = 1 to more_groups (n).nall_bins;
					groups (j).all_bins (m + more_groups (j).nall_bins) =
					     groups (n).all_bins (m);
				     end;
				     more_groups (j).nall_bins =
					more_groups (j).nall_bins + more_groups (n).nall_bins;
				     more_groups (j).group_numbers (k) = 0;
				end;
			     else all_done = "0"b;
		     end;
		if sum (more_groups (j).group_numbers (*)) = 0
		then more_groups (j).all_processed = "1"b;
	     end;
	end;
	if ^all_done
	then do;
		call com_err_ (0, ME, "There is a circular reference to groups in the control file.");
		OK = "0"b;
		return;
	     end;
split_title:
     proc (title, line1, line2);

/* This procedure takes a group title and breaks it into 2 lines
   Parameters:
   title - input - group title
   line1,line2 - output - the 2 shorter lines */

dcl	title		char (24),
	(line1, line2)	char (12),
	t		char (24) var,
	(i, j, m, l1, s2, l2, m1, m2)
			fixed bin;

	line1, line2 = "";
	t = substr (title, 1, min (length (title), length (title) - verify (reverse (title), " ") + 1));
	m = length (t) / 2;
	i = index (reverse (substr (t, 1, m)), " ");
	j = index (substr (t, m + 1), " ");
	if i = 0 & j = 0
	then do;
		if length (t) < 12
		then substr (line2, 13 - length (t)) = t;
		else do;
			line1 = substr (t, 1, 12);
			line2 = substr (t, 13);
		     end;
	     end;
	else if (i > 0 & j = 0) | (i > 0 & j > 0 & i < j)
	then do;
		l1 = m - i;
		s2 = l1 + 2;
		l2 = length (t) - l1 - 1;
		m2 = max (1, 12 - l2 + 1);
		m1 = m2 + (l2 - l1 + 1) / 2;
		substr (line1, m1) = substr (t, 1, l1);
		substr (line2, m2) = substr (t, s2);
	     end;
	else if (j > 0 & i = 0) | (j > 0 & i > 0 & j < i)
	then do;
		l1 = m + j - 1;
		s2 = l1 + 2;
		l2 = length (t) - l1 - 1;
		m1 = max (1, 12 - l1 + 1);
		m2 = m1 + (l1 - l2 + 1) / 2;
		substr (line1, m1) = substr (t, 1, l1);
		substr (line2, m2) = substr (t, s2);
	     end;
     end split_title;
get_line:
     proc (c, s, l, eof);

/* This procedure gets the next line from the control file.
   Parameters:
   c - input - the control file
   s - input,output - the current position in the control file
   l - output - the next line
   eof - output - "1"b if there are no more lines in file */

dcl	c		char (*),
	l		char (*) var,
	(s, i)		fixed bin,
	eof		bit (1),
	NL		char (1) init ("
");

	if s > length (c)
	then eof = "1"b;
	else do;
		i = index (substr (c, s), NL);
		if i = 0
		then eof = "1"b;
		else do;
			i = i + s;
			l = substr (c, s, i - s - 1);
			s = i;
			eof = "0"b;
			if substr (l, 1, 1) = "*"
			then /* ignore comment lines */
			     call get_line (c, s, l, end_of_file);
		     end;
	     end;
     end get_line;
get_group_title:
     proc (l, s, t, eol);

/* This procedure extracts the group title from the beginning of a control fileline.
   Parameters:
   l - input - the control file line
   s - input,output - the current position within the line
   t - output - the group title
   eol - output - "1"b if there is no group title  in line */

dcl	l		char (*) var,
	t		char (*),
	eol		bit (1),
	(s, i)		fixed bin;

	i = index (substr (l, s), ":");
	if i = 0
	then eol = "1"b;
	else do;
		t = substr (l, s, i - s);
		eol = "0"b;
		s = i + 1;
	     end;
     end get_group_title;
get_bin_title:
     proc (l, s, t, b, eol);

/* This procedure extracts bin or group titles from a control file line.
   Parameters:
   l - input - the control file line
   s - input,output - the current position within the line
   t - output - the next bin or group title
   b - output - "1"b if bin title, "0"b if group title
   eol - output - "1"b if there are no more titles in the line */

dcl	l		char (*) var,
	t		char (*),
	(s, i)		fixed bin,
	eol		bit (1),
	b		bit (1);

	if s > length (l)
	then do;
		eol = "1"b;
		return;
	     end;
	eol = "0"b;
	i = index (substr (l, s), ",");
	if i = 0
	then i = length (l) + 2;
	else i = i + s;
	if substr (l, s, 1) = """" & substr (l, i - 2, 1) = """"
	then do;
		t = substr (l, s + 1, i - s - 3);
		b = "0"b;
	     end;
	else do;
		t = substr (l, s, i - s - 1);
		b = "1"b;
	     end;
	s = i;
     end get_bin_title;
     end parse_control_file;

make_titles:
     proc (daily, titles, short_date);

/* This procedure sets up the titles for the report.
   Parameters:
   daily - input - "1"b if daily report, "0"b if monthly report
   titles - output - the titles for the report
   short_date - output - date to be printed in top left corner of pages */

dcl	daily		bit (1);
dcl	1 titles,					/* Titles for 1st and last pages */
	  2 company	char (120),		/* Company name, double spaced */
	  2 dept		char (120),		/* department name, double spaced */
	  2 report_title	char (50),		/* ...usage and revenue report */
	  2 time_span	char (42),		/* For mm/dd/yy hhmm dddto mm/dd/yy hhmm ddd */
	  2 system	char (24);		/* Current System: xxx */
dcl	short_date	char (8);
dcl	dummy		char (1);
dcl	system_info_$titles entry (char (*), char (*), char (*), char (*));
	call system_info_$titles (dummy, dummy, titles.company, titles.dept);
	if daily
	then titles.report_title = "Multics Usage and Revenue Report";
	else titles.report_title = "**** Monthly Multics Usage and Revenue Report ****";
	if daily
	then titles.time_span =
		"For " || format_time (xtotp -> use_totals.period_end) || " to "
		|| format_time (use_totals.period_end);
	else titles.time_span =
		"For " || format_time (use_totals.period_begin) || " to " || format_time (use_totals.period_end);
	short_date = substr (format_time (use_totals.period_end), 1, 8);
	titles.system = "Current System: " || use_totals.last_sysid;
     end make_titles;

initial:
     proc (n);

/* This procedure zeroes out the data in one element of the groups structure.
   Parameters:
   n - input - the element to be zeroed out */

dcl	n		fixed bin;

	groups (n).devices$ = 0;
	groups (n).misc_dollars = 0;
	groups (n).disk = 0;
	groups (n).interactive = 0;
	groups (n).absentee = 0;
	groups (n).iod = 0;
	groups (n).total = 0;
     end initial;

add_bins:
     proc (out, in, daily, P);

/* This procedure takes data from one bin of use_totals and adds it to one element of groups
   plus calculates the charges for those items that use the "get_prices" charges.
   Parameters:
   out -input - the element of groups to to the data
   in - input - the bin from which data comes
   daily - input - is this daily or monthly report?
   P - input - is the prices for the rate to be used for bin "in"
*/

dcl	(out, in)		fixed bin,
	daily		bit (1);
dcl	1 P,					/* all the prices for one rate structure */
	  2 rs_name	char (32),		/* name for this rate */
	  2 abs_cpu_rates	(1:4) float bin,		/* installation price for absentee cpu time ($/hr) */
	  2 abs_memory_rates
			(1:4) float bin,		/* installation price for absentee memory usage ($/Kmu) */
	  2 connect_rates	(0:7) float bin,		/* installation price for terminal connect time ($/hr) */
	  2 memory_rates	(0:7) float bin,		/* installation price for memory usage ($/Kmu) */
	  2 disk_rates	float bin,		/* installation price for disk storage ($/page-sec) */
	  2 cpu_rates	(0:7) float bin,		/* installation price for interactive cpu time ($/hr) */
	  2 lines_rates	(1:4) float bin,		/* installation price for line printer lines ($/K-lines) */
	  2 ioops_rates	(0:7) float bin,		/* installation price for I/O operations ($/K) */
	  2 reg_rates	float bin,		/* user registration charge ($/month) */
	  2 device_table	aligned,
	    3 ndevices	fixed bin,		/* number of devices used */
	    3 dvt		(16),
	      4 device_id	char (8),
	      4 device_rates
			(0:7) float bin;		/* $/hr */

/* add the data from current use_totals */
	groups (out).projects = groups (out).projects + use_totals.ut (in).nproj;
	groups (out).users = groups (out).users + use_totals.ut (in).nusers;
	groups (out).devices$ = groups (out).devices$ + sum (use_totals.ut (in).devices (*));
	groups (out).misc_dollars = groups (out).misc_dollars + use_totals.ut (in).misc;
	groups (out).disk.page_days = groups (out).disk.page_days + use_totals.ut (in).disk_psec;
	groups (out).disk.page_days$ = groups (out).disk.page_days$ + P.disk_rates * use_totals.ut (in).disk_psec;
	groups (out).disk.quota = groups (out).disk.quota + use_totals.ut (in).disk_quota;
	groups (out).disk.usage = groups (out).disk.usage + use_totals.ut (in).disk_usage;
	groups (out).interactive.shifts (*).cpu =
	     groups (out).interactive.shifts (*).cpu + use_totals.ut (in).interactive (*).cpu;
	groups (out).interactive.shifts (*).cpu_dollars =
	     groups (out).interactive.shifts (*).cpu_dollars
	     + P.cpu_rates (*) * use_totals.ut (in).interactive (*).cpu / 3.6e9;
	groups (out).interactive.shifts (*).memory =
	     groups (out).interactive.shifts (*).memory + use_totals.ut (in).interactive (*).core;
	groups (out).interactive.shifts (*).memory_dollars =
	     groups (out).interactive.shifts (*).memory_dollars
	     + P.memory_rates (*) * use_totals.ut (in).interactive (*).core / 1e6;
	groups (out).interactive.shifts (*).connect =
	     groups (out).interactive.shifts (*).connect + use_totals.ut (in).interactive (*).connect;
	groups (out).interactive.shifts (*).ioops =
	     groups (out).interactive.shifts (*).ioops + use_totals.ut (in).interactive (*).io_ops;
	groups (out).interactive.shifts (*).ioops_dollars =
	     groups (out).interactive.shifts (*).ioops_dollars
	     + P.ioops_rates (*) * use_totals.ut (in).interactive (*).io_ops;
	groups (out).interactive.shifts (*).total_dollars =
	     groups (out).interactive.shifts (*).total_dollars + use_totals.ut (in).interactive (*).charge;
	groups (out).interactive.sessions = groups (out).interactive.sessions + use_totals.ut (in).logins;
	groups (out).absentee.queues (*).cpu =
	     groups (out).absentee.queues (*).cpu + use_totals.ut (in).absentee (*).cpu;
	groups (out).absentee.queues (*).cpu_dollars =
	     groups (out).absentee.queues (*).cpu_dollars
	     + P.abs_cpu_rates (*) * use_totals.ut (in).absentee (*).cpu / 3.6e9;
	groups (out).absentee.queues (*).memory =
	     groups (out).absentee.queues (*).memory + use_totals.ut (in).absentee (*).memory;
	groups (out).absentee.queues (*).memory_dollars =
	     groups (out).absentee.queues (*).memory_dollars
	     + P.abs_memory_rates (*) * use_totals.ut (in).absentee (*).memory / 1e6;
	groups (out).absentee.queues (*).jobs =
	     groups (out).absentee.queues (*).jobs + use_totals.ut (in).absentee (*).jobs;
	groups (out).absentee.queues (*).total_dollars =
	     groups (out).absentee.queues (*).total_dollars + use_totals.ut (in).absentee (*).charge;
	groups (out).iod.queues (*).lines = groups (out).iod.queues (*).lines + use_totals.ut (in).iod (*).lines;
	groups (out).iod.queues (*).lines_dollars =
	     groups (out).iod.queues (*).lines_dollars + P.lines_rates (*) * use_totals.ut (in).iod (*).lines / 1e3;
	groups (out).total.today_dollars =
	     groups (out).total.today_dollars + use_totals.ut (in).dollar_charge + use_totals.ut (in).misc;
	groups (out).total.month_dollars =
	     groups (out).total.month_dollars + use_totals.ut (in).dollar_charge + use_totals.ut (in).misc;

/* for daily report, subtract off data from old use_totals */
	if daily
	then do;
		groups (out).devices$ = groups (out).devices$ - sum (xtotp -> use_totals.ut (in).devices (*));
		groups (out).misc_dollars = groups (out).misc_dollars - xtotp -> use_totals.ut (in).misc;
		groups (out).disk.page_days = groups (out).disk.page_days - xtotp -> use_totals.ut (in).disk_psec;
		groups (out).disk.page_days$ =
		     groups (out).disk.page_days$ - P.disk_rates * xtotp -> use_totals.ut (in).disk_psec;
		groups (out).interactive.shifts (*).cpu =
		     groups (out).interactive.shifts (*).cpu - xtotp -> use_totals.ut (in).interactive (*).cpu;
		groups (out).interactive.shifts (*).cpu_dollars =
		     groups (out).interactive.shifts (*).cpu_dollars
		     - P.cpu_rates (*) * xtotp -> use_totals.ut (in).interactive (*).cpu / 3.6e9;
		groups (out).interactive.shifts (*).memory =
		     groups (out).interactive.shifts (*).memory - xtotp -> use_totals.ut (in).interactive (*).core;
		groups (out).interactive.shifts (*).memory_dollars =
		     groups (out).interactive.shifts (*).memory_dollars
		     - P.memory_rates (*) * xtotp -> use_totals.ut (in).interactive (*).core / 1e6;
		groups (out).interactive.shifts (*).connect =
		     groups (out).interactive.shifts (*).connect
		     - xtotp -> use_totals.ut (in).interactive (*).connect;
		groups (out).interactive.shifts (*).ioops =
		     groups (out).interactive.shifts (*).ioops - xtotp -> use_totals.ut (in).interactive (*).io_ops;
		groups (out).interactive.shifts (*).ioops_dollars =
		     groups (out).interactive.shifts (*).ioops_dollars
		     - P.ioops_rates (*) * xtotp -> use_totals.ut (in).interactive (*).io_ops;
		groups (out).interactive.shifts (*).total_dollars =
		     groups (out).interactive.shifts (*).total_dollars
		     - xtotp -> use_totals.ut (in).interactive (*).charge;
		groups (out).interactive.sessions =
		     groups (out).interactive.sessions - xtotp -> use_totals.ut (in).logins;
		groups (out).absentee.queues (*).cpu =
		     groups (out).absentee.queues (*).cpu - xtotp -> use_totals.ut (in).absentee (*).cpu;
		groups (out).absentee.queues (*).cpu_dollars =
		     groups (out).absentee.queues (*).cpu_dollars
		     - P.abs_cpu_rates (*) * xtotp -> use_totals.ut (in).absentee (*).cpu / 3.6e9;
		groups (out).absentee.queues (*).memory =
		     groups (out).absentee.queues (*).memory - xtotp -> use_totals.ut (in).absentee (*).memory;
		groups (out).absentee.queues (*).memory_dollars =
		     groups (out).absentee.queues (*).memory_dollars
		     - P.abs_memory_rates (*) * xtotp -> use_totals.ut (in).absentee (*).memory / 1e6;
		groups (out).absentee.queues (*).jobs =
		     groups (out).absentee.queues (*).jobs - xtotp -> use_totals.ut (in).absentee (*).jobs;
		groups (out).absentee.queues (*).total_dollars =
		     groups (out).absentee.queues (*).total_dollars - xtotp -> use_totals.ut (in).absentee (*).charge;
		groups (out).iod.queues (*).lines =
		     groups (out).iod.queues (*).lines - xtotp -> use_totals.ut (in).iod (*).lines;
		groups (out).iod.queues (*).lines_dollars =
		     groups (out).iod.queues (*).lines_dollars
		     - P.lines_rates (*) * xtotp -> use_totals.ut (in).iod (*).lines / 1e3;
		groups (out).total.today_dollars =
		     groups (out).total.today_dollars - xtotp -> use_totals.ut (in).dollar_charge
		     - xtotp -> use_totals.ut (in).misc;
	     end;
     end add_bins;

conversions_and_sums:
     proc;

/* This procedure adds up totals, makes units conversions, calculates the breakdown of charges,
   calculates some averages, and "rounds" everything for printing.
   Parameters:
   all parameters are input */

dcl	(i, j)		fixed bin;

/* first get the totals for all shifts, all queues, etc. */
	do i = 1 to ngroups;
	     groups (i).interactive.total.cpu = sum (groups (i).interactive.shifts (*).cpu);
	     groups (i).interactive.total.memory = sum (groups (i).interactive.shifts (*).memory);
	     groups (i).interactive.total.connect = sum (groups (i).interactive.shifts (*).connect);
	     groups (i).interactive.total.ioops = sum (groups (i).interactive.shifts (*).ioops);
	     groups (i).interactive.total.total_dollars = sum (groups (i).interactive.shifts (*).total_dollars);
	     groups (i).absentee.total.cpu = sum (groups (i).absentee.queues (*).cpu);
	     groups (i).absentee.total.memory = sum (groups (i).absentee.queues (*).memory);
	     groups (i).absentee.total.jobs = sum (groups (i).absentee.queues (*).jobs);
	     groups (i).absentee.total.total_dollars = sum (groups (i).absentee.queues (*).total_dollars);
	     groups (i).iod.total.lines = sum (groups (i).iod.queues (*).lines);
	end;

/* now make units conversions.  Convert cpu and connect time from microseconds to hours,
   memory from milli-mu to kmu, and page-seconds to page-days */
	groups (*).disk.page_days = groups (*).disk.page_days / (60 * 60 * 24);
	groups (*).interactive.shifts (*).cpu = groups (*).interactive.shifts (*).cpu / 3.6e9;
	groups (*).interactive.total.cpu = groups (*).interactive.total.cpu / 3.6e9;
	groups (*).interactive.shifts (*).connect = groups (*).interactive.shifts (*).connect / 3.6e9;
	groups (*).interactive.total.connect = groups (*).interactive.total.connect / 3.6e9;
	groups (*).interactive.shifts (*).memory = groups (*).interactive.shifts (*).memory / 1e6;
	groups (*).interactive.total.memory = groups (*).interactive.total.memory / 1e6;
	groups (*).absentee.queues (*).cpu = groups (*).absentee.queues (*).cpu / 3.6e9;
	groups (*).absentee.total.cpu = groups (*).absentee.total.cpu / 3.6e9;
	groups (*).absentee.queues (*).memory = groups (*).absentee.queues (*).memory / 1e6;
	groups (*).absentee.total.memory = groups (*).absentee.total.memory / 1e6;
	groups (*).total.cpu = groups (*).total.cpu / 3.6e9;
	groups (*).total.memory = groups (*).total.memory / 1e6;

/* now calculate the remaining breakdown of charges (those not done by add_bins) */
/* note that because consoleless daemons have connect usage, but do not have
   connect charges, connect charges are not simply usage*rates.  connect charges are
   therefore calculated by subtracting all other interactive charges from the total
   interactive charges */

	do i = 1 to ngroups;
	     groups (i).interactive.total.cpu_dollars = sum (groups (i).interactive.shifts (*).cpu_dollars);
	     groups (i).interactive.total.memory_dollars = sum (groups (i).interactive.shifts (*).memory_dollars);
	     groups (i).interactive.total.ioops_dollars = sum (groups (i).interactive.shifts (*).ioops_dollars);
	     groups (i).interactive.shifts (*).connect_dollars =
		groups (i).interactive.shifts (*).total_dollars - groups (i).interactive.shifts (*).cpu_dollars
		- groups (i).interactive.shifts (*).memory_dollars - groups (i).interactive.shifts (*).ioops_dollars;
	     groups (i).interactive.total.connect_dollars =
		groups (i).interactive.total.total_dollars - groups (i).interactive.total.cpu_dollars
		- groups (i).interactive.total.memory_dollars - groups (i).interactive.total.ioops_dollars;
	     groups (i).absentee.total.cpu_dollars = sum (groups (i).absentee.queues (*).cpu_dollars);
	     groups (i).absentee.total.memory_dollars = sum (groups (i).absentee.queues (*).memory_dollars);
	     groups (i).iod.total.lines_dollars = sum (groups (i).iod.queues (*).lines_dollars);
	end;

/* now get a few more totals */
	groups (*).total.cpu = groups (*).interactive.total.cpu + groups (*).absentee.total.cpu;
	groups (*).total.cpu_dollars = groups (*).interactive.total.cpu_dollars + groups (*).absentee.total.cpu_dollars;
	groups (*).total.memory = groups (*).interactive.total.memory + groups (*).absentee.total.memory;
	groups (*).total.memory_dollars =
	     groups (*).interactive.total.memory_dollars + groups (*).absentee.total.memory_dollars;

/* calculate a few averages, being careful to avoid zerodivide */
	do i = 1 to ngroups;
	     do j = 0 to 7;
		if groups (i).interactive.shifts (j).connect > 0
		then do;
			groups (i).interactive.shifts (j).dollars_per_hour =
			     groups (i).interactive.shifts (j).total_dollars
			     / groups (i).interactive.shifts (j).connect;
			groups (i).interactive.total.dollars_per_hour =
			     groups (i).interactive.total.total_dollars / groups (i).interactive.total.connect;
		     end;
	     end;
	     if groups (i).interactive.sessions > 0
	     then do;
		     groups (i).interactive.dollars_per_session =
			groups (i).interactive.total.total_dollars / groups (i).interactive.sessions;
		     groups (i).interactive.hours_per_session =
			groups (i).interactive.total.connect / groups (i).interactive.sessions;
		end;
	     do j = 1 to 4;
		if groups (i).absentee.queues (j).jobs > 0
		then groups (i).absentee.queues (j).dollars_per_job =
			groups (i).absentee.queues (j).total_dollars / groups (i).absentee.queues (j).jobs;
	     end;
	     if groups (i).absentee.total.jobs > 0
	     then groups (i).absentee.total.dollars_per_job =
		     groups (i).absentee.total.total_dollars / groups (i).absentee.total.jobs;
	end;

/* "Round" */
	groups (*).devices$ = groups (*).devices$ + sign (groups (*).devices$) * 5e-3;
	groups (*).misc_dollars = groups (*).misc_dollars + sign (groups (*).misc_dollars) * 5e-3;
	groups (*).interactive = groups (*).interactive + sign (groups (*).interactive) * 5e-3;
	groups (*).disk = groups (*).disk + sign (groups (*).disk) * 5e-3;
	groups (*).absentee = groups (*).absentee + sign (groups (*).absentee) * 5e-3;
	groups (*).iod = groups (*).iod + sign (groups (*).iod) * 5e-3;
	groups (*).total = groups (*).total + sign (groups (*).total) * 5e-3;
	groups (*).disk.page_days = groups (*).disk.page_days + sign (groups (*).disk.page_days) * .495e0;

/* et voil'a, ready to be printed */
     end conversions_and_sums;

revenue_summary:
     proc (daily, titles);

/* This procedure prints the Revenue Summary portion of the report.
   Parameters:
   daily - input - "1"b if daily report, "0"b if monthly report
   titles - input - the titles to be printed at beginning of report */
dcl	i		fixed bin,
	daily		bit (1);
dcl	1 titles,					/* Titles for 1st page */
	  2 company	char (120),		/* Company name, double spaced */
	  2 dept		char (120),		/* department name, double spaced */
	  2 report_title	char (50),		/* ...usage and revenue report */
	  2 time_span	char (42),		/* For mm/dd/yy hhmm dddto mm/dd/yy hhmm ddd */
	  2 system	char (24);		/* Current System: xxx */
dcl	usage		format;			/* this is used to select the formats for either the daily or monthly report */

/* formats for monthly report */
f1:
	format (skip, col (20), a (7), x (9), a (3), x (8), a (6), x (5), a (8), x (8), a (4), x (8), a (4), x (35),
	     a (5));
f2:
	format (skip, col (21), a (5), x (9), a (5), x (9), a (3), x (9), a (3), x (8), a (7), x (4), a (9), x (6),
	     a (7), x (8), a (5), x (6), a (7));
f3:
	format (skip, col (2), a (5), x (7), 3 p "zz,zzz,zz9.v99", 3 p "z,zzz,zzz,zz9v");
f4:
	format (skip, col (2), a (8), x (4), 9 p "--,---,--9.v99");

/* formats for daily report */
f5:
	format (skip, col (18), a (7), x (8), a (3), x (7), a (6), x (4), a (8), x (7), a (4), x (7), a (4), x (32),
	     a (5), x (7), a (5));
f6:
	format (skip, col (19), a (5), x (8), a (5), x (8), a (3), x (8), a (3), x (7), a (7), x (3), a (9), x (5),
	     a (7), x (7), a (5), x (5), a (7), x (5), a (7));
f7:
	format (skip, col (2), a (5), x (6), 3 p "z,zzz,zz9.v99", 3 p "zzzz,zzz,zz9v");
f8:
	format (skip, col (2), a (8), x (3), 10 p "-,---,--9.v99");


/* print titles for 1st page */
	call print_centered (23 - 2 * ngroups, titles.company);
	call print_centered (2, titles.dept);
	call print_centered (2, titles.report_title);
	call print_centered (2, titles.time_span);
	call print_centered (2, titles.system);
	call print_centered (2, "R__e_v_e_n_u_e S__u_m_m_a_r_y");
	if daily
	then do;					/* assign formats and print headers for daily report */
		usage = f7;
		put skip (2) edit ("Connect", "CPU", "Memory", "Terminal", "Unit", "Disk", "Total", "Month") (r (f5));
		put edit ("Hours", "Hours", "Kmu", "I/O", "Records", "Page-Days", "Devices", "Misc.", "Charges",
		     "Charges") (r (f6));
	     end;
	else do;					/* assign formats and print headers for monthly report */
		usage = f3;
		put skip (2) edit ("Connect", "CPU", "Memory", "Terminal", "Unit", "Disk", "Total") (r (f1));
		put edit ("Hours", "Hours", "Kmu", "I/O", "Records", "Page-Days", "Devices", "Misc.", "Charges")
		     (r (f2));
	     end;
	do i = 1 to ngroups;
	     put edit (groups (i).title) (skip (2), a);
	     put edit ("Usage", groups (i).total.connect, groups (i).total.cpu, groups (i).total.memory,
		groups (i).interactive.total.ioops, groups (i).iod.total.lines, groups (i).disk.page_days) (r (usage))
		;
	     if daily
	     then put edit ("$Charges", groups (i).total.connect_dollars, groups (i).total.cpu_dollars,
		     groups (i).total.memory_dollars, groups (i).interactive.total.ioops_dollars,
		     groups (i).iod.total.lines_dollars, groups (i).disk.page_days$, groups (i).devices$,
		     groups (i).misc_dollars, groups (i).total.today_dollars, groups (i).total.month_dollars) (r (f8))
		     ;
	     else put edit ("$Charges", groups (i).total.connect_dollars, groups (i).total.cpu_dollars,
		     groups (i).total.memory_dollars, groups (i).interactive.total.ioops_dollars,
		     groups (i).iod.total.lines_dollars, groups (i).disk.page_days$, groups (i).devices$,
		     groups (i).misc_dollars, groups (i).total.today_dollars) (r (f4));
	end;
     end revenue_summary;

interactive_summary:
     proc (short_date);

/* This procedure prints the Interactive Summary portion of the report.
   Parameter:
   short_date - input - the date to be printed at top of each page */
dcl	shift_used	(0:7) fixed bin;
dcl	nshifts		fixed bin;
dcl	short_date	char (8);
dcl	i		fixed bin,
	shift_names	(0:7) char (8)
			init ("Shift 0:", "Shift 1:", "Shift 2:", "Shift 3:", "Shift 4:", "Shift 5:", "Shift 6:",
			"Shift 7:");

f0:
	format (page, a (8), col (127), a (4), p "z9");
f1:
	format (skip, x (76 - 6 * ngroups), 9 a (12));
f2:
	format (skip (2), x (56 - 6 * ngroups), a (8), x (2), a (10), 9 p "z,zzz,zz9.v99");
f3:
	format (skip, x (66 - 6 * ngroups), a (10), 9 p "-,---,--9.v99");
f4:
	format (skip (2), x (56 - 6 * ngroups), a (8), x (2), a (10), 9 p "zzzz,zzz,zz9v");
f5:
	format (skip, x (66 - 6 * ngroups), a (10), 9 p "----,---,--9v");

	shift_used = 0;
	do i = 0 to 7;
	     if sum (groups (*).interactive.shifts (i).cpu) > 0
	     then shift_used (i) = 1;
	end;
	nshifts = sum (shift_used);
	if nshifts > 0
	then do;
		put file (sysprint) edit (short_date, "Page", pageno (sysprint)) (r (f0));
		call print_centered (1, "I__n_t_e_r_a_c_t_i_v_e S__u_m_m_a_r_y:_ C_P_U_ H__o_u_r_s");
		put file (sysprint) edit (groups (*).title_line_1) (skip, r (f1));
		put file (sysprint) edit (groups (*).title_line_2) (r (f1));
		do i = 0 to 7;
		     if shift_used (i) > 0
		     then put file (sysprint)
			     edit (shift_names (i), "Usage", groups (*).interactive.shifts (i).cpu) (r (f2))
			     ("$Charges", groups (*).interactive.shifts (i).cpu_dollars) (r (f3));
		end;
		put file (sysprint)
		     edit ("Total:", "Usage", groups (*).interactive.total.cpu) (r (f2))
		     ("$Charges", groups (*).interactive.total.cpu_dollars) (r (f3));
	     end;
	shift_used = 0;
	do i = 0 to 7;
	     if sum (groups (*).interactive.shifts (i).connect) > 0
	     then shift_used (i) = 1;
	end;
	nshifts = sum (shift_used);
	if nshifts > 0
	then do;
		if lineno (sysprint) > 50 - 3 * nshifts
		then put file (sysprint) edit (short_date, "Page", pageno (sysprint)) (r (f0));
		else put file (sysprint) skip (3);
		call print_centered (1, "I__n_t_e_r_a_c_t_i_v_e S__u_m_m_a_r_y:_ C__o_n_n_e_c_t H__o_u_r_s");
		put file (sysprint) edit (groups (*).title_line_1) (skip, r (f1));
		put file (sysprint) edit (groups (*).title_line_2) (r (f1));
		do i = 0 to 7;
		     if shift_used (i) > 0
		     then put file (sysprint)
			     edit (shift_names (i), "Usage", groups (*).interactive.shifts (i).connect) (r (f2))
			     ("$Charges", groups (*).interactive.shifts (i).connect_dollars) (r (f3));
		end;
		put file (sysprint)
		     edit ("Total:", "Usage", groups (*).interactive.total.connect) (r (f2))
		     ("$Charges", groups (*).interactive.total.connect_dollars) (r (f3));
	     end;
	shift_used = 0;
	do i = 0 to 7;
	     if sum (groups (*).interactive.shifts (i).memory) > 0
	     then shift_used (i) = 1;
	end;
	nshifts = sum (shift_used);
	if nshifts > 0
	then do;
		if lineno (sysprint) > 50 - 3 * nshifts
		then put file (sysprint) edit (short_date, "Page", pageno (sysprint)) (r (f0));
		else put file (sysprint) skip (3);
		call print_centered (1, "I__n_t_e_r_a_c_t_i_v_e S__u_m_m_a_r_y:_ M__e_m_o_r_y K__m_u");
		put file (sysprint) edit (groups (*).title_line_1) (skip, r (f1));
		put file (sysprint) edit (groups (*).title_line_2) (r (f1));
		do i = 0 to 7;
		     if shift_used (i) > 0
		     then put file (sysprint)
			     edit (shift_names (i), "Usage", groups (*).interactive.shifts (i).memory) (r (f2))
			     ("$Charges", groups (*).interactive.shifts (i).memory_dollars) (r (f3));
		end;
		put file (sysprint)
		     edit ("Total:", "Usage", groups (*).interactive.total.memory) (r (f2))
		     ("$Charges", groups (*).interactive.total.memory_dollars) (r (f3));
	     end;
	shift_used = 0;
	do i = 0 to 7;
	     if sum (groups (*).interactive.shifts (i).ioops) > 0
	     then shift_used (i) = 1;
	end;
	nshifts = sum (shift_used);
	if nshifts > 0
	then do;
		if lineno (sysprint) > 50 - 3 * nshifts
		then put file (sysprint) edit (short_date, "Page", pageno (sysprint)) (r (f0));
		else put file (sysprint) skip (3);
		call print_centered (1, "I__n_t_e_r_a_c_t_i_v_e S__u_m_m_a_r_y:_ T__e_r_m_i_n_a_l I_/_O_");
		put file (sysprint) edit (groups (*).title_line_1) (skip, r (f1));
		put file (sysprint) edit (groups (*).title_line_2) (r (f1));
		do i = 0 to 7;
		     if shift_used (i) > 0
		     then put file (sysprint)
			     edit (shift_names (i), "Usage", groups (*).interactive.shifts (i).ioops) (r (f4))
			     ("$Charges", groups (*).interactive.shifts (i).ioops_dollars) (r (f3));
		end;
		put file (sysprint)
		     edit ("Total:", "Usage", groups (*).interactive.total.ioops) (r (f2))
		     ("$Charges", groups (*).interactive.total.ioops_dollars) (r (f3));
	     end;
	shift_used = 0;
	do i = 0 to 7;
	     if sum (groups (*).interactive.shifts (i).total_dollars) > 0
	     then shift_used (i) = 1;
	end;
	nshifts = sum (shift_used);
	if nshifts > 0
	then do;
		if lineno (sysprint) > 47 - 3 * nshifts
		then put file (sysprint) edit (short_date, "Page", pageno (sysprint)) (r (f0));
		else put file (sysprint) skip (3);
		call print_centered (1, "I__n_t_e_r_a_c_t_i_v_e S__u_m_m_a_r_y: T__o_t_a_l I__n_t_e_r_a_c_t_i_v_e C__h_a_r_g_e_s");
		put file (sysprint) edit (groups (*).title_line_1) (skip, r (f1));
		put file (sysprint) edit (groups (*).title_line_2) (r (f1));
		do i = 0 to 7;
		     if shift_used (i) > 0
		     then put file (sysprint)
			     edit (shift_names (i), "$Charges", groups (*).interactive.shifts (i).total_dollars)
			     (r (f2)) ("$/Hour", groups (*).interactive.shifts (i).dollars_per_hour) (r (f3));
		end;
		put file (sysprint)
		     edit ("Total:", "$Charges", groups (*).interactive.total.total_dollars) (r (f2))
		     ("$/Hour", groups (*).interactive.total.dollars_per_hour) (r (f3))
		     ("Sessions", groups (*).interactive.sessions) (r (f5))
		     ("$/Session", groups (*).interactive.dollars_per_session) (r (f3))
		     ("Hr/Session", groups (*).interactive.hours_per_session) (r (f3));
	     end;
     end interactive_summary;

absentee_summary:
     proc (short_date);

/* this procedure prints the Absentee Summary portion of the report.
   Parameter:
   short_date - input - the date to print at top of each page */
dcl	short_date	char (8);
dcl	queue_used	(4) fixed bin;
dcl	nqueues		fixed bin;
dcl	i		fixed bin,
	queue_names	(4) char (8) init ("Queue 1:", "Queue 2:", "Queue 3:", "Queue 4:");

f0:
	format (page, a (8), col (127), a (4), p "z9");
f1:
	format (skip, x (76 - 6 * ngroups), 9 a (12));
f2:
	format (skip (2), x (56 - 6 * ngroups), a (8), x (2), a (10), 9 p "z,zzz,zz9.v99");
f3:
	format (skip, x (66 - 6 * ngroups), a (10), 9 p "-,---,--9.v99");
f4:
	format (skip (2), x (56 - 6 * ngroups), a (8), x (2), a (10), 9 p "zzzz,zzz,zz9v");
f5:
	format (skip, x (66 - 6 * ngroups), a (10), 9 p "----,---,--9v");

	queue_used = 0;
	do i = 1 to 4;
	     if sum (groups (*).absentee.queues (i).cpu) > 0
	     then queue_used (i) = 1;
	end;
	nqueues = sum (queue_used);
	if nqueues > 0
	then do;
		put file (sysprint) edit (short_date, "Page", pageno (sysprint)) (r (f0));
		call print_centered (1, "A__b_s_e_n_t_e_e S__u_m_m_a_r_y:_ C_P_U_ H__o_u_r_s");
		put file (sysprint) edit (groups (*).title_line_1) (skip, r (f1));
		put file (sysprint) edit (groups (*).title_line_2) (r (f1));
		do i = 1 to 4;
		     if queue_used (i) > 0
		     then put file (sysprint)
			     edit (queue_names (i), "Usage", groups (*).absentee.queues (i).cpu) (r (f2))
			     ("$Charges", groups (*).absentee.queues (i).cpu_dollars) (r (f3));
		end;
		put file (sysprint)
		     edit ("Total:", "Usage", groups (*).absentee.total.cpu) (r (f2))
		     ("$Charges", groups (*).absentee.total.cpu_dollars) (r (f3));
	     end;
	queue_used = 0;
	do i = 1 to 4;
	     if sum (groups (*).absentee.queues (i).memory) > 0
	     then queue_used (i) = 1;
	end;
	nqueues = sum (queue_used);
	if nqueues > 0
	then do;
		if lineno (sysprint) > 50 - 3 * nqueues
		then put file (sysprint) edit (short_date, "Page", pageno (sysprint)) (r (f0));
		else put file (sysprint) skip (3);
		call print_centered (1, "A__b_s_e_n_t_e_e S__u_m_m_a_r_y:_ M__e_m_o_r_y K__m_u");
		put file (sysprint) edit (groups (*).title_line_1) (skip, r (f1));
		put file (sysprint) edit (groups (*).title_line_2) (r (f1));
		do i = 1 to 4;
		     if queue_used (i) > 0
		     then put file (sysprint)
			     edit (queue_names (i), "Usage", groups (*).absentee.queues (i).memory) (r (f2))
			     ("$Charges", groups (*).absentee.queues (i).memory_dollars) (r (f3));
		end;
		put file (sysprint)
		     edit ("Total", "Usage", groups (*).absentee.total.memory) (r (f2))
		     ("$Charges", groups (*).absentee.total.memory_dollars) (r (f3));
	     end;
	do i = 1 to 4;
	     if sum (groups (*).absentee.queues (i).total_dollars) > 0
	     then queue_used (i) = 1;
	end;
	nqueues = sum (queue_used);
	if nqueues > 0
	then do;
		if lineno (sysprint) > 49 - 3 * nqueues
		then put file (sysprint) edit (short_date, "Page", pageno (sysprint)) (r (f0));
		else put file (sysprint) skip (3);
		call print_centered (1, "A__b_s_e_n_t_e_e S__u_m_m_a_r_y: T__o_t_a_l A__b_s_e_n_t_e_e C__h_a_r_g_e_s");
		put file (sysprint) edit (groups (*).title_line_1) (skip, r (f1));
		put file (sysprint) edit (groups (*).title_line_2) (r (f1));
		do i = 1 to 4;
		     if queue_used (i) > 0
		     then put file (sysprint)
			     edit (queue_names (i), "$Charges", groups (*).absentee.queues (i).total_dollars)
			     (r (f2)) ("Jobs", groups (*).absentee.queues (i).jobs) (r (f5))
			     ("$/Job", groups (*).absentee.queues (i).dollars_per_job) (r (f3));
		end;
		put file (sysprint)
		     edit ("Total:", "$Charges", groups (*).absentee.total.total_dollars) (r (f2))
		     ("Jobs", groups (*).absentee.total.jobs) (r (f5))
		     ("$/Job", groups (*).absentee.total.dollars_per_job) (r (f3));
	     end;
     end absentee_summary;

iod_summary:
     proc (short_date);

/* This procedure prints the IO Daemon Summary portion of the report.
   Parameter:
   short_date - input - the date to be printed at top of each page */
dcl	queue_used	(4) fixed bin;
dcl	nqueues		fixed bin;
dcl	short_date	char (8);
dcl	i		fixed bin,
	queue_names	(4) char (8) init ("Queue 1:", "Queue 2:", "Queue 3:", "Queue 4:");

f0:
	format (page, a (8), col (127), a (4), p "z9");
f1:
	format (skip, x (76 - 6 * ngroups), 9 a (12));
f2:
	format (skip (2), x (56 - 6 * ngroups), a (8), x (2), a (10), 9 p "z,zzz,zz9.v99");
f3:
	format (skip, x (66 - 6 * ngroups), a (10), 9 p "-,---,--9.v99");
f4:
	format (skip (2), x (56 - 6 * ngroups), a (8), x (2), a (10), 9 p "zzzz,zzz,zz9v");
f5:
	format (skip, x (66 - 6 * ngroups), a (10), 9 p "----,---,--9v");

	queue_used = 0;
	do i = 1 to 4;
	     if sum (groups (*).iod.queues (i).lines) > 0
	     then queue_used (i) = 1;
	end;
	nqueues = sum (queue_used);
	if nqueues > 0
	then do;
		put file (sysprint) edit (short_date, "Page", pageno (sysprint)) (r (f0));
		call print_centered (1, "I_/_O_ D__a_e_m_o_n S__u_m_m_a_r_y:_ L__i_n_e_s");
		put file (sysprint) edit (groups (*).title_line_1) (skip, r (f1));
		put file (sysprint) edit (groups (*).title_line_2) (r (f1));
		do i = 1 to 4;
		     if queue_used (i) > 0
		     then put file (sysprint)
			     edit (queue_names (i), "Usage", groups (*).iod.queues (i).lines) (r (f4))
			     ("$Charges", groups (*).iod.queues (i).lines_dollars) (r (f3));
		end;
		put file (sysprint)
		     edit ("Total:", "Usage", groups (*).iod.total.lines) (r (f4))
		     ("$Charges", groups (*).iod.total.lines_dollars) (r (f3));
	     end;
     end iod_summary;

system_stats:
     proc (daily, short_date);

/* This procedure extracts system usage info from use_totals and prints the System Statistics
   portion of the report.
   Parameters:
   daily - input - "1"b if daily report, "0"b if monthly
   short_date - input - date to be printed at top of pages */
dcl	(day_units, total_units)
			float bin,
	(i, j)		fixed bin,
	daily		bit (1),
	short_date	char (8);
dcl	days		float bin,
	(xcpu, xmem)	fixed bin;
dcl	1 sys_stats	(3),			/* today,average,month */
	( 2 starts,
	  2 crashes,
	  2 mtbf,
	  2 hrs_avail,
	  2 cpu_avail,
	  2 two_cpu,
	  2 cpu_billed,
	  2 overhead,
	  2 idle,
	  2 zidle,
	  2 mpidle,
	  2 nmpidle,
	  2 max_units,
	  2 reconfigs
	  )		float bin;

/* daily formats */
f0:
	format (skip (2), col (76), a (5), x (6), a (5));
f1:
	format (skip, x (40), a (29), p "zzz,zzz,zz9v", p "zzz,zzz,zz9v");
f2:
	format (skip, x (40), a (29), p "zzzz,zz9.v99", p "zzzz,zz9.v99");
f3:
	format (skip, x (42), a (27), p "zzzz,zz9.v99", p "zzzz,zz9.v99");

/* monthly formats */

f4:
	format (skip, x (40), a (29), p "zzzz,zz9.v99", p "zzz,zzz,zz9v");
f5:
	format (skip, x (40), a (29), x (11), p "zzzz,zz9.v99");
f6:
	format (skip, x (40), a (29), 2 p "zzzz,zz9.v99");
f7:
	format (skip, x (42), a (27), x (11), p "zzzz,zz9.v99");
f8:
	format (skip (3), col (75), a (5), col (74), a (7), x (6), a (5));

	sys_stats (3).starts = use_totals.sys_starts;
	sys_stats (3).crashes = use_totals.sys_crash;
	sys_stats (3).hrs_avail = use_totals.uptime;
	sys_stats (3).cpu_avail = use_totals.cpu_avail;
	sys_stats (3).cpu_billed = use_totals.total_cpu;
	sys_stats (3).idle = use_totals.idle;
	sys_stats (3).zidle = use_totals.zidle;
	sys_stats (3).mpidle = use_totals.mpidle;

	if daily
	then do;
		sys_stats (1).starts = sys_stats (3).starts - xtotp -> use_totals.sys_starts;
		sys_stats (1).crashes = sys_stats (3).crashes - xtotp -> use_totals.sys_crash;
		sys_stats (1).hrs_avail = sys_stats (3).hrs_avail - xtotp -> use_totals.uptime;
		sys_stats (1).cpu_avail = sys_stats (3).cpu_avail - xtotp -> use_totals.cpu_avail;
		sys_stats (1).cpu_billed = sys_stats (3).cpu_billed - xtotp -> use_totals.total_cpu;
		sys_stats (1).idle = sys_stats (3).idle - xtotp -> use_totals.idle;
		sys_stats (1).zidle = sys_stats (3).zidle - xtotp -> use_totals.zidle;
		sys_stats (1).mpidle = sys_stats (3).mpidle - xtotp -> use_totals.mpidle;
	     end;
	xcpu, xmem = -1;
	sys_stats (3).reconfigs = -1;
	sys_stats (1).reconfigs = 0;
	sys_stats (1).max_units, sys_stats (3).max_units = 0;
	day_units, total_units = 0;
	do i = 1 to use_totals.max_day_log;
	     do j = 1
		to 96 * bin (i ^= use_totals.max_day_log) + use_totals.max_qhour * bin (i = use_totals.max_day_log);
		if ^(use_totals.daylog (i).qh (j).cpu = xcpu & use_totals.daylog (i).qh (j).kmem = xmem)
		     & use_totals.daylog (i).qh (j).cpu ^= 0
		then do;
			sys_stats (3).reconfigs = sys_stats (3).reconfigs + 1;
			if daily
			then if use_totals.daylog (i).qh (j).time > xtotp -> use_totals.period_end
			     then sys_stats (1).reconfigs = sys_stats (1).reconfigs + 1;
			xcpu = use_totals.daylog (i).qh (j).cpu;
			xmem = use_totals.daylog (i).qh (j).kmem;
		     end;
		if daily
		then if use_totals.daylog (i).qh (j).time > xtotp -> use_totals.period_end
		     then if use_totals.daylog (i).qh (j).nunits > sys_stats (1).max_units
			then sys_stats (1).max_units = use_totals.daylog (i).qh (j).nunits;
		if use_totals.daylog (i).qh (j).nunits > sys_stats (3).max_units
		then sys_stats (3).max_units = use_totals.daylog (i).qh (j).nunits;
		if use_totals.daylog (i).qh (j).nunits > day_units
		then day_units = use_totals.daylog (i).qh (j).nunits;
	     end;
	     total_units = total_units + day_units;
	     day_units = 0;
	end;
	sys_stats (3).mtbf = sys_stats (3).hrs_avail / (sys_stats (3).crashes + 1);
	sys_stats (3).two_cpu = sys_stats (3).cpu_avail - sys_stats (3).hrs_avail;
	if daily
	then do;
		sys_stats (1).mtbf = sys_stats (1).hrs_avail / (sys_stats (1).crashes + 1);
		sys_stats (1).two_cpu = sys_stats (1).cpu_avail - sys_stats (1).hrs_avail;
	     end;
	if sys_stats (3).cpu_avail > 0
	then do;
		sys_stats (3).overhead =
		     (sys_stats (3).cpu_avail - sys_stats (3).cpu_billed - sys_stats (3).idle)
		     / sys_stats (3).cpu_avail * 100e0;
		sys_stats (3).idle = sys_stats (3).idle / sys_stats (3).cpu_avail * 100e0;
		sys_stats (3).zidle = sys_stats (3).zidle / sys_stats (3).cpu_avail * 100e0;
		sys_stats (3).mpidle = sys_stats (3).mpidle / sys_stats (3).cpu_avail * 100e0;
		sys_stats (3).nmpidle = sys_stats (3).idle - sys_stats (3).zidle - sys_stats (3).mpidle;
	     end;
	if daily
	then if sys_stats (1).cpu_avail > 0
	     then do;
		     sys_stats (1).overhead =
			(sys_stats (1).cpu_avail - sys_stats (1).cpu_billed - sys_stats (1).idle)
			/ sys_stats (1).cpu_avail * 100e0;
		     sys_stats (1).idle = sys_stats (1).idle / sys_stats (1).cpu_avail * 100e0;
		     sys_stats (1).zidle = sys_stats (1).zidle / sys_stats (1).cpu_avail * 100e0;
		     sys_stats (1).mpidle = sys_stats (1).mpidle / sys_stats (1).cpu_avail * 100e0;
		     sys_stats (1).nmpidle = sys_stats (1).idle - sys_stats (1).zidle - sys_stats (1).mpidle;
		end;
	sys_stats (3).hrs_avail = sys_stats (3).hrs_avail / 3.6e9;
	sys_stats (3).cpu_avail = sys_stats (3).cpu_avail / 3.6e9;
	sys_stats (3).cpu_billed = sys_stats (3).cpu_billed / 3.6e9;
	sys_stats (3).two_cpu = sys_stats (3).two_cpu / 3.6e9;
	sys_stats (3).mtbf = sys_stats (3).mtbf / 3.6e9;
	sys_stats (3).max_units = sys_stats (3).max_units / 10e0;
	if daily
	then do;
		sys_stats (1).hrs_avail = sys_stats (1).hrs_avail / 3.6e9;
		sys_stats (1).cpu_avail = sys_stats (1).cpu_avail / 3.6e9;
		sys_stats (1).cpu_billed = sys_stats (1).cpu_billed / 3.6e9;
		sys_stats (1).two_cpu = sys_stats (1).two_cpu / 3.6e9;
		sys_stats (1).mtbf = sys_stats (1).mtbf / 3.6e9;
		sys_stats (1).max_units = sys_stats (1).max_units / 10e0;
	     end;
	if ^daily
	then do;
		days = use_totals.period_end - use_totals.period_begin;
		days = days / 8.64e10;
		sys_stats (2).starts = sys_stats (3).starts / days;
		sys_stats (2).crashes = sys_stats (3).crashes / days;
		sys_stats (2).hrs_avail = sys_stats (3).hrs_avail / days;
		sys_stats (2).cpu_avail = sys_stats (3).cpu_avail / days;
		sys_stats (2).two_cpu = sys_stats (3).two_cpu / days;
		sys_stats (2).cpu_billed = sys_stats (3).cpu_billed / days;
		sys_stats (2).reconfigs = sys_stats (3).reconfigs / days;
		sys_stats (2).max_units = total_units / (days * 10e0);
	     end;

/* "Round" */
	sys_stats = sys_stats + 5e-3;

	put edit (short_date, "Page", pageno (sysprint)) (page, a (8), col (127), a (4), p "z9");
	if ^daily
	then put skip (6);
	call print_centered (4, "S__y_s_t_e_m P__e_r_f_o_r_m_a_n_c_e _a_n_d A__v_a_i_l_a_b_i_l_i_t_y");

	if daily
	then do;
		put edit ("Today", "Month") (r (f0));
		put skip;
		put edit ("Starts", (sys_stats (i).starts do i = 1, 3)) (r (f1));
		put edit ("Crashes", (sys_stats (i).crashes do i = 1, 3)) (r (f1));
		put edit ("Mean Time Between Failures", (sys_stats (i).mtbf do i = 1, 3)) (r (f2));
		put edit ("Hours Available", (sys_stats (i).hrs_avail do i = 1, 3)) (r (f2));
		put edit ("CPU Hours", (sys_stats (i).cpu_avail do i = 1, 3)) (r (f2));
		put edit ("Two-CPU Hours", (sys_stats (i).two_cpu do i = 1, 3)) (r (f2));
		put edit ("Virtual CPU Hours Billed", (sys_stats (i).cpu_billed do i = 1, 3)) (r (f2));
		put edit ("% CPU Overhead", (sys_stats (i).overhead do i = 1, 3)) (r (f2));
		put edit ("% Idle", (sys_stats (i).idle do i = 1, 3)) (r (f2));
		put edit ("% Zero Idle", (sys_stats (i).zidle do i = 1, 3)) (r (f3));
		put edit ("% Multiprogramming Idle", (sys_stats (i).mpidle do i = 1, 3)) (r (f3));
		put edit ("% Nonmultiprogramming Idle", (sys_stats (i).nmpidle do i = 1, 3)) (r (f3));
		put edit ("Maximum Load Units", (sys_stats (i).max_units do i = 1, 3)) (r (f2));
		put edit ("Reconfigurations", (sys_stats (i).reconfigs do i = 1, 3)) (r (f1));
	     end;
	else do;
		put edit ("Daily", "Average", "Month") (r (f8));
		put skip;
		put edit ("Starts", (sys_stats (i).starts do i = 2, 3)) (r (f4));
		put edit ("Crashes", (sys_stats (i).crashes do i = 2, 3)) (r (f4));
		put edit ("Mean Time Between Failures", sys_stats (3).mtbf) (r (f5));
		put edit ("Hours Available", (sys_stats (i).hrs_avail do i = 2, 3)) (r (f6));
		put edit ("CPU Hours", (sys_stats (i).cpu_avail do i = 2, 3)) (r (f6));
		put edit ("Two-CPU Hours", (sys_stats (i).two_cpu do i = 2, 3)) (r (f6));
		put edit ("Virtual CPU Hours Billed", (sys_stats (i).cpu_billed do i = 2, 3)) (r (f6));
		put edit ("% CPU Overhead", sys_stats (3).overhead) (r (f5));
		put edit ("% Idle", sys_stats (3).idle) (r (f5));
		put edit ("% Zero Idle", sys_stats (3).zidle) (r (f7));
		put edit ("% Multiprogramming Idle", sys_stats (3).mpidle) (r (f7));
		put edit ("% Nonmultiprogramming Idle", sys_stats (3).nmpidle) (r (f7));
		put edit ("Maximum Load Units", (sys_stats (i).max_units do i = 2, 3)) (r (f6));
		put edit ("Reconfigurations", (sys_stats (i).reconfigs do i = 2, 3)) (r (f4));
	     end;
     end system_stats;

disk_stats:
     proc ();

/* this procedure prints out the Disk Statistics portion of the report. */
dcl	i		fixed bin;

	call print_centered (3, "D__i_s_k S__t_a_t_i_s_t_i_c_s:  U__s_e _o_f >__u_d_d S__t_o_r_a_g_e");
	put edit ("Quota", "Used") (skip (2), x (73), a (5), x (7), a (4));
	put skip;
	do i = 1 to ngroups;
	     put edit (groups (i).title, groups (i).disk.quota, groups (i).disk.usage)
		(skip, x (43), a (24), 2 p "zzz,zzz,zz9v");
	end;
     end disk_stats;

times_available:
     proc;

/* This procedure extracts data from the daylog portion of use_totals and prints
   the Times Available section of the report. */
dcl	(i, j)		fixed bin,
	(from, to)	char (17),
	(lup, ldown)	char (14),
	(ctime, stime)	fixed bin (71),
	reason		char (12);

	call print_centered (3, "T__i_m_e_s A__v_a_i_l_a_b_l_e T__o_d_a_y");
	put edit ("Length of", "Length of") (skip (2), x (68), a (9), x (21), a (9));
	put edit ("From", "To", "Uptime", "Reason Down", "Downtime")
	     (skip, x (32), a (4), x (17), a (2), x (15), a (6), x (5), a (13), x (5), a (8));
	put skip;
	ctime = 0;
	do i = 1 to use_totals.max_day_log;
	     do j = 1
		to 96 * bin (i ^= use_totals.max_day_log) + use_totals.max_qhour * bin (i = use_totals.max_day_log);
		if use_totals.daylog (i).qh (j).crashtime > xtotp -> use_totals.period_end
		     & use_totals.daylog (i).qh (j).crashtime < use_totals.period_end
		     & use_totals.daylog (i).qh (j).time ^= 0
		then do;
			reason = "";
			if use_totals.daylog (i).qh (j).dump_number ^= 0
			then reason = ltrim (char (use_totals.daylog (i).qh (j).dump_number));
			else if j = 96
			then if use_totals.daylog (i + 1).qh (1).dump_number ^= 0
			     then reason = ltrim (char (use_totals.daylog (i + 1).qh (1).dump_number));
			     else ;
			else if use_totals.daylog (i).qh (j + 1).dump_number ^= 0
			then reason = ltrim (char (use_totals.daylog (i).qh (j + 1).dump_number));
			if reason ^= "shutdown" & reason ^= "crash" & reason ^= ""
			then reason = "crash #" || reason;
			if ctime > 0
			then do;
				call elapsed_time (use_totals.daylog (i).qh (j).starttime - ctime, ldown);
				put edit (ldown) (x (1), a (14));
			     end;
			ctime = use_totals.daylog (i).qh (j).crashtime;
			to = format_time (use_totals.daylog (i).qh (j).crashtime);
			from = format_time (use_totals.daylog (i).qh (j).starttime);
			call elapsed_time (use_totals.daylog (i).qh (j).crashtime
			     - use_totals.daylog (i).qh (j).starttime, lup);
			put edit (from, to, lup, reason)
			     (skip, x (26), a (17), x (3), a (17), x (1), a (14), x (3), a (12));
		     end;
	     end;
	end;
	if use_totals.daylog (max_day_log).qh (max_qhour).time > 0
	then stime = use_totals.daylog (max_day_log).qh (max_qhour).starttime;
	else stime = use_totals.period_end;
	if ctime > 0
	then do;
		call elapsed_time (stime - ctime, ldown);
		put edit (ldown) (x (1), a (14));
	     end;
	if stime > ctime
	then do;
		from = format_time (stime);
		put edit (from) (skip, x (26), a (17));
	     end;
elapsed_time:
     proc (time, string);

/* This procedure converts a time in microseconds into a character string repesenting the
   time in hours and minutes
   Parameters:
   time - input - the time in microseconds
   string - output - character representation of the time */
/* 1 min = 60,000,000 microseconds
   1 hour = 3,600,000,000 microseconds */

dcl	(time, temp, temp2) fixed bin (71),
	string		char (*),
	minutes		pic "z9",
	hours		pic "zzz9";

	if time <= 0
	then do;
		string = "";
		return;
	     end;
	temp = time;
	temp2 = divide (temp, 3600000000, 71, 0);
	hours = min (temp2, 9999);
	temp = temp - multiply (temp2, 3600000000, 71, 0);
	temp2 = divide (temp + 30000000, 60000000, 71, 0);
	minutes = temp2;
	if hours > 0
	then string = hours || " Hr " || minutes || " Min";
	else string = "        " || minutes || " Min";
     end elapsed_time;
     end times_available;

group_composition:
     proc (short_date);

/* This procedure prints out the group composition section of the report
   Parameter:
   short_date - input - date to be printed at top of each page */
dcl	(total, ll, i, j, k, m, n)
			fixed bin,
	temp		char (12),
	short_date	char (8),
	s		char (24) var,
	bin_used		(hbound (groups.bins, 2)) fixed bin init ((hbound (groups.bins, 2)) 0),
	ioa_$rsnnl	entry options (variable);

	put edit (short_date, "Page", pageno (sysprint)) (page, a (8), col (127), a (4), p "z9");
	call print_centered (1, "C__o_m_p_o_s_i_t_i_o_n _o_f _t_h_e G__r_o_u_p_s _i_n _t_h_i_s R_e__p_o_r_t");
	do i = 1 to ngroups;
	     call ioa_$rsnnl ("^a", s, m, groups (i).title);
	     put edit ("""", s, """ consists of ") (skip (2), x (30), a (1), a, a (14));
	     ll = 21 + m;
	     call ioa_$rsnnl ("^d", s, m, groups (i).projects);
	     if groups (i).projects > 1
	     then do;
		     put edit (s, " projects with ") (a, a (15));
		     ll = ll + 15 + m;
		end;
	     else do;
		     put edit (s, " project with ") (a, a (14));
		     ll = ll + 14 + m;
		end;
	     call ioa_$rsnnl ("^d", s, m, groups (i).users);
	     if groups (i).projects > 1
	     then do;
		     put edit (s, " users.  The projects are") (a, a (25));
		     ll = ll + 25 + m;
		end;
	     else do;
		     put edit (s, " users.  The project is") (a, a (23));
		     ll = ll + 23 + m;
		end;
	     total = 0;
	     do j = 1 to hbound (groups.bins, 2) while (groups (i).bins (j) > 0);
		bin_used (groups (i).bins (j)) = 1;
		n = 0;
		do k = 1 to use_totals.n_select;
		     if use_totals.select_ut (k) = groups (i).bins (j)
		     then n = n + 1;
		end;
		if n = 0
		then total = total + 1;
		else total = total + n;
	     end;
	     n = 0;
	     do j = 1 to hbound (groups.bins, 2) while (groups (i).bins (j) > 0);
		do k = 1 to use_totals.n_select;
		     if use_totals.select_ut (k) = groups (i).bins (j)
		     then do;
			     n = n + 1;
			     temp = use_totals.select_proj (k);
			     call print (n, total, ll, temp);
			end;
		end;
	     end;
	     if n < total
	     then do;
		     n = n + 1;
		     call print (n, total, ll, "all projects not otherwise specified");
		end;
	     if sum (groups (i).groups (*)) > 0
	     then do;
		     call print (n, total, ll, "those projects included in the group(s)");
		     total = 0;
		     do j = 1 to 9 while (groups (i).groups (j) > 0);
			total = total + 1;
		     end;
		     do j = 1 to 9 while (groups (i).groups (j) > 0);
			call print (j, total, ll, groups (groups (i).groups (j)).title);
		     end;
		end;
	     put edit (".") (a (1));
	end;
	if sum (bin_used) < ntypes
	then do;
		total, m, n = 0;
		do j = 1 to ntypes;
		     if bin_used (j) = 0
		     then do;
			     n = n + use_totals.ut (j).nproj;
			     m = m + use_totals.ut (j).nusers;
			     do k = 1 to use_totals.n_select;
				if use_totals.select_ut (k) = j
				then total = total + 1;
			     end;
			end;
		end;
		if n ^= 0
		then do;
			call ioa_$rsnnl ("^d", s, k, n);
			put edit (s, " projects with ") (skip (2), x (30), a, a (15));
			ll = 20 + k;
			call ioa_$rsnnl ("^d", s, k, m);
			put edit (s, " users are not included in this report.  The projects are") (a, a (57));
			ll = k + 56;
			n = 0;
			do j = 1 to ntypes;
			     if bin_used (j) = 0
			     then do;
				     n = n + 1;
				     do k = 1 to use_totals.n_select;
					if use_totals.select_ut (k) = j
					then do;
						n = n + 1;
						temp = use_totals.select_proj (k);
						call print (n, total, ll, temp);
					     end;
				     end;
				end;
			end;
			put edit (".") (a (1));
		     end;
	     end;
print:
     proc (n, total, ll, title);

/* This procedure is called to print each item in the list of projects belonging to a group.
   It determines what to put between items (, or and) and where to break lines.
   Parameters:
   n - input - the position of the item in the list
   total - input - the total number of items in the list
   ll - input,output - the column position within the current output line
   title - input - the item to be printed */

dcl	(n, total, ll)	fixed bin,
	title		char (*),
	s		char (120) var,
	m		fixed bin;

	call ioa_$rsnnl ("^a", s, m, title);
	if ll + m > 85
	then do;
		if n > 1
		then if n < total
		     then put edit (",", s) (a, skip, x (26), a);
		     else put edit (" and", s) (a, skip, x (26), a);
		else put edit (s) (skip, x (26), a);
		ll = m;
	     end;
	else do;
		if n > 1
		then if n < total
		     then put edit (", ", s) (a, a);
		     else put edit (" and ", s) (a, a);
		else put edit (s) (x (1), a);
		ll = ll + m + 2;
	     end;
     end print;
     end group_composition;

rates_and_shifts:
     proc (P, shift_table, short_date);

/* This procedure prints the Rates portion of the report.
   Parameters:
   are all input parameters */

dcl	1 P,					/* all the prices for one rate structure */
	  2 rs_name	char (32),		/* name for this rate */
	  2 abs_cpu_rates	(1:4) float bin,		/* installation price for absentee cpu time ($/hr) */
	  2 abs_memory_rates
			(1:4) float bin,		/* installation price for absentee memory usage ($/Kmu) */
	  2 connect_rates	(0:7) float bin,		/* installation price for terminal connect time ($/hr) */
	  2 memory_rates	(0:7) float bin,		/* installation price for memory usage ($/Kmu) */
	  2 disk_rates	float bin,		/* installation price for disk storage ($/page-sec) */
	  2 cpu_rates	(0:7) float bin,		/* installation price for interactive cpu time ($/hr) */
	  2 lines_rates	(1:4) float bin,		/* installation price for line printer lines ($/K-lines) */
	  2 ioops_rates	(0:7) float bin,		/* installation price for I/O operations ($/K) */
	  2 reg_rates	float bin,		/* user registration charge ($/month) */
	  2 device_table	aligned,
	    3 ndevices	fixed bin,		/* number of devices used */
	    3 dvt		(16),
	      4 device_id	char (8),
	      4 device_rates
			(0:7) float bin;		/* $/hr */
dcl	shift_table	(336) fixed bin,		/* table of shift #'s for each half hour in week */
	shifts		(7, 0:47) fixed bin def (shift_table),
	day_names		(7) char (3) init ("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"),
	(shift, start_time, end_time, day, day2, time, time2, cur_shft)
			fixed bin,
	(match, this_shift_used)
			bit (1);
dcl	nn		(4) fixed bin,
	(i, j, k, l, n)	fixed bin,
	s		char (8) var,
	yes		bit (1),
	ioa_$rsnnl	entry options (variable);
dcl	short_date	char (8);


	put edit (short_date, "Page", pageno (sysprint)) (page, a (8), col (127), a (4), p "z9");
	call print_centered (1, "The following prices are currently in effect for rate structure - " || rs_name);
	call print_centered (2, "I__n_t_e_r_a_c_t_i_v_e R__a_t_e_s");
	put edit ("CPU", "Connect", "Memory", "Terminal I/O")
	     (skip (2), x (53), a (3), x (8), a (7), x (9), a (6), x (3), a (12));
	put skip;
	do i = 0 to 7;
	     if cpu_rates (i) > 0 | memory_rates (i) > 0 | connect_rates (i) > 0 | ioops_rates (i) > 0
	     then put edit ("Shift", i, ":", cpu_rates (i) + 5e-3, "/Hr", connect_rates (i) + 5e-3, "/Hr",
		     memory_rates (i) + 5e-3, "/Kmu", ioops_rates (i) + 5e-3, "/K")
		     (skip, x (33), a (5), p "z9", a (1), 2 (p "$,$$$,$$9.v99", a (3)), p "$$$$,$$9.v99", a (4),
		     p "$$,$$$,$$9.v99", a (2));
	end;
	call print_centered (2, "A__b_s_e_n_t_e_e R__a_t_e_s");
	put edit ("CPU", "Memory") (skip (2), x (68), a (3), x (9), a (6));
	put skip;
	do i = 1 to 4;
	     if abs_cpu_rates (i) > 0 | abs_memory_rates (i) > 0
	     then put edit ("Queue", i, ":", abs_cpu_rates (i) + 5e-3, "/Hr", abs_memory_rates (i) + 5e-3, "/Kmu")
		     (skip, x (49), a (5), p "z9", a (1), p "$$$$,$$9.v99", a (3), p "$$$$,$$9.v99", a (4));
	end;
	call print_centered (2, "I_/_O_ D__a_e_m_o_n R__a_t_e_s");
	put edit ("Lines") (skip (2), x (72), a (5));
	put skip;
	do i = 1 to 4;
	     if lines_rates (i) > 0
	     then put edit ("Queue", i, ":", lines_rates (i) + 5e-3, "/K")
		     (skip, x (55), a (5), p "z9", a (1), p "$,$$$,$$9.v99", a (2));
	end;
	yes = "0"b;
	do i = 1 to ndevices;
	     if sum (dvt (i).device_rates (*)) > 0
	     then yes = "1"b;
	end;
	if yes
	then do;
		call print_centered (2, "D__e_v_i_c_e R__a_t_e_s");
		i = 1;
		do while (i <= ndevices);
		     nn = 0;
		     n = 1;
		     do while (n <= 4 & i <= ndevices);
			if sum (dvt (i).device_rates (*)) > 0
			then do;
				nn (n) = i;
				n = n + 1;
			     end;
			i = i + 1;
		     end;
		     n = n - 1;
		     if n > 0
		     then do;
			     call ioa_$rsnnl ("^a", s, l, dvt (nn (1)).device_id);
			     put edit (s) (skip (2), x ((156 - n * 15) / 2), x (8 - l), a);
			     do j = 2 to n;
				call ioa_$rsnnl ("^a", s, l, dvt (nn (j)).device_id);
				put edit (s) (x (7), x (8 - l), a);
			     end;
			     put skip;
			     do j = 0 to 7;
				yes = "0"b;
				do k = 1 to n while (^yes);
				     if dvt (nn (k)).device_rates (j) > 0
				     then yes = "1"b;
				end;
				if yes
				then do;
					put edit ("Shift", j, ":")
					     (skip, x ((126 - n * 15) / 2), a (5), p "z9", a (1));
					do k = 1 to n;
					     put edit (dvt (nn (k)).device_rates (j) + 5e-3, "/Hr")
						(p "$,$$$,$$9.v99", a (3));
					end;
				     end;
			     end;
			end;
		end;
	     end;
	if reg_rates > 0 | disk_rates > 0
	then do;
		call print_centered (2, "O__t_h_e_r R__a_t_e_s");
		put skip;
		if disk_rates > 0
		then put edit (disk_rates * 2592e3 + 5e-3, "/disk-page per month (", disk_rates, "/page-second )")
			(skip, x (35), p "$$$,$$9.v99", a, e (16), a);
		if reg_rates > 0
		then put edit (reg_rates, " per month registration fee per user") (skip, x (42), p "$$$,$$9.v99", a);
	     end;
	call print_centered (3, "The current shift schedule is:");
	put edit ("Shift", "Hours", "Days") (skip (2), x (44), a (5), x (3), a (5), x (5), a (4));
	put skip;
	do shift = 0 to 7;
	     this_shift_used = "0"b;
	     do day = 1 to 7;
		cur_shft = -2;
		do time = 0 to 47;
		     if shifts (day, time) = shift & cur_shft ^= shift
		     then do;
			     start_time = time;
			     cur_shft = shift;
			end;
		     if (shifts (day, time) ^= shift | time = 47) & cur_shft = shift
		     then do;
			     if shifts (day, time) = shift
			     then end_time = time;
			     else end_time = time - 1;
			     cur_shft = -2;
			     do time2 = start_time to end_time;
				shifts (day, time2) = -1;
			     end;
			     if ^this_shift_used
			     then do;
				     this_shift_used = "1"b;
				     put edit (shift) (skip, x (46), p "9");
				end;
			     put edit (start_time / 2, mod (start_time, 2) * 30, "-", (end_time + 1) / 2,
				mod (end_time + 1, 2) * 30) (col (51), 2 p "99", a (1), 2 p "99");
			     put edit (day_names (day)) (x (3), a);
			     do day2 = day + 1 to 7;
				match = "1"b;
				do time2 = start_time to end_time;
				     if shifts (day2, time2) ^= shift
				     then match = "0"b;
				end;
				if match
				then if start_time ^= 0
				     then if shifts (day2, start_time - 1) = shift
					then match = "0"b;
				if match
				then if end_time ^= 47
				     then if shifts (day2, end_time + 1) = shift
					then match = "0"b;
				if match
				then do;
					put edit (",", day_names (day2)) (a, a);
					do time2 = start_time to end_time;
					     shifts (day2, time2) = -1;
					end;
				     end;
			     end;
			end;
		end;
	     end;
	end;
     end rates_and_shifts;

footnote:
     proc (short_date);

/* this procedure checks to see if a segment named usage_and_revenue_footnote exists in the working directory.
   If it does, its contents are printed following the report.
   Parameter:
   short_date - input - date to be printed at top of each page. */
dcl	null		builtin;
dcl	note		char (nl) based (np),
	nl		fixed bin,
	np		ptr,
	(i, j)		fixed bin,
	bit_count		fixed bin (24),
	ec		fixed bin (35),
	short_date	char (8),
	NL		char (1) init ("
");
dcl	get_wdir_		entry returns (char (168));
dcl	initiate_file_	entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35))
			;
dcl	terminate_file_	entry (pointer, fixed binary (24), bit (*), fixed binary (35));

	call initiate_file_ (get_wdir_ (), "usage_and_revenue_footnote", R_ACCESS, np, bit_count, ec);
	if ec ^= 0
	then return;
	nl = divide (bit_count, 9, 17, 0);
	put edit (short_date, "Page", pageno (sysprint)) (page, a (8), col (127), a (4), p "z9");
	put skip (3);
	j = 1;
	do i = 1 to nl;
	     if substr (note, i, 1) = NL
	     then do;
		     put edit (substr (note, j, i - j)) (skip, x (15), a (i - j));
		     j = i + 1;
		end;
	     else if i - j > 100
	     then do;
		     put edit (substr (note, j, i - j + 1)) (skip, x (15), a (i - j + 1));
		     j = i;
		end;
	end;
	call terminate_file_ (np, (0), TERM_FILE_TERM, (0));
     end;

clean_up:
     proc (use_totals_ptr, xtotp, gptr);

/* This procedure terminates the use_totals segments, deletes the temporary
   segment used for groups and prints a final CR.
   Parameters:
   use_totals_ptr,xtotp - input - pointer to use_totals segment to be terminated
   gptr - input - pointer to temporary segment to be deleted */

dcl	(use_totals_ptr, xtotp, gptr)
			ptr;

dcl	ec		fixed bin (35);
dcl	terminate_file_	entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl	release_temp_segment_
			entry (character (*), pointer, fixed binary (35));

	if use_totals_ptr ^= null ()
	then call terminate_file_ (use_totals_ptr, (0), TERM_FILE_TERM, ec);
	if xtotp ^= null ()
	then call terminate_file_ (xtotp, (0), TERM_FILE_TERM, ec);
	if gptr ^= null ()
	then call release_temp_segment_ (ME, gptr, ec);
	if P_ptr ^= null ()
	then free P;
	P_ptr = null ();
	put file (sysprint) skip;
	close file (sysprint);
     end clean_up;

format_time:
     proc (time) returns (char (*));

/* this procedure returns a character representation of the time, formatted slightly differently from the way
   that date_time_ formats it.
   Parameter:
   time -input - system clock time */

dcl	time		fixed bin (71),
	date_time_str	char (24),
	date		char (9) def date_time_str pos (1),
	stime		char (4) def date_time_str pos (11),
	day		char (4) def date_time_str pos (21);
dcl	date_time_	entry (fixed bin (71), char (*));

	call date_time_ (time, date_time_str);
	return (date || stime || day);
     end format_time;

print_centered:
     proc (skips, string);

/* print_centered prints one line which consists of the input parameter "string" centered on a
   132-character line with "skips" NL's at the beginning of the line.
   Parameters:
   skips - input - # of NL's
   string - input - string to be centered and printed */

dcl	string		char (*),			/* input parameter */
	skips		fixed bin;
dcl	(i, j, k, l)	fixed bin;
dcl	(verify, length, reverse, translate)
			builtin;

dcl	BS		char (1) init ("");		/* backspace */
dcl	non_print		char (32) /* All control characters from octal 0 to octal 40 except
						   backspace */ init ("
  ");


	i = verify (string, non_print);		/* ignore leading blanks and control characters */
	if i = 0
	then do;					/* if there are no printable characters then print
						   a blank line and return */
		put file (sysprint) skip (skips);
		return;
	     end;
	j = length (string) - verify (reverse (string), non_print) + 1;
	l = j - i + 1;				/* length of string without leading and trailing blanks and
						   control characters */
	do k = i to j;
	     if substr (string, k, 1) = BS
	     then l = l - 2;			/* subtract 2 from length for each backspace in the string */
	end;					/* print the line, substituting blanks for all
						   control characters in the string */
	put file (sysprint) skip (skips)
	     edit (translate (substr (string, i, j - i + 1), "", non_print)) (x (66 - l / 2), a);
     end print_centered;
     end usage_and_revenue;




		    usage_total.pl1                 08/29/88  0947.9rew 08/29/88  0858.8      102141



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

/* format: style3 */
/* Modified 1984-08-31 BIM for v3 use_totals */

/****^  HISTORY COMMENTS:
  1) change(86-10-15,Parisek), approve(87-06-17,MCR7570),
     audit(87-06-15,Hirneisen), install(87-08-06,MR12.1-1066):
     Suppress error reporting of a non existent pdt of a renamed project.
  2) change(88-04-27,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-04,Lippard), install(88-08-29,MR12.2-1093):
      A) Add misc charges from projfile into use_totals.dollar_charge, in
         addition to summing them in the misc field. (as 471, phx19221)
                                                   END HISTORY COMMENTS */

usage_total:
     procedure options (variable);

/* program to clear all usage in pdt's */

dcl	satp		ptr,			/* pointer to the sat */
	pdtp		ptr,			/* pointer to the pdt */
	pp		ptr,			/* ptr to projfile */
	satep		ptr,			/* ptr to sat entry */
	pdtep		ptr,			/* ptr to pdt entry  */
	ap		ptr,
	dtemp		fixed bin (71),
	ftemp		float bin,
	disk_price	float bin,
	al		fixed bin (21),
	(sat_dir, pdtdir, tot_dir, projfile_dir)
			char (168),
	(sat_ename, projfile_ename, tot_ename, pdt_ename)
			char (32);

dcl	arg		char (al) based (ap);

dcl	error_table_$unimplemented_version
			fixed bin (35) ext static;

dcl absolute_pathname_ entry (character (*), character (*), fixed binary (35));
dcl	expand_pathname_$add_suffix
			entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	com_err_		entry options (variable);
dcl	com_err_$suppress_name
			entry () options (variable);
dcl	initiate_file_	entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35))
			;
dcl	terminate_file_	entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl	pathname_		entry (character (*), character (*)) returns (character (168));
dcl	system_info_$prices_rs
			entry (fixed bin, (0:7) float bin, (0:7) float bin, (0:7) float bin, (0:7) float bin,
			float bin, float bin);

dcl	(addr, null, rtrim, clock)
			builtin;

dcl	ec		fixed bin (35),
	t		fixed bin,		/* user type index */
	(i, j, k)		fixed bin;
declare	arg_count		fixed bin;
declare	ME		char (32) init ("usage_total") int static options (constant);
declare	cleanup		condition;

%page;
%include terminate_file;
%include access_mode_values;
%include sat;
%include pdt;
%include projfile;
%include use_totals;
%include user_attributes;


	satp, pdtp, use_totals_ptr, pp = null ();
	on cleanup call clean_up;
	call cu_$arg_count (arg_count, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME);
		return;
	     end;
	if arg_count ^= 4
	then do;
		call com_err_$suppress_name (0, ME,
		     "Usage: usage_totals SAT_path PDT_dir_path PROJFILE_path USE_TOTALS_path");
		return;
	     end;

	call cu_$arg_ptr (1, ap, al, (0));
	call expand_pathname_$add_suffix (arg, "", sat_dir, sat_ename, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "Invalid sat pathname ^a.", arg);
		go to ERROR;
	     end;
	call initiate_file_ (sat_dir, sat_ename, R_ACCESS, satp, (0), ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a.", pathname_ (sat_dir, sat_ename));
		go to ERROR;
	     end;
	call cu_$arg_ptr (2, ap, al, (0));
	call absolute_pathname_ (arg, pdtdir, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "Invalid PDT directory pathname ^a.", arg);
		go to ERROR;
	     end;
	call cu_$arg_ptr (3, ap, al, (0));
	call expand_pathname_$add_suffix (arg, "", projfile_dir, projfile_ename, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "Invalid projfile pathname ^a.", arg);
		go to ERROR;
	     end;
	call initiate_file_ (projfile_dir, projfile_ename, R_ACCESS, pp, (0), ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a", pathname_ (projfile_dir, projfile_ename));
		goto ERROR;
	     end;

	call cu_$arg_ptr (4, ap, al, (0));
	call expand_pathname_$add_suffix (arg, "use_totals", tot_dir, tot_ename, ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "Invalid use totals pathname ^a.", arg);
		go to ERROR;
	     end;
	call initiate_file_ (tot_dir, tot_ename, RW_ACCESS, use_totals_ptr, (0), ec);
	if ec ^= 0
	then do;
		call com_err_ (ec, ME, "^a", pathname_ (tot_dir, tot_ename));
		go to ERROR;
	     end;
	if use_totals.version ^= USE_TOTALS_VERSION_3
	then do;
		call com_err_ (error_table_$unimplemented_version, ME, "^a is version 2, but it should be version 3.",
		     pathname_ (tot_dir, tot_ename));
		go to ERROR;
	     end;

	use_totals.generated = clock ();
	use_totals.period_begin = clock ();
	use_totals.period_end = 0;
	use_totals.total_cpu = 0;			/* Recalculate this. */
	do t = 1 to use_totals.ntypes;
	     use_totals.ut (t).dollar_charge = 0e0;
	     use_totals.ut (t).logins = 0;
	     use_totals.ut (t).crashes = 0;
	     use_totals.ut (t).nproj = 0;
	     use_totals.ut (t).nusers = 0;
	     use_totals.ut (t).disk_psec = 0;
	     use_totals.ut (t).disk_quota = 0;
	     use_totals.ut (t).disk_usage = 0;
	     use_totals.ut (t).misc = 0e0;
	     do i = 0 to 7;
		use_totals.ut (t).interactive (i).charge = 0e0;
		use_totals.ut (t).interactive (i).cpu = 0;
		use_totals.ut (t).interactive (i).core = 0;
		use_totals.ut (t).interactive (i).connect = 0;
		use_totals.ut (t).interactive (i).io_ops = 0;
	     end;
	     do i = 1 to 4;
		use_totals.ut (t).absentee (i).charge = 0e0;
		use_totals.ut (t).absentee (i).jobs = 0;
		use_totals.ut (t).absentee (i).cpu = 0;
		use_totals.ut (t).absentee (i).memory = 0;
	     end;
	     do i = 1 to 4;
		use_totals.ut (t).iod (i).charge = 0e0;
		use_totals.ut (t).iod (i).pieces = 0;
		use_totals.ut (t).iod (i).pages = 0;
		use_totals.ut (t).iod (i).lines = 0;
	     end;
	     do i = 1 to 16;
		use_totals.ut (t).devices (i) = 0e0;
	     end;
	end;

	do j = 1 to satp -> sat.current_size;
	     satep = addr (satp -> sat.project (j));
	     if project.state = 0 | project.state = 3	/* skip renamed project also to suppress error messages */
	     then go to endloop1;

	     pdt_ename = rtrim (project.project_id) || ".pdt";

	     do i = 1 to use_totals.n_select;		/* classify project into bin */
		if select_proj (i) = project.project_id
		then do;
			t = select_ut (i);
			go to scan3;
		     end;
	     end;
	     t = 1;
scan3:
	     use_totals.ut (t).nproj = use_totals.ut (t).nproj + 1;

	     call system_info_$prices_rs ((project.rs_number), (0), (0), (0), (0), disk_price, (0));

	     do i = 1 to projfile.nproj;		/* look up project disk usage */
		if projfile.id (i) = project.project_id
		then do;
			use_totals.ut (t).disk_quota = use_totals.ut (t).disk_quota + projfile.disk_quota (i);
			use_totals.ut (t).disk_usage = use_totals.ut (t).disk_usage + projfile.disk_use (i);
			dtemp = projfile.disk_psec (i);
			use_totals.ut (t).disk_psec = use_totals.ut (t).disk_psec + dtemp;
			ftemp = disk_price * dtemp;
			use_totals.ut (t).dollar_charge = use_totals.ut (t).dollar_charge + ftemp;
			use_totals.ut (t).misc = use_totals.ut (t).misc + projfile.misc_charges (i);
			use_totals.ut (t).dollar_charge = use_totals.ut (t).dollar_charge + projfile.misc_charges (i);
			go to getpdt;
		     end;
	     end;
	     call com_err_ (0, ME, "Projfile entry missing for ^a", project.project_id);

getpdt:
	     call initiate_file_ (pdtdir, pdt_ename, RW_ACCESS, pdtp, (0), ec);
	     if ec ^= 0
	     then do;
		     call com_err_ (ec, ME, "^a", pathname_ (pdtdir, pdt_ename));
		     go to endloop1;
		end;

	     do k = 1 to pdtp -> pdt.current_size;	/* loop on users in project */
		pdtep = addr (pdtp -> pdt.user (k));
		if user.state = 0
		then go to endloop;

		if user.state = 1
		then /* Find out when month began. */
		     if user.time_last_reset ^= 0
		     then if user.time_last_reset < use_totals.period_begin
			then use_totals.period_begin = user.time_last_reset;
		if user.last_update > use_totals.period_end
		then if user.last_update < use_totals.generated
		     then use_totals.period_end = user.last_update;
		     else user.last_update = use_totals.generated;

		use_totals.ut (t).nusers = use_totals.ut (t).nusers + 1;
		use_totals.ut (t).dollar_charge = use_totals.ut (t).dollar_charge + user.dollar_charge;
		use_totals.ut (t).logins = use_totals.ut (t).logins + user.logins;
		use_totals.ut (t).crashes = use_totals.ut (t).crashes + user.crashes;
		do i = 0 to 7;
		     use_totals.ut (t).interactive (i).charge =
			use_totals.ut (t).interactive (i).charge + user.interactive (i).charge;
		     use_totals.ut (t).interactive (i).cpu =
			use_totals.ut (t).interactive (i).cpu + user.interactive (i).cpu;
		     use_totals.total_cpu = use_totals.total_cpu + user.interactive (i).cpu;
		     use_totals.ut (t).interactive (i).core =
			use_totals.ut (t).interactive (i).core + user.interactive (i).core;
		     use_totals.ut (t).interactive (i).connect =
			use_totals.ut (t).interactive (i).connect + user.interactive (i).connect;
		     use_totals.ut (t).interactive (i).io_ops =
			use_totals.ut (t).interactive (i).io_ops + user.interactive (i).io_ops;
		end;
		do i = 1 to 4;
		     use_totals.ut (t).absentee (i).charge =
			use_totals.ut (t).absentee (i).charge + user.absentee (i).charge;
		     use_totals.ut (t).absentee (i).jobs =
			use_totals.ut (t).absentee (i).jobs + user.absentee (i).jobs;
		     use_totals.ut (t).absentee (i).cpu = use_totals.ut (t).absentee (i).cpu + user.absentee (i).cpu;
		     use_totals.total_cpu = use_totals.total_cpu + user.absentee (i).cpu;
		     use_totals.ut (t).absentee (i).memory =
			use_totals.ut (t).absentee (i).memory + user.absentee (i).memory;
		end;
		do i = 1 to 4;
		     use_totals.ut (t).iod (i).charge = use_totals.ut (t).iod (i).charge + user.iod (i).charge;
		     use_totals.ut (t).iod (i).pieces = use_totals.ut (t).iod (i).pieces + user.iod (i).pieces;
		     use_totals.ut (t).iod (i).pages = use_totals.ut (t).iod (i).pages + user.iod (i).pages;
		     use_totals.ut (t).iod (i).lines = use_totals.ut (t).iod (i).lines + user.iod (i).lines;
		end;
		do i = 1 to 16;
		     use_totals.ut (t).devices (i) = use_totals.ut (t).devices (i) + user.devices (i);
		end;

endloop:
	     end;
	     call terminate_file_ (pdtp, (0), TERM_FILE_TERM, (0));

endloop1:
	end;

ERROR:
	call clean_up;
	return;



clean_up:
     procedure;

	if pdtp ^= null ()
	then call terminate_file_ (pdtp, (0), TERM_FILE_TERM, (0));
	if pp ^= null ()
	then call terminate_file_ (pp, (0), TERM_FILE_TERM, (0));
	if use_totals_ptr ^= null ()
	then call terminate_file_ (use_totals_ptr, (0), TERM_FILE_TERM, (0));
	if satp ^= null ()
	then call terminate_file_ (satp, (0), TERM_FILE_TERM, (0));
	return;
     end clean_up;

     end usage_total;




		    value.pl1                       11/12/82  1412.9rew 11/12/82  1111.7       43308



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


value: proc;

dcl  en char (32) aligned int static,
     dn char (168) aligned int static,
     segptr ptr int static init (null),
     ap ptr, al fixed bin, bchr char (al) unal based (ap),
     answer char (32) varying,
     bvcs char (al) varying based (ap),
     ec fixed bin,
     i fixed bin,
     string char (168) aligned;

dcl (null, substr, addr, min) builtin;

dcl  com_err_ entry options (variable),
     adjust_bit_count_ entry (char (*) aligned, char (*) aligned, bit (1), fixed bin (24), fixed bin (17)),
     get_wdir_ entry () returns (char (168) aligned),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
     active_fnc_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     cu_$af_arg_count entry (fixed bin, fixed bin),
     cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin),
     error_table_$wrong_no_of_args fixed bin ext,
     hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (5), ptr, fixed bin),
     ioa_ entry options (variable);

dcl 1 valueseg based (segptr) aligned,
    2 laste fixed bin,
    2 freep fixed bin,
    2 pad (6) fixed bin,
    2 arry (14506),
      3 name char (32),
      3 valu char (32),
      3 lth fixed bin,
      3 chain fixed bin;

/* ========================================= */

	if segptr = null then do;

	     dn = get_wdir_ ();
	     en = "value_seg";
	     call hcs_$initiate (dn, en, "", 0, 1, segptr, ec);
	     if segptr = null then do;
aer:		call active_fnc_err_ (ec, "value", "^a>^a", dn, en);
		return;
	     end;
	end;

	call cu_$af_arg_count (i, ec);
	if ec ^= 0 then go to aer;
	if i ^= 1 then do;
	     ec = error_table_$wrong_no_of_args;
	     go to aer;
	end;
	call cu_$af_arg_ptr (1, ap, al, ec);
	if ec ^= 0 then go to aer;

	do i = 1 to laste;
	     if chain (i) = 0 then if name (i) ^= "" then
		     if bchr = name (i) then go to found;
	end;
	answer = "undefined!";
	go to give;

found:	answer = substr (valu (i), 1, lth (i));
give:	call cu_$af_return_arg (i, ap, al, ec);
	if ec ^= 0 then go to aer;
	bvcs = answer;
	return;

/* ---------------------------------- */

set:	entry;

	if segptr = null then do;
	     dn = get_wdir_ ();
	     en = "value_seg";
	     call hcs_$initiate (dn, en, "", 0, 1, segptr, ec);
	     if segptr = null then do;
er:		call com_err_ (ec, "value", "^a>^a", dn, en);
		return;
	     end;
	end;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then go to er;
	string = bchr;

	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then do;
	     do i = 1 to laste;
		if string = name (i) then do;
		     chain (i) = freep;
		     freep = i;
		     name (i) = "";
		end;
	     end;
	     return;
	end;

	do i = 1 to laste;
	     if chain (i) = 0 then if name (i) ^= "" then
		     if name (i) = string then do;
			go to f1;
		     end;
	end;
	if freep = 0 then i, laste = laste + 1;
	else do;
	     i = freep;
	     freep = chain (i);
	end;
	name (i) = string;
f1:	valu (i) = bchr;
	chain (i) = 0;
	lth (i) = min (al, 32);

	call adjust_bit_count_ (dn, en, "0"b, (0), ec);

	return;

/* ----------------------------------- */

set_seg:	entry;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then go to er;
	string = bchr;
	call expand_path_ (addr (string), al, addr (dn), addr (en), ec);
	if ec ^= 0 then go to er;
	call hcs_$initiate (dn, en, "", 0, 1, segptr, ec);
	if segptr = null then do;
	     call hcs_$make_seg (dn, en, "", 1011b, segptr, ec);
	     if segptr = null then go to er;
	     call ioa_ ("value: Creating ^a>^a", dn, en);
	end;
	return;

/* ------------------------------------------ */

dump:	entry;

	if segptr = null then do;
	     dn = get_wdir_ ();
	     en = "value_seg";
	     call hcs_$initiate (dn, en, "", 0, 1, segptr, ec);
	     if segptr = null then go to er;
	end;

	call cu_$arg_ptr (1, ap, al, ec);
	do i = 1 to laste;
	     if name (i) = "" then go to nop;
	     if chain (i) = 0 then do;
		if ec = 0 then if name (i) ^= bchr then go to nop;
		call ioa_ ("^-^a^-^a", name (i), substr (valu (i), 1, lth (i)));
	     end;
nop:	end;
	call ioa_ ("");

     end;



		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
