



		    act_ctl_.pl1                    10/21/92  1609.2rew 10/21/92  1607.2      748935



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1992   *
        *                                                         *
        * 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: style4 */
act_ctl_: proc (p);

/* ACT_CTL_ - this procedure keeps records of usage for the system.
   The usage data for each user is stored in his PDT entry.
   Limits also in the PDT entry are checked and the user may be bumped.

   Special handling is given to the PDT entry for Initializer.SysDaemon.
   It contains the total system uptime, and the initializer process CPU usage.

   There are the following entries:

   act_ctl_$init			called when the system is brought up
   act_ctl_$open_account		called from "dialup_" when user identified
   .				.. this entrypoint makes an entrypoint in the accounting file
   act_ctl_$close_account		called from "dialup_" when user signs off.
   act_ctl_$cp			called from "dialup_" when process created (reset ate, check limit)
   act_ctl_$dp			called from "dialup_" when process destroyed (totals cputime)
   act_ctl_$check			called from "lg_ctl_" for permission to log user in
   act_ctl_$update			called every 15 minutes by event channel to update cpu time
   act_ctl_$shift_cmnd_update		called by shift command to do accounting update and switch to new shift
   act_ctl_$act_ctl_close		called when system shuts down

   There are also entrypoints to call from the console for testing.

   act_ctl_$act_ctl_disable		turns off charging
   act_ctl_$act_ctl_reable		turns it on again

*/

/* Originally coded by E. Stone, 9/25/69 */
/* Modified by J. Grochow, 10/10 to fix bugs */
/* Modified by J. Grochow to accept daemon calls, 1/21/70 */
/* Modified by J. Grochow to automatic update, 3/1/70 */
/* Converted to pl1 and modified by J. Grochow, 4/12/70 */
/* Modified some more by J. Grochow, 7/8/70 */
/* new user control 8/10/70 JMG */
/* Inactive check 9/2/70 JMG, whotab THVV */
/* daemon accounting 11/70 JMG */
/* metering 3/71 THVV */
/* modified for absentee 6/71 EDS */
/* new accounting 2/72 THVV */
/* 6180 version, as_error_table_, rework absentee, fix bugs, virtual cpu + frankstons 1/73 THVV */
/* Modified 741226 by PG for audit msgs */
/* Modified May 1976 by T. Casey to implement shift command and per-user cutoff warning thresholds */
/* Modified 760819 by Roy Planalp to respect -brief flag, to pass text of
   error msg to lg_ctl_, and to give user some grace when bumping for inactivity */
/* Modified 770623 by Robert Coren to not use obsolete terminal type fields in ATE */
/* Modified August 1977 by T. Casey to call device_acct_$broom when destroying
   a process, and to not leave event calls masked if unable to lock pdte. */
/* Modified May 1978 by T. Casey to pass old shift to load_ctl_$set_max_units */
/* Modified November 1978 by T. Casey for new absentee control parameters */
/* Modified April 1979 by T. Casey for MR7.0a to fix bugs in foreground absentee implementation. */
/* Modified August 1979 by T. Casey for MR8.0 for session cost and process preservation across hangups. */
/* shift change looping bug fixed December 1979, Ch Hornig */
/* Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures (UNCA). */
/* Modified March 1980 by T. Casey to add metering. */
/* Modified June 1981 by E. N. Kittlitz for UNCA rate structures */
/* Modified June 1981 by T. Casey for MR9.0 for new wakeup priorities. */
/* Modified November 1981, E. N. Kittlitz.  user_table_entry conversion. */
/* Modified December 1981, E. N. Kittlitz.  user_warn controls */
/* Modified May 1982, E. N. Kittlitz. New AS initialization. */
/* Modified September 1982, E. N. Kittlitz. publish more stuff in answer_table */
/* Modified 1984-07-12 BIM for login authorization ranges. */
/* Modified 1985-01-11 by E. Swenson for new A.S. auditing */
/* Modified 1985-01-21, BIM: proper any_other handler. */
/* Modified 1985-03-28, E. Swenson to handle damaged PDTs at as
   initialization.
*/

/****^  HISTORY COMMENTS:
  1) change(86-04-04,Herbst), approve(87-07-13,MCR7697),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
     Changed write_message proc to call asu_$blast_user.
  2) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  3) change(86-05-20,Gilcrease), approve(86-05-22,MCR7369),
     audit(86-06-23,LJAdams), install(86-06-30,MR12.0-1081):
               Allow "weekly" cutoffs. SCP6250.
  4) change(86-08-03,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Moved code for printing "Your authorization is..." to dialup_ so that this
     message can be displayed upon process reconnection. (Actual change date
     was 85-08-03)
  5) change(87-02-24,Brunelle), approve(87-07-13,MCR7697),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
     Changed activity_unbump entrypoint to use installation_parms.warning_time
     instead of installation_parms.update_time when making check for inactivity
     since bump was scheduled.
  6) change(87-04-06,Brunelle), approve(87-07-13,MCR7697),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
     Added statements to set anstbl.current_time = clock () to the following
     entrypoints: check, cp and activity_unbump.
  7) change(87-04-09,Brunelle), approve(87-07-13,MCR7694),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
     Set the value of system_area_ptr prior to passing it to
     network_accounting_.
  8) change(87-04-27,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-22,Brunelle), install(87-08-03,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  9) change(87-05-06,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-22,Brunelle), install(87-08-03,MR12.1-1055):
     When mode = "test", call network_accounting_gate_$test.
 10) change(87-05-11,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-22,Brunelle), install(87-08-03,MR12.1-1055):
      A) Replace use of literals with named constants when referencing
         ute.active.
      B) Replace use of literals with named constants when referencing
         ute.process_type.
 11) change(87-05-14,Brunelle), approve(87-07-13,MCR7697),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
      A) Add inactivity stabilization time of 200 milliseconds to inactivity
         unbump check.
 12) change(87-05-14,Brunelle), approve(87-07-13,MCR7694),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
      A) Add code to display any NAT records not used in accounting update.
 13) change(87-06-11,Brunelle), approve(87-07-13,MCR7694),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
      A) Added code to check any unused net accting records after to call to
         $get_process_total.
 14) change(87-06-28,GDixon), approve(87-07-13,MCR7694),
     audit(87-07-22,Brunelle), install(87-08-03,MR12.1-1055):
      A) Correct error messages printed after calls to
         network_accounting_gate_.
      B) Avoid signalling sub_error_ if network accounting initialization
         fails.
 15) change(87-07-22,Brunelle), approve(87-07-22,MCR7694),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
      A) Remove call to initialize network accounting.  It will go in
         ls_server_request.
      B) Conditionalize network accounting calls and update of data based on
         anstbl.login_server_present.
 16) change(87-07-22,Brunelle), approve(87-07-22,MCR7741),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
      A) Correct error message documentation.
      B) Remove entrypoints which are no longer called ($login_message &
         $act_ctl_noupdate)
 17) change(87-07-22,Brunelle), approve(87-07-22,MCR7697),
     audit(87-07-27,GDixon), install(87-08-03,MR12.1-1055):
     Add code to cause an inactive disconnected process to be bumped
     immediately instead of going through the normal warning sequence.
 18) change(87-07-28,Brunelle), approve(87-07-28,MCR7694),
     audit(87-07-28,GDixon), install(87-08-03,MR12.1-1055):
     Change so debug_na entrypoint calls network_accounting_gate_$debug to turn
     on inner ring debugging.
 19) change(87-07-31,Brunelle), approve(87-07-31,MCR7694),
     audit(87-08-01,GDixon), install(87-08-03,MR12.1-1055):
     Check version from network accounting.
 20) change(87-08-06,GDixon), approve(87-08-06,MCR7694),
     audit(87-08-06,Brunelle), install(87-08-06,MR12.1-1064):
     Set network_account_array_ptr to null before testing to see if the login
     server is present.  Otherwise, the ptr never gets set but is tested in a
     variety of places.
 21) change(87-08-12,Brunelle), approve(87-08-12,MCR7694),
     audit(87-08-12,GDixon), install(87-08-13,MR12.1-1085):
     Correct call to as_meter_$exit with NETUP_METER when no equivalent call
     to as_meter_$enter has occurred.
 22) change(92-08-28,Schroth), approve(92-10-14,MCR8263), audit(92-10-15,Vu),
     install(92-10-21,MR12.5-1038):
     Correctly update whotab.next_shift_change_time when a manually set shift
     crosses a defined shift boundary into the same shift as that set by the
     operator shift command.  phx21344.
                                                   END HISTORY COMMENTS */

/* parameters */

dcl  p ptr parameter;


/* constants */

dcl  INACTIVITY_STABILIZATION_TIME fixed bin (71) int static options (constant) init (200000);
dcl  MICROSECONDS_PER_HOUR fixed bin (35) int static options (constant) init (3600000000);
dcl  MICROSECONDS_PER_MINUTE float bin (63) int static options (constant) init (6.0e7);
dcl  MICROSECONDS_PER_WEEK fixed bin (71) int static options (constant) init (604800000000);
dcl  MILLION fixed bin (35) int static options (constant) init (1000000);
dcl  NEVER fixed bin (71) init (9435484800000000) internal static options (constant);
						/* This date is 12/31/2199 0000. GMT */

/* .. if Multics last this long we will have to fix */
dcl  NL char (1) int static options (constant) init ("
");
dcl  OPEN float bin init (1e37) internal static options (constant);
dcl  QNAME (0:4) char (4) int static options (constant) init (
	"Q FG",
	"Q 1",
	"Q 2",
	"Q 3",
	"Q 4");
dcl  TOLERANCE float bin (63) int static options (constant) init (0.05);
						/* Amount of discrepancy which will be ignored; 3 minutes/hour */


/* Internal Static */

dcl  alarmfail fixed bin int static init (0);		/* set when alarm clock failure detected */
dcl  initializer_pdtep ptr int static init (null);	/* ptr to initializer PDT entry */
dcl  last_update_interval fixed bin (71) internal static;	/* interval used to set timer */
dcl  mode char (4) aligned int static init ("norm");
dcl  next_update fixed bin (71) int static;		/* time for next update */
dcl  static_label label int static;			/* Label used if fault in update. */
dcl  static_nlogins fixed bin int static;		/* Total sessions since startup. */
dcl  static_total_dollar_charge float bin int static;	/* Total billed since startup. */
dcl  static_total_time_charged fixed bin (71) int static;	/* Total CPU time charged. */
dcl  system_area_ptr ptr int static init (null);
dcl  updatetime fixed bin (71) int static;		/* time update last performed */


/* Entries */

dcl  act_ctl_$update entry;
dcl  adjust_cutoff_ entry (ptr, fixed bin (71));
dcl  as_any_other_handler_ entry (character (*), entry, label, label);
dcl  as_meter_ entry (fixed bin (71), fixed bin (71), fixed bin (71), float bin, fixed bin, float bin, float bin, float bin);
dcl  as_meter_$as_meter_init entry (fixed bin (71), fixed bin, fixed bin (71), fixed bin (71));
dcl  as_meter_$as_meter_stop entry;
dcl  as_meter_$enter entry (fixed bin);
dcl  as_meter_$exit entry (fixed bin);
dcl  as_meter_$exit_values entry (fixed bin, fixed bin (34), fixed bin (71), fixed bin (71));
dcl  asu_$blast_user entry (ptr, char (*), char (*), fixed bin (35));
dcl  asu_$bump_code entry (ptr, fixed bin (35), char (8) aligned, fixed bin (35), fixed bin);
dcl  asu_$bump_user entry (ptr, char (*), fixed bin (35), fixed bin);
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cu_$arg_count entry (fixed bin);
dcl  date_time_ entry (fixed bin (71), char (*));
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_$next_shift_change entry (fixed bin (71), fixed bin (71), fixed bin, fixed bin);
dcl  datebin_$revert entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71));
dcl  device_acct_$broom entry (ptr);
dcl  device_acct_$update entry (ptr);
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$wakeup entry (bit (*) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  hphcs_$process_status entry (ptr);
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_$rs entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl  ipc_$mask_ev_calls entry (fixed bin (35));
dcl  ipc_$unmask_ev_calls entry (fixed bin (35));
dcl  load_ctl_$load_level entry (fixed bin, float bin);
dcl  load_ctl_$set_maxunits entry (fixed bin);
dcl  network_accounting_gate_$debug entry (bit (1));
dcl  network_accounting_gate_$get_process_total entry (bit (36) aligned, ptr, ptr, char (*), fixed bin (35));
dcl  network_accounting_gate_$read_and_reset_table entry (ptr, ptr, char (*), fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
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  sub_err_ entry () options (variable);
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));


/* External Static */

dcl  (as_error_table_$cut_proj_date,
     as_error_table_$cut_proj_funds,
     as_error_table_$cut_proj_other,
     as_error_table_$cut_user_cut_msg,
     as_error_table_$cut_user_date_msg,
     as_error_table_$cut_user_mlim_msg,
     as_error_table_$cut_user_shift_msg,
     as_error_table_$inactive,
     as_error_table_$proj_low_funds,
     as_error_table_$user_warn_days,
     as_error_table_$user_warn_funds,
     as_error_table_$user_warn_pct,
     as_error_table_$warn_proj_date) fixed bin (35) ext;

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


/* Automatic */

dcl  absda fixed bin;				/* variable used with datebin_ */
dcl  asmtep ptr;
dcl  code fixed bin (35);				/* error codes */
dcl  coredelta fixed bin (71);			/* Memory usage since last update. */
dcl  cost float bin;				/* Dollar charge since last update. */
dcl  cpudelta fixed bin (71);				/* CPU since last update. */
dcl  crash_clock fixed bin (71);			/* used during init */
dcl  cur_rs_ptr ptr;
dcl  dd fixed bin;					/* variable used with datebin_ */
dcl  did_charge float bin (63);			/* for computing accounting errors */
dcl  discrepancy float bin (63);			/* for computing accounting errors */
dcl  ec fixed bin (35);				/* err code */
dcl  error_message char (500);			/* returned by subroutines */
dcl  format char (100) aligned;
dcl  hh fixed bin;					/* variable used with datebin_ */
dcl  hrs fixed bin;					/* format variable for logout message */
dcl  i fixed bin;					/* temp */
dcl  icode char (4);				/* ... id code */
dcl  interactive_signal char (8);
dcl  io_ops_delta fixed bin (71);			/* IO ops on terminal since last update. */
dcl  j fixed bin;					/* temp */
dcl  jobid char (32);				/* ... */
dcl  line char (168);				/* Format variable. */
dcl  logdelta fixed bin (71);				/* Connect since last update. */
dcl  mcode fixed bin (35);				/* message code */
dcl  mel float bin;
dcl  mhh float bin;
dcl  mins fixed bin (17);
dcl  minute fixed bin;				/* variable used with datebin_ */
dcl  mlth fixed bin;				/* Length of message. */
dcl  mm fixed bin;					/* variable used with datebin_ */
dcl  mqu float bin;
dcl  mrs float bin;					/* estimated response */
dcl  mtc fixed bin (71);				/* metering variable */
dcl  mti fixed bin (71);				/* metering variable */
dcl  mui fixed bin (71);				/* metering variable */
dcl  mws fixed bin;					/* ... page meter */
dcl  ncrash fixed bin;				/* used in determining how many left on */
dcl  nolog bit (1) aligned;				/* Used by check. TRUE if no login. */
dcl  pagefaults fixed bin (34);
dcl  pdtep ptr;					/* ptr to user pdt entry, for new accounting */
dcl  pdtn char (32);				/* name of pdt  */
dcl  pdtp ptr;					/* ptr to user pdt */
dcl  real_time fixed bin (71);
dcl  satep ptr;					/* ptr to sat entry for user project */
dcl  sd_ptr ptr;					/* ptr to SysDaemon sate */
dcl  secs fixed bin (17);
dcl  shf fixed bin;					/* variable used with datebin_ */
dcl  short char (8) aligned;				/* junk */
dcl  should_charge float bin (63);			/* for computing accounting errors */
dcl  some_time_ago fixed bin (71);			/* If has been blocked since before here, bump */
dcl  sss fixed bin;					/* variable used with datebin_ */
dcl  total_dsa_charges float bin;
dcl  ttykind char (32);				/* ... */
dcl  vcpu_time fixed bin (71);
dcl  wkd fixed bin;					/* variable used with datebin_ */
dcl  yy fixed bin;					/* variable used with datebin_ */


/* Automatic Structures */

dcl  1 abs_signal aligned,				/* Wakeup message sent when bumping absentee user */
       2 type char (4),				/* "alar" = cpu over, "inac" = inactive */
       2 index fixed bin (35);			/* index in abs_user_tab */

dcl  1 process_status_return aligned,			/* structure returned by hphcs_$process_status */
       2 target_proc bit (36),			/* Input process id. */
       2 total_page_faults fixed bin (35),		/* Total page faults in process. */
       2 aptptr ptr,				/* ptr to user APTE */
       2 up_exec fixed bin,				/* execution state. 1=run, 4=block */
       2 up_mp fixed bin,				/* multiprogramming state. */
       2 up_block fixed bin (71),			/* time of last block */
       2 up_cpu fixed bin (71),			/* CPU usage in microseconds */
       2 up_page fixed bin (71),			/* memory usage in Frankstons */
       2 virtual_cpu fixed bin (71),			/* Process virtual CPU time */
       2 extra2 fixed bin (71);


/* Based */

dcl  system_area area based (system_area_ptr);
dcl  zap_abs fixed bin (71) based (addr (abs_signal));	/* for wakeup call */
dcl  zap_user fixed bin (71) based (addr (interactive_signal)); /* for wakeup call */

/* Builtins */

dcl  (abs, addr, baseno, baseptr, before, binary, ceil, clock, divide,
     fixed, float, index, length, max, min, mod, null, reverse, rtrim, substr,
     verify) builtin;

/* Conditions */

dcl  any_other condition;
dcl  seg_fault_error condition;

%page;

/* Program */

init: entry ();

/* Entry called by as_init_ when system is being brought up */

	if mode = "dumm" then return;			/* Was accounting disabled before startup? */
	if ^sc_stat_$Multics_typed | sc_stat_$Go_typed then do;
	     code = error_table_$out_of_sequence;
	     go to init_sub_error;
	end;
	if substr (sysdir, 1, 8) ^= ">system_" then mode = "test";

/* now set event call channel to signal updating of accounting info */

init1:	ansp = as_data_$ansp;
	call ipc_$create_ev_chn (anstbl.acct_update_chn, code); /* Set up event-call channel for acct update. */
	call ipc_$decl_ev_call_chn (anstbl.acct_update_chn, act_ctl_$update, null, ACCT_UPDATE_PRIO, code);
	if code ^= 0 then do;
	     call sys_log_$error_log (SL_LOG_BEEP, code, "act_ctl_$init", "creating update channel");
	     go to init_sub_error;
	end;
	anstbl.acct_alarm_fail = 0;
	alarmfail = 0;				/* Turn off switch says clock is late. */

/* Find out what time and what shift it is */

	crash_clock = anstbl.current_time;		/* Get best guess at time of crash or down. */
	anstbl.current_time = clock ();		/* Read clock. */

/* Before we trust the shift information left in the header of whotab from the last session,
   we must check it for reasonableness, since datebin_ uses it to tell us what shift it is. */

	if whotab.next_shift_change_time >
	     anstbl.current_time + MICROSECONDS_PER_WEEK |/* shift end can never be > 1 week in future */
	     whotab.last_shift_change_time >=
	     anstbl.current_time |			/* start of current shift must be in the past */
	     whotab.next_shift_change_time >		/* shift length must be <= 1 week */
	     whotab.last_shift_change_time + MICROSECONDS_PER_WEEK |
	     whotab.shift < 0 | whotab.shift > 7 then	/* shift number can only be 0 to 7 */
	     whotab.next_shift_change_time = 0;		/* force datebin_ to look in shift table */

/* because datebin_$next_shift_change uses the value of whotab.next_shift_change_time,
   and further, initializes its output arguments before processing, we can't
   just pass in whotab.next_shift_change_time as an argument. */

	begin;
dcl  next_shift_change_time fixed bin (71);
dcl  current_shift fixed bin;
dcl  next_shift fixed bin;

	     call datebin_$next_shift_change (anstbl.current_time, next_shift_change_time, current_shift, next_shift);
	     whotab.next_shift_change_time = next_shift_change_time;
	     whotab.shift = current_shift;
	end;

	call datebin_ (anstbl.current_time, absda, mm, dd, yy, hh, minute, sss, wkd, shf);

	if anstbl.shift ^= shf then do;		/* if shift changed since last session */
	     anstbl.shift = shf;			/* save current shift */
	     whotab.last_shift_change_time = anstbl.current_time; /* remember when it changed */
	end;

	call datebin_$revert (mm, dd, yy, hh, 0, 0, next_update);

	if installation_parms.acct_update <= 0 then do;
	     call sys_log_ (SL_LOG_BEEP,
		"act_ctl_$init: illegal value (^d) for accounting update interval in installation_parms.",
		installation_parms.acct_update);
	     call sub_err_ (0, "act_ctl_", "s");
	end;

	do while (next_update < anstbl.current_time);	/* compute next update time */
	     next_update = next_update + installation_parms.acct_update * MILLION;
	end;
	call timer_manager_$alarm_wakeup (next_update, "00"b, anstbl.acct_update_chn);
	last_update_interval = installation_parms.acct_update; /* Save for clock check (in case inst_parms changes) */
	updatetime = anstbl.current_time;		/* Set time of last update. */

	static_total_time_charged = 0;		/* Clear per-bootload counters. */
	static_total_dollar_charge = 0e0;		/* ... */
	static_nlogins = 0;				/* ... */
	ncrash = 0;				/* Find out how many users were on when crashed. */
	call as_meter_$enter (FIXPDT_METER);
	do i = 1 to sat.current_size;			/* Yes. Scan sat for projects with users on */
	     satep = addr (sat.project (i));		/* Get ptr to project entry. */
	     if project.project_id = "SysDaemon" then do; /* Need to remember "SysDaemon" pdt location. */
		sd_ptr = satep;			/* .. for filling in DUT entry for initializer */
		go to get_pdt;			/* .. now search for initializer entry in pdt */
	     end;
	     if project.n_users ^= 0 then do;		/* Live project? */
get_pdt:		pdtn = project.project_id;		/* Yes. Make name of its PDT. */
		j = index (pdtn, " ");		/* ... */
		substr (pdtn, j, 4) = ".pdt";		/* ... */
		call initiate_file_ (pdtdir, pdtn, RW_ACCESS, pdtp, (0), code);
		if code ^= 0 then do;
		     call sys_log_$error_log (SL_LOG_BEEP, code,
			"act_ctl_$init", "Cannot unlock PDT ^a",
			pathname_ (pdtdir, pdtn));
		     go to new3;			/* Hopeless. */
		end;

/**** The following code ensures makes sure the PDT is not damaged.  If
      it is, we just log (and print) an error and skip to the next PDT. */
		on seg_fault_error
		     begin;
		     call sys_log_$error_log (SL_LOG_BEEP, 0,
			"act_ctl_$init", "The PDT is damaged.  Cannot unlock ^a.", pathname_ (pdtdir, pdtn));
		     goto new3;
		end;
		j = pdt.current_size;		/* provoke seg_fault_error */
		revert seg_fault_error;

		do j = 1 to pdt.current_size;		/* Scan thru PDT looking for losers. */
		     pdtep = addr (pdt.user (j));	/* Get ptr to user. */
		     if user.person_id = "Initializer" then
			if project.project_id = "SysDaemon" then
			     initializer_pdtep = pdtep; /* Remember where initializer entry is. */
		     if user.last_update > crash_clock then crash_clock = user.last_update;
		     ncrash = ncrash + user.now_in;	/* Count processes which died. */
		     user.crashes = user.crashes + user.now_in;
		     user.now_in = 0;		/* Now he's out. */
		     user.n_foreground = 0;
		     user.n_background = 0;
		     user.n_interactive = 0;
		     user.n_disconnected = 0;
		     user.lock = "0"b;		/* And entry is not locked. */
		end;
/**** Keep our KST tidy by terminating PDTs unless we really need them. */
		if project.project_id ^= "SysDaemon" then
		     call terminate_file_ (pdtp, 0, TERM_FILE_TERM, code);
	     end;
new3:	     project.n_users = 0;			/* Clear project activity count. */
	end;
	call as_meter_$exit (FIXPDT_METER);
	if initializer_pdtep = null then do;		/* If cannot find initializer entry, truble */
	     call sys_log_ (SL_LOG_BEEP, "act_ctl_$init: cannot locate Initializer.SysDaemon pdt entry");
	     go to init_sub_error;
	end;
	else do;					/* Worked ok. Fill in some useful stuff. */
	     dutp = as_data_$dutp;
	     utep = addr (dutbl.entry (1));		/* Initializer is always # 1 in DUT */
	     ute.pdtep = initializer_pdtep;
	     ute.uprojp = sd_ptr;
	     initializer_pdtep -> user.logins = initializer_pdtep -> user.logins + 1;
	end;
	call as_meter_$as_meter_init (crash_clock, ncrash, next_update, last_update_interval);
	if ncrash > 0 then initializer_pdtep -> user.crashes = initializer_pdtep -> user.crashes + 1;

	if system_area_ptr = null
	then system_area_ptr = get_system_free_area_ ();

	return;

init_sub_error:
	call sub_err_ (code, "act_ctl_$init", "s");
%page;
check: entry (p, sp, wordx, e_text, codex);

/* Called by lg_ctl_.
   Entrypoint is passed a pointer to the user and to the user's SAT entry.
   It determines whether the user is cut off and if so, types out a message.
   If the user is not permitted to log in, it returns an error code. */

dcl  wordx char (8) aligned;				/* reason. */
dcl  e_text char (168) varying;			/* long reason */
dcl  codex fixed bin (35);				/* Nonzero if no login. */
dcl  sp ptr;					/* Ptr to user SAT entry for his proj. */
dcl  dont_check bit (36) aligned;

	utep = p;
	satep = sp;
	goto CHECK_COMMON;

check_for_process_creation:
     entry (P_utep, wordx, e_text, codex);

dcl  P_utep ptr parameter;				/* pointer to user's UTE */

	utep = P_utep;

	satep = ute.uprojp;
	goto CHECK_COMMON;

CHECK_COMMON:
	if mode = "dumm" then return;			/* If accounting is off, forget it. */
	ansp = as_data_$ansp;
	anstbl.current_time = clock ();		/* Read clock. */
	codex = 0;
	dont_check = ""b;				/* bits set when we squawk about something */
	mcode = 0;
	if project.cutoff ^= " " then do;		/* See if project is cut off */
	     nolog = "0"b;				/* probably non-fatal. */
	     if project.cutoff = "X" then do;		/* X = no login, out of funds */
		nolog = "1"b;
		mcode = as_error_table_$cut_proj_funds;
	     end;
	     else if project.cutoff = "W" then ;	/* "almost out of funds" is handled below */
	     else if project.cutoff = "Y" then do;
		mcode = as_error_table_$cut_proj_funds;
		dont_check = "1"b;			/* already talked about money */
	     end;
	     else if project.cutoff = "T" then do;	/* T = no login, out of date */
		nolog = "1"b;
		mcode = as_error_table_$cut_proj_date;
	     end;
	     else if project.cutoff = "R" then ;	/* "near cutoff date" is handled below */
	     else if project.cutoff = "S" then do;
		mcode = as_error_table_$cut_proj_date;
		dont_check = dont_check | "01"b;	/* indicate complained about date */
	     end;
	     else mcode = as_error_table_$cut_proj_other;
	     if nolog then do;			/* Login permitted? */
		codex = mcode;			/* no */
		call convert_status_code_ (mcode, wordx, format);
		if format ^= ""			/* If installation has this msg */
		then e_text = substr (format, 1, length (format) + 1 - verify (reverse (format), " ")) || NL;
		else e_text = "";
		return;
	     end;
	     else if (mcode ^= 0 & ^ute.at.brief)
	     then call Write_User_Message (mcode, (wordx));
	end;

	pdtep = ute.pdtep;				/* locate pdt entry */

	call adjust_cutoff_ (pdtep, anstbl.current_time); /* for cutoff_warning and checklim */

	if ^ute.at.brief				/* if user didn't say -bf */
	then call cutoff_warning (dont_check);		/* maybe print "almost out of funds" or "near cutoff date" */
	call checklim (ute.queue, mcode);		/* Limit stop check. */
						/* If no go, puts reason in mcode, short, line */
	if mcode ^= 0 then do;			/* wups */
	     codex = mcode;				/* Tell lg_ctl_ */
	     wordx = short;
						/* mlth set by checklim... */
	     e_text = substr (line, 1, mlth);		/* tell user why he was refused */
	     return;
	end;
	return;
%page;
/* Entry called when user is logging in */
/* called by dialup_, absentee_user_manager_, daemon_user_manager_ & ftp_dialup_ */

open_account: entry (p);

	if mode = "dumm" then return;			/* accounting disabled */
	utep = p;					/* Copy ptr to answer table entry. */
	if ute.active < NOW_LOGGED_IN then return;	/* not logged in */
	ansp = as_data_$ansp;
	anstbl.current_time = clock ();		/* Read clock. */

	if ute.process_type = PT_ABSENTEE then do;
	     ttykind = "Absentee";			/* ... */
	     i = 169 - index (reverse (ute.input_seg), ">");
	     jobid = "(" || before (substr (ute.input_seg, i + 1), ".absin") || ")";
	     icode = QNAME (ute.queue);
	end;
	else if ute.process_type = PT_DAEMON then do;
	     ttykind = "Daemon";			/* ... */
	     jobid = "";				/* ... */
	     icode = ute.tty_id_code;			/* ... */
	end;
	else do;					/* interactive */
	     ttykind = ute.terminal_type;
	     jobid = "";				/* ... */
	     icode = ute.tty_id_code;			/* ... */
	end;
	static_nlogins = static_nlogins + 1;		/* Count one login. */
	if asmtp ^= null then
	     asmt.logins (ute.process_type) = asmt.logins (ute.process_type) + 1; /* also count them by process type */

	pdtep = ute.pdtep;				/* extract user pdt ptr */
	user.now_in = user.now_in + 1;		/* no need to lock entry, just doing aos */
	if ute.queue <= 0 then do;			/* accounting treats all foreground processes as interactive */
	     user.logins = user.logins + 1;
	     user.n_foreground = user.n_foreground + 1;
	     if ute.process_type = PT_INTERACTIVE then	/* but we must maintain an accurate count */
		user.n_interactive = user.n_interactive + 1; /* of real interactive processes */
	end;
	else do;
	     user.absentee (ute.queue).jobs = user.absentee (ute.queue).jobs + 1;
	     user.n_background = user.n_background + 1;
	end;
	user.last_update = anstbl.current_time;		/* Start last update for user. */

check_update:
						/* compute timer lag (if any) */
	discrepancy = anstbl.current_time - updatetime - (last_update_interval * MILLION);
	if discrepancy > 60e6 then do;		/* if clock is more than 1 minute late */
	     call sys_log_ (SL_LOG,
		"act_ctl_: alarm clock late or failing by ^.2f mins",
		discrepancy / MICROSECONDS_PER_MINUTE);
	     anstbl.acct_alarm_fail = 1;		/* publish that it failed this bootload */
	     alarmfail = 1;				/* set flag */
	     call act_ctl_$update;			/* call update manually */
	     alarmfail = 0;				/* reset switch */
	end;

	return;
%page;
/* Entry called on process creation */
/* called by dialup_, absentee_user_manager_, daemon_user_manager_ & ftp_dialup_ */

cp:  entry (p);

	ansp = as_data_$ansp;
	anstbl.current_time = clock ();		/* Read clock. */
	utep = p;					/* Copy answer table entry ptr. */
	ute.cpu_this_process = 0;			/* no usage so far, of course */
	ute.mem_this_process = 0;			/* ... */
	ute.last_update_time = clock ();		/* ... */

	if ute.queue = 0 & ^ute.adjust_abs_q_no then do;	/* Check limits at new_proc for interactive. */
	     if ute.n_processes > 1 then do;
		pdtep = ute.pdtep;			/* Obtain ptr to user PDT entry. */
		call adjust_cutoff_ (pdtep, anstbl.current_time);
		call checklim (0, mcode);		/* Check limits */
		if mcode ^= 0 then do;		/* splat */
		     call asu_$bump_user (utep, substr (line, 1, mlth), code,
			installation_parms.warning_time);
		     call sys_log_ (SL_LOG, "act_ctl_: bumping ^a.^a ^a", ute.person, ute.project,
			substr (line, 1, mlth));
		end;
	     end;
	end;
	return;
%page;
shift_cmnd_update: entry;

/* entry point to do an accounting update when shift is changed by shift command */
/* called by admin_ */

dcl  shift_cmnd bit (1) aligned;
	shift_cmnd = "1"b;
	goto update_common;

/* update entry point to find all processes and log their data */
/* called automatically by timer_manager call based on installation_parms.update_time */

update: entry;
	shift_cmnd = ""b;
update_common:

	if mode = "dumm" then return;			/* accounting disabled */

dcl  up_word char (12) aligned;			/* for update message */

	ansp = as_data_$ansp;
	anstbl.acct_last_update_time, anstbl.current_time = clock (); /* Read clock. */
	some_time_ago = anstbl.current_time - installation_parms.inactive_time * MILLION;
	call ipc_$mask_ev_calls (ec);			/* in case wait on lock */
	static_label = updret1;			/* Set up exit if fault during update. */
	on any_other
	     call as_any_other_handler_ ("act_ctl_", NULL_PROC, static_label, static_label);
	call as_meter_$enter (ACCTUP_METER);

	if alarmfail ^= 0 then up_word = "Manual";	/* Make message for operator. */
	else up_word = "Automatic";			/* ... */
	if shift_cmnd then up_word = "Shift cmnd";	/* ... */

rescan:	call datebin_ (anstbl.current_time, absda, mm, dd, yy, hh, minute, sss, wkd, shf);

/* get accounting data for all current DSA network connections */
	network_account_array_ptr = null ();
	if anstbl.login_server_present then do;
	     call as_meter_$enter (NETUP_METER);
	     call network_accounting_gate_$read_and_reset_table
		(system_area_ptr, network_account_array_ptr, error_message,
		code);
	     if code ^= 0 then
		call sys_log_$error_log (SL_LOG_BEEP, code,
		     "act_ctl_$update", "Error from " || error_message);
	     else do;
		if network_account_array_ptr ^= null then do;
		     if network_account_array.version ^= NET_ACCT_ARRAY_VERSION_1 then do;
			call sys_log_ (SL_LOG_BEEP,
			     "act_ctl_$update: Net accounting array version (^a) not supported.  Expected version (^a)",
			     network_account_array.version, NET_ACCT_ARRAY_VERSION_1);
			free network_account_array in (system_area);
			network_account_array_ptr = null;
		     end;
		end;
	     end;
	     call as_meter_$exit (NETUP_METER);
	end;

	do i = 1 to anstbl.current_size;		/* Look at all interactive users. */
	     utep = addr (anstbl.entry (i));		/* Get ptr to answer table entry. */
	     static_label = updend;			/* if error, try next guy */
	     if ute.active ^= NOW_HAS_PROCESS then go to updend; /* Does user have a process? */
	     if ute.destroy_flag > WAIT_LOGOUT_SIG then go to updend; /* Process is being destroyed, ignore it */
	     pdtep = ute.pdtep;			/* Yes. set up ptrs and update him. */
	     call update_user;			/* Update all usage. */
	     if ute.preempted > 0 then go to updend;	/* don't kick a man when he's down */
	     call adjust_cutoff_ (pdtep, anstbl.current_time);
	     call checklim (0, mcode);		/* User over limit? */
	     if mcode ^= 0 then do;			/* yup */
		call asu_$bump_user (utep, substr (line, 1, mlth), code, installation_parms.warning_time);
		call sys_log_ (SL_LOG, "act_ctl_: bumping ^a.^a ^a", ute.person, ute.project, substr (line, 1, mlth));
	     end;

/* now see if user should be bumped for inactivity */

	     if up_exec = 5				/* Is process stopped? */
		| up_exec = 4 then do;		/* .. or blocked? */
check_time:	if up_block >= some_time_ago then go to updend;
		if ute.at.nobump then go to updend;	/* no bump daemons */
		if ute.uflags.disconnected then do;

/* disconnected processes get bumped NOW */
		     interactive_signal = "bump";	/* Sending wakeup to dialup_ saying blocked too long */
		     call hcs_$wakeup (as_data_$as_procid, ute.event, zap_user, code);
		end;
		else do;

/* Give the user some time to call up and cancel the bump,
   or finish his work up gracefully */
		     call asu_$bump_code (utep, as_error_table_$inactive, short, code, installation_parms.warning_time);
		     call sys_log_ (SL_LOG, "act_ctl_: bumping ^a.^a for inactivity", ute.person, ute.project);
		end;
	     end;

updend:	     static_label = updret1;			/* If run off end of table or somethng. */
	end;

/* Now update usage for daemons. */

	dutp = as_data_$dutp;
	do i = 1 to dutbl.current_size;		/* Same sort of scan. */
	     utep = addr (dutbl.entry (i));		/* Use the fact that anstbl and dutbl look same */
	     static_label = skip_dmn;			/* Set up ucs transfer to go to next daemon. */
	     if ute.active ^= NOW_HAS_PROCESS then go to skip_dmn;
						/* skip if nobody there */
	     pdtep = ute.pdtep;			/* Get ptr to PDT entry for daemon */
	     call update_user;			/* Charge daemon. (Gets initializer too.) */
skip_dmn:	     static_label = updret1;
	end;

	autp = as_data_$autp;
	do i = 1 to autbl.current_size;		/* Now update absentees. */
	     utep = addr (autbl.entry (i));
	     static_label = skip_abs;			/* in case fault */
	     if ute.active = NOW_FREE then go to skip_abs;
	     pdtep = ute.pdtep;
	     call update_user;			/* Update all time counters */

	     if divide (ute.cpu_this_process, MILLION, 35, 0) > ute.max_cpu_time then
		if ^ute.at.nobump then do;		/* If over-ran cpu limit. */
		     call sys_log_ (SL_LOG, "act_ctl_: bumping abs^d ^a.^a - too much time",
			i, ute.person, ute.project);
		     abs_signal.type = "alar";	/* Sending wake to aum saying out of time */
		     go to send_wakeup;
		end;
	     if up_exec = 4 then do;
		if up_block >= some_time_ago then go to skip_abs;
		if ute.uflags.suspended then goto skip_abs; /* don't bump suspended job for inactivity */
		call sys_log_ (SL_LOG, "act_ctl_: bumping abs^d ^a.^a - inactive too long",
		     i, ute.person, ute.project);
		abs_signal.type = "inac";		/* Sending wake to aum saying blocked too long */
send_wakeup:	abs_signal.index = i;		/* .. set index for speedy finding of user */
		call hcs_$wakeup (whotab.abs_procid, whotab.abs_event, zap_abs, code);
	     end;

skip_abs:	     static_label = updret1;
	end;

/* free network_account_array in system area */
	if network_account_array_ptr ^= null then do;
	     call CHECK_NETWORK_ACCOUNTING_USE;
	     free network_account_array in (system_area);
	     network_account_array_ptr = null;
	end;

	call as_meter_ (mtc, mti, mui, mrs, mws, mhh, mel, mqu);

/* to see if two numbers are relatively equal, we use the following equation:
   .	|A-B|
   .	----- < TOLERANCE
   .	|A+B|
   .
   if this relation is true, A and B are equal within the "tolerance".
   due to the actual implementation (multiplying both sides by (A+B)),
   A+B must not be zero.
*/

	should_charge = float (mtc - mti, 63);		/* total availability. */
	did_charge = float (static_total_time_charged, 63); /* did charge this amount */
	discrepancy = should_charge - did_charge;	/* and this is the error term. */

	if discrepancy ^= 0e0			/* equation doesn't work if zero (and error is zero anyway!) */
	then if abs (discrepancy) >= TOLERANCE * abs (should_charge + did_charge)
	     then if mode ^= "test" then do;		/* doesn't work in test mode... */
		     call sys_log_ (SL_LOG, "act_ctl_: discrepancy of ^.2f mins", discrepancy / MICROSECONDS_PER_MINUTE);
		     call sys_log_ (SL_LOG_SILENT, "act_ctl_: charged ^.2f, available ^.2f mins",
			(did_charge / MICROSECONDS_PER_MINUTE), (should_charge / MICROSECONDS_PER_MINUTE));
		end;
	if shf ^= anstbl.shift then do;		/* Has shift changed? */
	     call sys_log_ (SL_LOG, "act_ctl_: changing shift from ^d to ^d", anstbl.shift, shf);
	     i = anstbl.shift;			/* remember old shift */
	     anstbl.shift = shf;

	     if ^shift_cmnd then do;			/* shift command sets whotab stuff */
		whotab.last_shift_change_time = anstbl.current_time; /* but we do it here at other shift changes */
		call datebin_$next_shift_change (anstbl.current_time, whotab.next_shift_change_time, whotab.shift, (0));
	     end;

	     call load_ctl_$set_maxunits (i);		/* The rules may have changed */
	     go to rescan;				/* Catch users with zero shift limit on new shift */
	end;
	else if anstbl.current_time >= whotab.next_shift_change_time then
	     call datebin_$next_shift_change (anstbl.current_time, whotab.next_shift_change_time, (0), (0));

	call load_ctl_$load_level (binary (mqu * 1e1), (mui * 1e1) / mtc);
updret1:	static_label = updret2;
	if alarmfail ^= 0 then go to updret2;		/* may have been called manually */
	if shift_cmnd then goto updret2;		/* or called by the shift command */
	next_update = next_update + installation_parms.acct_update * MILLION;
	last_update_interval = installation_parms.acct_update; /* save for alarm clock check */
	call timer_manager_$alarm_wakeup (next_update, "00"b, anstbl.acct_update_chn);
updret2:	static_label = return_immediately;
	updatetime = anstbl.current_time;		/* Remember when we did it */
	call ipc_$unmask_ev_calls (ec);		/* remember to allow logins again */
	call as_meter_$exit_values (ACCTUP_METER, pagefaults, vcpu_time, real_time);
	call sys_log_ (SL_LOG,
	     "act_ctl_: ^a update: users = ^d, pf=^d, vcpu=^.3f, rt=^.3f^[, answer table locked^]^[, install(s) pending^]",
	     up_word, anstbl.n_users, pagefaults, vcpu_time / 1.0e6, real_time / 1.0e6,
	     (anstbl.lock_count ^= 0), anstbl.update_pending);
return_immediately:
	return;
%page;
/* This entry is called whenever a process is destroyed, including at logout */
/* called by dialup_, absentee_user_manager_, daemon_user_manager_ & ftp_dialup_ */

dp:  entry (p);
	if mode = "dumm" then return;			/* accounting disabled */
	utep = p;					/* Copy ptr to answer table entry. */

	ansp = as_data_$ansp;
	anstbl.current_time = clock ();		/* Read clock. */

	cpudelta = ute.cpu_this_process;		/* dpg_ bumped cpu_usage */
	logdelta = anstbl.current_time - ute.last_update_time;
	coredelta = ute.mem_this_process;		/* ... */
	io_ops_delta = 0;				/* for now */
	static_total_time_charged = static_total_time_charged + cpudelta;

	pdtep = ute.pdtep;				/* get ptr to user pdte */
	if pdtep = null then go to check_update;	/* If null, forget update. */
	user.last_update = anstbl.current_time;		/* Note update. */
	call ipc_$mask_ev_calls (ec);			/* In case wait on lock, don't allow ev call. */
	call set_lock_$lock (user.lock, 300, ec);	/* lock user entry so can update charges */
	call ipc_$unmask_ev_calls ((0));		/* be sure not to leave them masked, whatever else happens */
	if ec = error_table_$lock_wait_time_exceeded then do;
	     call sys_log_$error_log (SL_LOG_BEEP, ec, "act_ctl_", "While destroying proc for ^a.^a",
		ute.person, ute.project);		/* Fuss. */
	     go to check_update;			/* But let him off easy. */
	end;
	if ute.queue = 0 then call charge_interactive;	/* Interactive user? */
	else if ute.queue < 0 then call charge_daemon;	/* Daemon? */
	else call charge_abs;			/* Other internal proc for absentees. */
	call device_acct_$broom (utep);		/* clean up any device_table slots for this process */

/* update any final DSA network charges for this user */
	network_account_array_ptr = null;
	if anstbl.login_server_present then do;
	     call as_meter_$enter (NETUP_METER);
	     call network_accounting_gate_$get_process_total (ute.proc_id,
		system_area_ptr, network_account_array_ptr, error_message,
		code);
	     if code ^= 0 then
		call sys_log_$error_log (SL_LOG_BEEP, code, "act_ctl_$dp",
		     "Error from " || error_message);
	     else do;
		if network_account_array_ptr ^= null then do;
		     if network_account_array.version ^= NET_ACCT_ARRAY_VERSION_1 then do;
			call sys_log_ (SL_LOG_BEEP,
			     "act_ctl_$dp:  Net accounting array version (^a) not supported.  Expected version (^a)",
			     network_account_array.version, NET_ACCT_ARRAY_VERSION_1);
			free network_account_array in (system_area);
			network_account_array_ptr = null;
		     end;
		end;
		call UPDATE_NETWORK_ACCOUNTING (utep);

/* free network_account_array in system area */
		call CHECK_NETWORK_ACCOUNTING_USE;
		if network_account_array_ptr ^= null then do;
		     free network_account_array in (system_area);
		     network_account_array_ptr = null;
		end;
	     end;
	     call as_meter_$exit (NETUP_METER);
	end;

	call set_lock_$unlock (user.lock, ec);		/* Done with PDT entry. */

	go to check_update;				/* Should clock have rung? */
%page;
/* This entrypoint is called when a user logs out. */
/* called by dialup_, absentee_user_manager_, daemon_user_manager_ & ftp_dialup_ */

close_account: entry (p);

	utep = p;					/* Copy ptr to answer tb */

	if mode = "dumm" then return;			/* accounting disabled */

	if ute.active < NOW_LOGGED_IN then return;	/* Ignore if nobody there. */
	ansp = as_data_$ansp;
	anstbl.current_time = clock ();		/* Read clock. */
	if ute.process_type = PT_ABSENTEE then do;
	     ttykind = "Absentee";			/* .. */
	     icode = QNAME (ute.queue);
	end;
	else if ute.process_type = PT_DAEMON then do;
	     ttykind = "Daemon";			/* .. */
	     icode = ute.tty_id_code;			/* .. */
	end;
	else do;					/* Interactive */
	     if ute.uflags.disconnected then
		ttykind = "DISCONNECTED";
	     else ttykind = ute.terminal_type;
	     icode = ute.tty_id_code;			/* .. */
	end;
	pdtep = ute.pdtep;				/* get ptr to user pdte */
	if pdtep ^= null then do;
	     user.now_in = decrement_and_check (user.now_in, "now_in");
	     if ute.queue <= 0 then do;
		user.n_foreground = decrement_and_check ((user.n_foreground), "n_foreground");
		if ute.process_type = PT_INTERACTIVE then do;
		     user.n_interactive = decrement_and_check ((user.n_interactive), "n_interactive");
		     if ute.disconnected then
			user.n_disconnected = decrement_and_check ((user.n_disconnected), "n_disconnected");
		end;
	     end;
	     else user.n_background = decrement_and_check ((user.n_background), "n_background");
	end;

	if asmtp ^= null then
	     asmt.logouts (ute.process_type) = asmt.logouts (ute.process_type) + 1;
						/* count logouts for metering */

	go to check_update;				/* Done. */
%page;
/* entry point called when system shutdown */
/* called by as_init_ */

act_ctl_close: entry;

	if mode = "dumm" then return;			/* accounting disabled */

	ansp = as_data_$ansp;
	anstbl.current_time = clock ();		/* Get time of shutdown */

	call as_meter_ (mtc, mti, mui, mrs, mws, mhh, mel, mqu);
	call as_meter_$as_meter_stop;			/* Stop metering. */

	secs = divide (static_total_time_charged, MILLION, 35, 0);
	mins = divide (secs, 60, 35, 0);		/* Format last message. */
	secs = mod (secs, 60);			/* .. */
	hrs = divide (mins, 60, 35, 0);		/* .. */
	mins = mod (mins, 60);			/* .. */
	call sys_log_ (SL_LOG, "act_ctl_: shutdown, ^d ^.2f ^.2f ^.2f ^.2f ^d:^d:^d $^.2f",
	     static_nlogins, mqu, mel, mhh, mrs,
	     hrs, mins, secs, static_total_dollar_charge);
	mode = "dumm";				/* disable accounting */
	return;

%page;
/* entry to see if process which has bump pending can have bump cancelled
   due to activity since warning of bump */
/* called by dialup_ */

activity_unbump: entry (a_atep, a_code);		/* see if a user is now active */

dcl  a_atep ptr;
dcl  a_code fixed bin (35);

	a_code = 0;				/* assume the best */
	ansp = as_data_$ansp;
	anstbl.current_time = clock ();		/* Read clock. */
	some_time_ago = anstbl.current_time - installation_parms.warning_time * MILLION
	     + INACTIVITY_STABILIZATION_TIME;
	call ipc_$mask_ev_calls (ec);			/* in case wait on lock */
	static_label = auret1;
	on any_other call as_any_other_handler_ ("act_ctl_", NULL_PROC, static_label, static_label);

	utep = a_atep;
	target_proc = ute.proc_id;			/* set up for call */
	call hphcs_$process_status (addr (process_status_return)); /* get process usage */

	if aptptr ^= null & up_exec = 4 & up_block < some_time_ago then
	     a_code = as_error_table_$inactive;		/* still no good */
	if debug_ia_sw then do;			/* DEBUG */
	     call sys_log_ (SL_LOG, "unbump check for ^a.^a, state = ^d, limit time = ^d, blocked at ^d, delta = ^d",
		ute.person, ute.project, up_exec, some_time_ago, up_block, some_time_ago - up_block);
	end;
auret1:	call ipc_$unmask_ev_calls (ec);
	return;
%page;

/* entry points to disable and reenable accounting for testing purposes */

act_ctl_disable: entry;

	mode = "dumm";
	call sys_log_ (SL_LOG, "act_ctl_: accounting disabled");
	return;

act_ctl_reable: entry;

	mode = "norm";				/* Turn accounting back on. */
	call sys_log_ (SL_LOG, "act_ctl_: accounting enabled.");
	ansp = as_data_$ansp;
	if anstbl.acct_update_chn = 0 then go to init1;	/* Have we started accounting? */
	return;

dcl  debug_ia_sw bit (1) int static init ("0"b);
dcl  ctlarg char (*);

debug_ia: entry (ctlarg);
	call cu_$arg_count (i);
	if i = 0 then
	     goto debug_ia_return;
	if ctlarg = "on" then
	     debug_ia_sw = "1"b;
	else if ctlarg = "off" then
	     debug_ia_sw = "0"b;
debug_ia_return:
	call sys_log_ (SL_LOG, "act_ctl_: Inactivity debug ^[on^;off^]", debug_ia_sw);
	return;


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

debug_na: entry (ctlarg);
	call cu_$arg_count (i);
	if i = 0 then
	     goto debug_na_return;
	if ctlarg = "on" then
	     debug_na_sw = "1"b;
	else if ctlarg = "off" then
	     debug_na_sw = "0"b;
	call network_accounting_gate_$debug (debug_na_sw);
debug_na_return:
	call sys_log_ (SL_LOG, "act_ctl_: Network accounting debug ^[on^;off^]", debug_na_sw);
	return;

%page;

/* internal subroutines */

/* This procedure calls the hardcore to find a process's usage, and then charges the usage
   via a call to charge_interactive, charge_daemon, or charge_abs. */

update_user: proc;

	target_proc = ute.proc_id;			/* set up for call */
	call hphcs_$process_status (addr (process_status_return)); /* get process usage */
	if aptptr = null then do;			/* Is user process there? */
	     call sys_log_ (SL_LOG_BEEP, "act_ctl_: process ^12.3b for ^a.^a vanished", ute.proc_id, ute.person,
		ute.project);
	     call asu_$bump_user (utep, "Process lost", code, 0);
	     return;				/* Can't update him. */
	end;

	cpudelta = process_status_return.virtual_cpu - ute.cpu_this_process; /* Calculate usage in process. */
	logdelta = anstbl.current_time - ute.last_update_time;
	coredelta = process_status_return.up_page - ute.mem_this_process;
	io_ops_delta = 0;				/* for now */

	call set_lock_$lock (user.lock, 15, ec);	/* lock user pdt entry */
	if ec = error_table_$lock_wait_time_exceeded then go to ugh1;
	static_label = ugh;				/* if error in this section, unlock user */
	ute.cpu_this_process = process_status_return.virtual_cpu; /* Fix up anstbl entry for next time. */
	ute.mem_this_process = process_status_return.up_page; /* ... */
	ute.last_update_time = anstbl.current_time;
	static_total_time_charged = static_total_time_charged + cpudelta;
	user.last_update = anstbl.current_time;		/* Note update in PDT */
	if ute.queue = 0 then call charge_interactive;
	else if ute.queue < 0 then call charge_daemon;
	else call charge_abs;
	call device_acct_$update (utep);		/* charge for tapes etc. */

/* update network accounting for this user */
	if anstbl.login_server_present then do;
	     call as_meter_$enter (NETUP_METER);
	     call UPDATE_NETWORK_ACCOUNTING (utep);
	     call as_meter_$exit (NETUP_METER);
	end;

ugh:	call set_lock_$unlock (user.lock, ec);		/* Now free PDT entry. */
ugh1:	return;

     end update_user;

%page;

/* This procedure charges an absentee for his usage. "pdtep", "atep", and the deltas must be set up. */

charge_abs: proc;

dcl  ii fixed bin;

	ii = ute.queue;				/* Extract queue number. */
	user.absentee (ii).cpu = user.absentee (ii).cpu + cpudelta;
	user.absentee (ii).memory = user.absentee (ii).memory + coredelta;
	cost = cpudelta * rs_ptrs (ute.rs_number) -> rate_structure.abs_cpu_price (ii) / MICROSECONDS_PER_HOUR +
	     coredelta * rs_ptrs (ute.rs_number) -> rate_structure.abs_mem_price (ii) / 1e6;
	user.absentee (ii).charge = user.absentee (ii).charge + cost;
	user.absolute_spent = user.absolute_spent + cost;
	user.dollar_charge = user.dollar_charge + cost;
	ute.session_cost = ute.session_cost + cost;
	static_total_dollar_charge = static_total_dollar_charge + cost;

     end charge_abs;

%page;

/* This procedure charges an interactive user for usage. "pdtep" and the deltas must be setup */

charge_interactive: proc;

dcl  ishft fixed bin;

	ishft = anstbl.shift;
	user.interactive.cpu (ishft) = user.interactive.cpu (ishft) + cpudelta;
	user.interactive.connect (ishft) = user.interactive.connect (ishft) + logdelta;
	user.interactive.core (ishft) = user.interactive.core (ishft) + coredelta;
	user.interactive.io_ops (ishft) = user.interactive.io_ops (ishft) + io_ops_delta;
	cost = cpudelta * rs_ptrs (ute.rs_number) -> rate_structure.cpu_price (ishft) / MICROSECONDS_PER_HOUR +
	     coredelta * rs_ptrs (ute.rs_number) -> rate_structure.core_price (ishft) / 1e6 +
	     logdelta * rs_ptrs (ute.rs_number) -> rate_structure.log_base_price (ishft) / MICROSECONDS_PER_HOUR +
	     io_ops_delta * rs_ptrs (ute.rs_number) -> rate_structure.io_ops_price (ishft) / MICROSECONDS_PER_HOUR;

	user.interactive.charge (ishft) = user.interactive.charge (ishft) + cost;
	user.dollar_charge = user.dollar_charge + cost;
	user.absolute_spent = user.absolute_spent + cost;
	ute.session_cost = ute.session_cost + cost;
	static_total_dollar_charge = static_total_dollar_charge + cost;

     end charge_interactive;

%page;

/* This procedure charges a daemon for usage. "pdtep" and the deltas must be setup
   the difference between this proc and charge_interactive is that daemons do not pay connect. */

charge_daemon: proc;

dcl  ishft fixed bin;

	ishft = anstbl.shift;
	user.interactive.cpu (ishft) = user.interactive.cpu (ishft) + cpudelta;
	user.interactive.connect (ishft) = user.interactive.connect (ishft) + logdelta;
	user.interactive.core (ishft) = user.interactive.core (ishft) + coredelta;
	user.interactive.io_ops (ishft) = user.interactive.io_ops (ishft) + io_ops_delta;
	cost = cpudelta * rs_ptrs (ute.rs_number) -> rate_structure.cpu_price (ishft) / MICROSECONDS_PER_HOUR +
	     coredelta * rs_ptrs (ute.rs_number) -> rate_structure.core_price (ishft) / 1e6 +
	     io_ops_delta * rs_ptrs (ute.rs_number) -> rate_structure.io_ops_price (ishft) / MICROSECONDS_PER_HOUR;

	user.interactive.charge (ishft) = user.interactive.charge (ishft) + cost;
	user.dollar_charge = user.dollar_charge + cost;
	user.absolute_spent = user.absolute_spent + cost;
	ute.session_cost = ute.session_cost + cost;
	static_total_dollar_charge = static_total_dollar_charge + cost;

     end charge_daemon;

%page;

/* Internal procedure to check resource limits.

   If a user should not be allowed to proceed, this program returns an error code
   and has set up the variables "line" and "mlth" with an explanation.
   Caller should ensure that adjust_cutoff_ has been called.

   Error codes are:

   .	shift limit exceeded (interactive)
   .	absolute limit exceeded
   .	month dollar limit exceeded
   .	cutoff date passed

   On entry, the variable "pdtep" must be pointing to the user's PDT entry.

*/

checklim: proc (abssw, errcd);

dcl  abssw fixed bin,				/* >0 if absentee -- don't check interactive limit */
     errcd fixed bin (35);				/* error code */

dcl  why char (32), limv float bin, ss fixed bin;

	errcd = 0;				/* clear error code */
	ss = anstbl.shift;
	if user.dollar_charge >= user.dollar_limit then do;
	     limv = user.dollar_limit;
	     errcd = as_error_table_$cut_user_mlim_msg;
	     why = "";
	end;
	if abssw <= 0 then				/* if not absentee, check shift limit */
	     if user.interactive.charge (ss) >= user.shift_limit (ss) then do;
		limv = user.shift_limit (ss);
		errcd = as_error_table_$cut_user_shift_msg;
		call convert_status_code_ (errcd, short, format);
		call ioa_$rs (format, line, mlth, limv, ss);
		return;
	     end;
	if user.absolute_spent >= user.absolute_limit then do;
	     limv = user.absolute_limit;
	     call date_time_ (user.absolute_cutoff, why);
	     errcd = as_error_table_$cut_user_cut_msg;
	end;
	if anstbl.current_time >= user.absolute_cutoff then do;
	     call date_time_ (user.absolute_cutoff, why);
	     errcd = as_error_table_$cut_user_date_msg;
	     call convert_status_code_ (errcd, short, format);
	     call ioa_$rs (format, line, mlth, why);
	     return;
	end;

	call convert_status_code_ (errcd, short, format); /* Get nice message for loser */
	call ioa_$rs (format, line, mlth, limv, why);
	return;

     end checklim;

%page;

cutoff_warning: proc (dont_check);

/* this procedure prints a warning message for the user if
   1) the project will be cut off soon (because of funds or date),
   2) the user will be cut off soon (because of funds or date),
   3) the user is supposed to get such warning messages, and
   4) this is not an absentee job. */

dcl  dont_check bit (36) aligned;

dcl  remaining float bin;
dcl  remaining_pct fixed bin;
dcl  (user_warn_days, user_warn_pct) fixed bin;
dcl  user_warn_dollars float bin;
dcl  (warn_days, warn_pct) fixed bin;
dcl  warn_dollars float bin;

dcl  ABS fixed bin init (1) static options (constant);
dcl  DAYS fixed bin init (2) static options (constant);
dcl  PCT fixed bin init (3) static options (constant);
dcl  SHIFT fixed bin init (6) static options (constant);
dcl  BILLING_PERIOD fixed bin init (7) static options (constant);

pom:	proc (type, v, period);
dcl  type fixed bin;
dcl  v float bin;
dcl  period fixed bin;

dcl  cut_date char (9);
dcl  reason char (64);

	     call date_time_ (user.absolute_cutoff, cut_date);
	     if type ^= DAYS then do;			/* periods 0-5 defined in adjust_cutoff_ */
		call ioa_$rsnnl ("^[ until" ||
		     "^[^; daily^; monthly^; yearly^; calendar year^; fiscal year^; weekly^]" ||
		     " cutoff on ^a^s^;^2s this ^[shift^;billing period^]^]",
		     reason, (0), period <= 6, period + 1, cut_date, period = SHIFT);
		if type = ABS then do;
		     call convert_status_code_ (as_error_table_$user_warn_funds, short, format);
		     call ioa_$rs (format, line, mlth, v, reason);
		end;
		else do;
		     call convert_status_code_ (as_error_table_$user_warn_pct, short, format);
		     call ioa_$rs (format, line, mlth, fixed (v), reason);
		end;
	     end;
	     else do;
		call convert_status_code_ (as_error_table_$user_warn_days, short, format);
		call ioa_$rs (format, line, mlth, cut_date);
	     end;
	     call write_message;
	end pom;

	if ute.queue > 0 | ute.adjust_abs_q_no then return; /* no use wasting any time if absentee */

	pdtp = baseptr (baseno (pdtep));		/* we have to look in the header of the user's pdt */

	if pdt.version >= 3 then do;			/* version 3 has warning thresholds in it */
	     user_warn_days = user.user_warn_days;
	     user_warn_pct = user.user_warn_pct;
	     user_warn_dollars = user.user_warn_dollars;
	     warn_days = user.warn_days;
	     warn_pct = user.warn_pct;
	     warn_dollars = user.warn_dollars;
	end;
	else do;					/* older pdts do not, so use defaults */
	     user_warn_days = 10;
	     user_warn_pct = 10;
	     user_warn_dollars = 10e0;
	     warn_days = 10;
	     warn_pct = 10;
	     warn_dollars = 10e0;
	end;

	if ^(dont_check & "1"b) & project.pct_balance < warn_pct | /* if low percentage-wise, or */
	     (project.pct_balance < 100 &		/* (proj w/no limit has pct=100 and dollars=0) */
	     project.dollars_to_cutoff < warn_dollars) then do; /* low in absolute dollars */
	     call convert_status_code_ (as_error_table_$proj_low_funds, short, format);
	     call ioa_$rs (format, line, mlth, project.dollars_to_cutoff, project.pct_balance);
	     call write_message;
	end;

	if ^(dont_check & "01"b) & project.days_to_cutoff < warn_days then do; /* if near cutoff date */
	     call convert_status_code_ (as_error_table_$warn_proj_date, short, format);
	     call ioa_$rs (format, line, mlth, project.days_to_cutoff);
	     call write_message;
	end;

	if user.dollar_limit < OPEN then do;
	     remaining = max (0e0, user.dollar_limit - user.dollar_charge);
	     if remaining < user_warn_dollars then	/* running out of monthly dollars */
		call pom (ABS, remaining, BILLING_PERIOD);
	     remaining_pct = ceil (remaining / max (1e-2, user.dollar_limit)) * 100e0;
	     if remaining_pct < user_warn_pct then	/* running out of monthly % */
		call pom (PCT, (remaining_pct), BILLING_PERIOD);

	end;
	if user.absolute_limit < OPEN then do;
	     remaining = max (0e0, user.absolute_limit - user.absolute_spent);
	     if remaining < user_warn_dollars then	/* running against periodic limit */
		call pom (ABS, remaining, user.absolute_increm);
	     remaining_pct = ceil (remaining / max (1e-2, user.absolute_limit)) * 100e0;
	     if remaining_pct < user_warn_pct then	/* running out of periodic % */
		call pom (PCT, (remaining_pct), user.absolute_increm);

	end;
	if user.shift_limit (anstbl.shift) < OPEN then do;
	     remaining = max (0e0, user.shift_limit (anstbl.shift) - user.interactive (anstbl.shift).charge);
	     if remaining < user_warn_dollars then
		call pom (ABS, remaining, SHIFT);
	     remaining_pct = ceil (remaining / max (1e-2, user.shift_limit (anstbl.shift))) * 100e0;
	     if remaining_pct < user_warn_pct then
		call pom (PCT, (remaining_pct), SHIFT);
	end;

	if user.absolute_increm = 0 then		/* absolute cutoff date in effect */
	     if user.absolute_cutoff < NEVER then
		if divide (user.absolute_cutoff - anstbl.current_time,
		     24 * 60 * 60 * MILLION, 71, 0) < user_warn_days then
		     call pom (DAYS, (0), 0);

	return;

     end cutoff_warning;

%page;

write_message: proc;				/* to write substr(line,1,mlth) on user or daemon terminal */

	if ute.queue = -1 then			/* daemon */
	     call sys_log_ (SL_LOG, substr (line, 1, mlth - 1)); /* omit newline since sys_log_ supplies one */
	else call asu_$blast_user (utep, substr (line, 1, mlth), "", 0);
	return;

     end write_message;

%page;
/* This procedure is called to decrement the various process counters in the pdt entry,
   and trap a bug where a counter can go negative. It returns the decremented value as a function
   return, because the counters are not all of the same precision. */

decrement_and_check: proc (counter, name) returns (fixed bin);

dcl  counter fixed bin;
dcl  name char (*);
dcl  return_value fixed bin;

	return_value = counter - 1;			/* decrement counter */
	if return_value < 0 then do;			/* trap bug */
	     call sys_log_ (SL_LOG_SILENT, "act_ctl_: ^a for ^a.^a is negative (^d) at logout; setting it to zero.",
		name, ute.person, ute.project, return_value);
	     return_value = 0;
	end;

	return (return_value);

     end decrement_and_check;


/* Internal procedure invoked when a fault occurs in update */

NULL_PROC: procedure; end NULL_PROC;			/* cleanup procedure with nothing in it */
%page;
Write_User_Message:
     procedure (P_code, P_message);

dcl  P_code fixed bin (35) parameter;
dcl  P_message char (*) parameter;

dcl  message char (512) automatic;
dcl  message_lth fixed bin automatic;
dcl  message_buffer_cur_lth fixed bin automatic;
dcl  message_buffer_max_lth fixed bin automatic;
dcl  message_buffer_ptr ptr automatic;
dcl  new_message_buffer_max_lth fixed bin automatic;
dcl  new_message_buffer_ptr ptr automatic;

dcl  status_code_string char (100) aligned automatic;

dcl  message_buffer char (message_buffer_max_lth)
	based (message_buffer_ptr);
dcl  new_message_buffer char (new_message_buffer_max_lth)
	based (new_message_buffer_ptr);

dcl  astty_$tty_force entry (ptr, ptr, fixed bin, fixed bin (35));

	if P_code ^= 0 then
	     call convert_status_code_ (P_code, (""), status_code_string);
	else status_code_string = "";

/**** Handle the case were the as_error_table_ entry specifies a null message.
      Only skip the message if both the code string and message string are
      null. */

	if (status_code_string = "") & (P_message = "") then
	     return;

	call ioa_$rs ("^[^a ^;^s^]^a", message, message_lth,
	     (status_code_string ^= ""), status_code_string,
	     rtrim (P_message));

	if ute.channel ^= null then			/* user has a MCS channel */
	     call astty_$tty_force ((ute.channel), addr (message),
		message_lth, (0));
	else do;
	     message_buffer_ptr = as_data_$ls_message_buffer_ptr;
	     message_buffer_max_lth = as_data_$ls_message_buffer_max_lth;
	     message_buffer_cur_lth = as_data_$ls_message_buffer_cur_lth;

	     if message_buffer_cur_lth + message_lth > message_buffer_max_lth then do;
		new_message_buffer_max_lth = message_buffer_max_lth +
		     min (512, message_buffer_cur_lth + message_lth);
		if system_area_ptr = null
		then system_area_ptr = get_system_free_area_ ();
		allocate new_message_buffer in (system_area)
		     set (new_message_buffer_ptr);
		substr (new_message_buffer, 1, message_buffer_cur_lth) =
		     substr (message_buffer, 1, message_buffer_cur_lth);
		free message_buffer in (system_area);
		as_data_$ls_message_buffer_ptr,
		     message_buffer_ptr = new_message_buffer_ptr;
		as_data_$ls_message_buffer_max_lth,
		     message_buffer_max_lth = new_message_buffer_max_lth;
	     end;

	     substr (message_buffer, message_buffer_cur_lth + 1,
		message_lth) = message;
	     as_data_$ls_message_buffer_cur_lth = message_buffer_cur_lth +
		message_lth;
	end;
	return;
     end Write_User_Message;
%page;
CHECK_NETWORK_ACCOUNTING_USE: proc;

/* this routine will scan through network accounting array and report any
   entries which weren't processed during the accounting update */

dcl  net_indx fixed bin;				/* index into network_account_array */
dcl  process_id_to_match bit (36) aligned;
dcl  purge_bit bit (1);
dcl  total_connect_seconds fixed bin (35);		/* connect time to charge for */
dcl  total_bytes fixed bin (35);			/* bytes to charge for */
dcl  total_packets fixed bin (35);			/* packets to charge for */

	if network_account_array_ptr = null then
	     return;

	total_bytes, total_packets, total_connect_seconds = 0;
	process_id_to_match, purge_bit = "0"b;

/* loop through all NAT entries */
	do net_indx = 1 to network_account_array.count;

/* look for NAT entries not used in accounting update */
	     if ^network_account_array.accounting (net_indx) then do;

/* found unused NAT entry, does it match one I'm accumulating for */
		if process_id_to_match ^= network_account_array.process_id (net_indx) then do;
		     if process_id_to_match ^= "0"b then do;
			call sys_log_ (SL_LOG_SILENT,
			     "act_ctl_$update: Processid ^w missing.
Not charged for ^d pkt, ^d byte & ^d seconds; was^[ not^] purged.",
			     process_id_to_match, total_packets,
			     total_bytes, total_connect_seconds,
			     ^purge_bit);
		     end;

/* reset to start accumulating for this user */
		     process_id_to_match = network_account_array.process_id (net_indx);
		     total_bytes, total_packets, total_connect_seconds = 0;
		     purge_bit = "0"b;
		end;
		total_bytes = total_bytes + network_account_array.byte_count (net_indx);
		total_packets = total_packets + network_account_array.packet_count (net_indx);
		total_connect_seconds = total_connect_seconds + network_account_array.connect_time (net_indx);
		if network_account_array.purged (net_indx) then
		     purge_bit = "1"b;
	     end;
	end;

	if process_id_to_match ^= "0"b then do;
	     call sys_log_ (SL_LOG_SILENT,
		"act_ctl_$update: Processid ^w missing.
Not charged for ^d pkt, ^d byte & ^d seconds; was^[ not^] purged.",
		process_id_to_match, total_packets, total_bytes,
		total_connect_seconds, ^purge_bit);
	end;

     end CHECK_NETWORK_ACCOUNTING_USE;
%page;
UPDATE_NETWORK_ACCOUNTING: proc (p);

/* routine to update PDT entry for user defined by p->utep.
   When this routine is called, the PDT is locked. */

dcl  p ptr;					/* utep to update */

dcl  found_entry bit (1);
dcl  net_indices_initialized bit (1) int static init ("0"b);
dcl  net_indx fixed bin;				/* index into network_account_array */
dcl  total_bytes fixed bin (35);			/* bytes to charge for */
dcl  total_connect_seconds fixed bin (35);		/* connect time to charge for */
dcl  total_packets fixed bin (35);			/* packets to charge for */

	if network_account_array_ptr = null then
	     return;

	utep = p;

/* scan through the network_account_array looking for 1st entry for this
   process ID.   Since the array is in ascending order based on the
   processid ID, we can stop if we hit an entry greater than the PID being
   scanned for.

   I know this is a brute force method but it will work for now */

	total_bytes, total_packets, total_connect_seconds = 0;
	total_dsa_charges = 0.0;
	found_entry = "0"b;

	do net_indx = 1 to network_account_array.count;
	     if ute.proc_id = network_account_array.process_id (net_indx) then do;
		total_bytes = total_bytes + network_account_array.byte_count (net_indx);
		total_packets = total_packets + network_account_array.packet_count (net_indx);
		total_connect_seconds = total_connect_seconds + network_account_array.connect_time (net_indx);
		network_account_array.accounting (net_indx) = "1"b; /* show entry accounted for */
		found_entry = "1"b;
	     end;
	     else if network_account_array.process_id (net_indx) > ute.proc_id then
		goto table_scan_done;
	end;
table_scan_done:
	if ^found_entry then return;			/* no entries in table for this user */

/* initialize network charge device indices if not already done so */
	if ^net_indices_initialized then
	     call INIT_NET_DEVICE_INDICES;

/* now update the data in the PDT */
	if total_bytes > 0 & devtab_ix_dsa_kilobyte > 0 then
	     call CHARGE_DEVICE (devtab_ix_dsa_kilobyte, float (total_bytes, 63) / 1000);
	if total_packets > 0 & devtab_ix_dsa_kilopacket > 0 then
	     call CHARGE_DEVICE (devtab_ix_dsa_kilopacket, float (total_packets, 63) / 1000);
	if total_connect_seconds > 0 & devtab_ix_dsa_hour > 0 then
	     call CHARGE_DEVICE (devtab_ix_dsa_hour, float (total_connect_seconds, 63) / 3600);

	if debug_na_sw then do;
	     call sys_log_ (SL_LOG_SILENT,		/* DEBUG */
		"act_ctl_$update: Added ^d pkts, ^d bytes & ^d connect seconds (total cost = $^.2f) to ^a.^a",
		total_packets, total_bytes, total_connect_seconds, total_dsa_charges, ute.person, ute.project);
	end;

     end UPDATE_NETWORK_ACCOUNTING;
%page;
CHARGE_DEVICE: proc (P_device_index, P_quantity);

dcl  P_device_index fixed bin;
dcl  P_quantity float bin (63);

	cost = rs_ptrs (ute.rs_number) -> rate_structure.device_price (P_device_index, anstbl.shift) * P_quantity;
	user.devices (P_device_index) = user.devices (P_device_index) + cost;
	user.dollar_charge = user.dollar_charge + cost;
	user.absolute_spent = user.absolute_spent + cost;
	ute.session_cost = ute.session_cost + cost;

/* ********************
   We should probabily make a decision when MNA becomes active to add
   this charge to static_total_dollar_charge and display total_dsa_charges
   as total_mna_charges on the shutdown line
   ******************** */

	total_dsa_charges = total_dsa_charges + cost;

     end CHARGE_DEVICE;



INIT_NET_DEVICE_INDICES: proc;

/* locate indices in installation parms device table for network data if not already found */
	do devtab_ix_dsa_kilobyte = 1 to installation_parms.ndevices
	     while (installation_parms.devtab (devtab_ix_dsa_kilobyte).device_id ^= dev_id (dev_dsa_kilobyte));
	end;
	if devtab_ix_dsa_kilobyte = installation_parms.ndevices + 1 then
	     devtab_ix_dsa_kilobyte = 0;

	do devtab_ix_dsa_kilopacket = 1 to installation_parms.ndevices
	     while (installation_parms.devtab (devtab_ix_dsa_kilopacket).device_id ^= dev_id (dev_dsa_kilopacket));
	end;
	if devtab_ix_dsa_kilopacket = installation_parms.ndevices + 1 then
	     devtab_ix_dsa_kilopacket = 0;

	do devtab_ix_dsa_hour = 1 to installation_parms.ndevices
	     while (installation_parms.devtab (devtab_ix_dsa_hour).device_id ^= dev_id (dev_dsa_hour));
	end;
	if devtab_ix_dsa_hour = installation_parms.ndevices + 1 then
	     devtab_ix_dsa_hour = 0;

     end INIT_NET_DEVICE_INDICES;

/* format: off */
%page; %include absentee_user_table;
%page; %include access_mode_values;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_meter_numbers;
%page; %include as_meter_table;
%page; %include as_wakeup_priorities;
%page; %include author_dcl;
%page; %include devid;
%page; %include dialup_values;
%page; %include daemon_user_table;
%page; %include installation_parms;
%page; %include network_account_array;
%page; %include pdt;
%page; %include rate_structure;
%page; %include sat;
%page; %include sc_stat_;
%page; %include sys_log_constants;
%page; %include terminate_file;
%page; %include ttyp;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;

%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   act_ctl_: accounting disabled

   S:	as (severity1)

   T:	May occur at any time.

   M:	The accounting system has been disabled by a call to
   act_ctl_$act_ctl_disable.

   A:	$ignore


   Message:
   act_ctl_: accounting enabled.

   S:	as (severity1)

   T:	May occur at any time.

   M:	The accounting system has been enabled, probably after a
   special session, by a call to act_ctl_$act_ctl_reable.

   A:	$ignore


   Message:
   act_ctl_: alarm clock late or failing by XX.XX mins

   S:	as (severity1)

   T:	$run

   M:	The alarm clock channel has not caused an accounting update
   to be performed when it was due. (The time between updates is stored
   in the segment installation_parms.) The system performs a manual
   accounting update.
   This message may appear if the system has entered BOS, and Multics has then been restarted by the GO command.  In such case,
   the message can be ignored.

   A:	$note


   Message:
   act_ctl_: MODE update: users = NN, pf=XX, vcpu=YY.Y, rt=ZZ.Z MESSAGE

   S:	as (severity1)

   T:	$run

   M:	Periodically, the accounting programs read and store the CPU usage
   for each user.  This message is printed when the update completes.
   MODE may be 'Automatic', in which case the update occurred at the normal
   system parameter time; 'Manual', where the normal update didn't occur;
   or 'Shift Cmnd' where the update occurred due to a shift command.
   XX is the number of page faults taken by Initializer for update.
   YY.Y is the virtual CPU time taken by Initializer for update.
   ZZ.Z is the real time taken by Initializer for update.
   MESSAGE may be one or both of the following strings:
   'answer table locked' or 'install(s) pending'

   A:	$ignore
   The number of seconds between accounting updates is a system parameter
   that an installation may change; it is stored in the segment
   installation_parms.


   Message:
   act_ctl_: bumping absNN NAME.PROJ - inactive too long

   S:	as (severity1)

   T:	$run

   M:	The absentee job on absentee slot NN for user NAME.PROJ
   has remained blocked too long. (The inactive time limit is
   stored in the segment installation_parms.) The absentee job
   is bumped.

   A:	$ignore


   Message:
   act_ctl_: bumping absXX NAME.PROJ - too much time

   S:	as (severity1)

   T:	$run

   M:	The absentee job on absentee slot XX for the user
   NAME.PROJ has exceeded the CPU time limit for the queue. (This
   limit is stored in the segment installation_parms.)
   The absentee job is bumped.

   A:	$ignore


   Message:
   act_ctl_: bumping NAME.PROJ for inactivity

   S:	as (severity1)

   T:	$run

   M:	The user with name NAME and project PROJ has been inactive too
   long, and is bumped off the system.  The maximum inactive time
   is stored in the segment installation_parms.

   A:	$ignore


   Message:
   act_ctl_: bumping NAME.PROJ. REASON

   S:	as (severity1)

   T:	$run

   M:	The user with name NAME and project PROJ has been bumped
   because some per-user limit has been exceeded. REASON tells what was
   wrong; it will be a message such as "User resource limit of
   $100 monthly exceeded," depending on which user limit has
   been exceeded.

   A:	$ignore


   Message:
   act_ctl_$init: cannot locate Initializer.SysDaemon pdt entry

   S:	as (severity2)

   T:	$init

   M:	The accounting system requires the entry for Initializer in
   the project SysDaemon to be present because certain system metering
   figures are kept there.  This entry cannot be found, either because
   SysDaemon.pdt has been lost, or because its contents have been destroyed.  The
   system will probably encounter a simfault_xxx error and be unable to
   start up.

   A:	$contact
   Do not attempt to
   run the system until this problem has been fixed.


   Message:
   act_ctl_: changing shift from x to y

   S:	as (severity1)

   T:	$run

   M:	The current accounting shift has changed.
   The table that tells the beginning time for each shift is stored
   in the segment installation_parms.

   A:	$ignore


   Message:
   act_ctl_: charged X, available Y mins

   S:	as (severity0)

   T:	$run

   M:	X is the sum of virtual CPU time charged to all processes and Y is the total virtual CPU time used by all processes.
   This message logs detailed accounting information and appears whenever the message "act_ctl_: discrepancy of XX.XX mins" appears.

   A:	$ignore


   Message:
   act_ctl_: discrepancy of XX.XX mins

   S:	as (severity1)

   T:	$run

   M:	The total time available from traffic control does not agree
   with the total time charged to users plus the Initializer time plus
   the idle time.  Some process has escaped being accounted for.

   A:	$inform_sa


   Message:
   act_ctl_$init: ERROR_MESSAGE. creating update channel

   S:	as (severity2)

   T:	$init

   M:	The timer channel that causes accounting updates to be performed
   could not be created.  All accounting updates will be manual,
   triggered by a user logging out.

   A:	$inform

   Message:
   act_ctl_: Lock wait time exceeded.  While destroying proc for NAME.PROJ

   S:	as (severity2)

   T:	$run

   M:	The accounting system was unable to lock the PDT entry for the
   user NAME in the project PROJ within its time limit (usually five minutes)
   This user attempted to log out or destroy a process.  The
   entry was probably locked because a system administrator or daemon process
   locked the entry and then failed.  The system attempts
   to continue.

   A:	$inform_sa


   Message:
   act_ctl_: process XXXXXXXXXXXX for NAME.PROJ vanished

   S:	as (severity2)

   T:	$run

   M:	Traffic control cannot locate a process for a user who should
   have one according to accounting.  The system attempts to run
   normally, but this user is not charged.  An attempt is
   made to bump the user in question.  This may be the first indication
   that the segment >system_control_1>answer_table has been damaged.

   A:	$note


   Message:
   act_ctl_: STRING for USER.PROJ is negative (NUM) at logout;
	 set it to zero.

   S:	as (severity2)

   T:	$run

   M:	A counter value of STRING was decremented by 1 and went negative.
   It was noticed when attempting to log out USER  on the PROJ project.
   This is a sign of possible damage to the PROJ pdt.

   A:	$note


   Message:
   act_ctl_$update: Processid XXXXXXXX missing.
   Not charged for XX pkt, YY byte and ZZ seconds; was/was not purged.

   S:	as (severity2)

   T:	$run

   M:	After charging network accounting usage for all users on the system,
   an entry was found for processid XXXXXXXX.  The XX, YY and ZZ are counts of
   the usage which the process had.  If the entry was for a process which is 
   no longer logged in, the accounting record was purged from the network 
   accounting file.

   A:	$note


   Message:
   act_ctl_: shutdown, NNN WW.WW XX.XX YY.YY ZZ.ZZ HH:MM:SS $DDD.DD

   S:	as (severity1)

   T:	$shut

   M:	A successful shutdown of the accounting portion of the system
   has been accomplished. NNN logins were recorded, for a total usage
   of HH:MM:SS of CPU time charged.  The other numbers are of interest
   to system administrators and programmers. WW.WW is the average queue
   length, XX.XX is the average eligible, YY.YY is the thrashing index,
   ZZ.ZZ is the average response, and DDD.DD is the total dollar charge
   since startup.  A shutdown of the hardcore system follows this
   message.

   A:	$ignore


   Message:
   act_ctl_$init: ERROR_MESSAGE. Cannot unlock PDT PATHNAME.

   S:	as (severity2)

   T:	$init

   M:	This message occurs during answering service initialization
   when attempting to unlock all PDTs.  ERROR_MESSAGE specifies the
   the reason for the problem.  The PDT is skipped.  Later problems
   may arise because of this error.
        
   A:	$inform

   Message:
   act_ctl_$init: The PDT is damaged. Cannot unlock PATHNAME.

   S:	as (severity2)

   T:	$init

   M:	This message occurs during answering service initialization
   when attempting to unlock all PDTs.  The specified PDT had its
   damaged switch turned on.  Because of this, it was not unlocked
   from the previous bootload.  It is skipped.  Later problems may
   arise when an attempt is made to reference this PDT.
        
   A:	$inform

   Message:
   act_ctl_$update: Error from ROUTINE: MESSAGE

   S:	as (severity2).

   T:	$run

   M:	The system encountered problems while referencing the
	network_accounting_table.  The network_accounting_ ROUTINE being
	called and MESSAGE text further describe the error.

   A:     $inform


   Message:
   act_ctl_$update: Net accounting array version (VERSION_RETURNED) not 
   supported.  Expected version (VERSION_SUPPORTED)

   S:	as (severity2).

   T:	$run

   M:	network_accounting_gate_$read_and_reset_table returned a structure
   version which act_ctl_ does not support.  $err

   A:     $contact_sm


   Message:
   act_ctl_$dp: Net accounting array version (VERSION_RETURNED) not 
   supported.  Expected version (VERSION_SUPPORTED)

   S:	as (severity2).

   T:	$run

   M:	network_accounting_gate_$read_and_reset_table returned a structure
   version which act_ctl_ does not support.  $err

   A:     $contact_sm


   Message:
   act_ctl_$init: illegal value (DD) for accounting update interval in installation_parms.

   S:	as (severity2)

   T:	$init

   M:	The value given in installation_parms.acct_update is less than or 
   equal to zero.  The installation_parms file is probabily damaged.

   A:	$contact
   Do not attempt to
   run the system until this problem has been fixed.


   END MESSAGE DOCUMENTATION */

     end act_ctl_;




		    as_data_.alm                    08/04/87  1506.2rew 08/04/87  1222.6      156060



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

" AS_DATA_ - external static constants for bound_user_control_
"
" This file must be kept in sync with as_data_.incl.pl1

" VERSION	DATE	EXPLANATION
"
" 1.0	1967	Phase 1 version
" 2.0	1968	Phase 2 version
" 3.0	1969	IS-1 version
" 4.0	10/1/69	First public version
" 5.0	11/1/70	Spier version
" 5.01	1/8/71	Nov 70 ttydim (THVV)
" 5.04	3/30/71	PNT hash table (KAW/THVV)
" 5.06	6/03/71	absentee
" 5.07	6/16/71	ring 1 daemons
" 5.11	8/12/71	ucs handler in dialup
" 5.18	1/06/72	help function
" 5.20	2/02/72	load control

" 6.0	4/19/72	New accounting (THVV, JP)
" 6.03	5/05/72	infinite absentee args
" 6.05	6/13/72	response control
" 6.06	7/13/72	limit stops
" 6.07	7/19/72	system admin in SAT, abs timax parameter
" 6.08	08/11/72	version number, memory charging, pw changing
" 6.09	08/28/72	as_dump_, count bad pw's, ucs for update & abs
" 6.10	09/29/72	put entire answering service in v2pl1.
" 6.11	11/25/72	eliminate old accounting. add tape and daemon. add process params.
" 6.12	1/73	eliminate test mode. add as_error_table_
" 7.0	3/21/73	virtual cpu. message coordinator. many fixes (6180 only)
" 7.1	4/30/73	no_warning sw, -ring, restore shutdown
" 7.2	5/22/73	rework config reading
" 7.3	8/28/73	compress dcl of pnt
" 7.4	1/07/74	new destroy_proc, no wait in ring 0 (MCR 164)
" 7.4a	1/11/74	fix bugs in 7.4 (MCR 304)
" 7.5	6/18/74	Many small fixes (MCR 318)
" 7.6	7/17/74	More fixes
" 7.7	3/31/75	Optimal sized hash tables - TAC (MCR 1035)
" 7.8	4/15/75	new ttydim (MCS) compatibility - PG (MCR 1089)
" 8.0	6/1/75	Access Isolation Mechanism - PG (MCR 714)
" ----------------  Release of MR2.2
" 8.1	7/15/75	RCP (WSS), Priority Scheduler (TAC), and Syserr Logging (LJS)
" 8.2	8/1/75	MCS Phase II changes (Corr 2741, ETX TN1200, CDT) (PG & THVV)
" ----------------  Release of MR3.0
" 8.3	10/24/75	-subsystem login arg, to get prelinked subsystem (TAC)
" ...     ........  miscellaneous bug fixes & fixes for upcoming tty/network dim changes (PG)
" ----------------  Release of MR3.1
"(8.4)	04/23/76  autocall facility (D. Jordan)
" 8.5	05/01/76  detection of process initialization failures and fatal process error
" ...	........  loops, verifying new passwords with -cpw, and misc. bug fixes (TAC),
" ...     ........  and more misc. bug fixes (PG)
" 8.6	06/01/76	fix pw mask handling, add resetreads, minor fixes (PG)
" ...     ........  shift command, per-user cutoff warning thresholds, misc. bug fixes (TAC)
" ----------------	Release of MR4.0
" 8.7	06/28/76	Implement FTP service_type in cdt, call net_as_$ftp_dialup to manage FTP
" ...	........	channels. Add transfer vector ftp_as_ (R. Planalp, D. Wells)
" 8.8     08/19/76  Move ftp_dialup_ into bound_user_control_, modify many modules to enable
" ...	........  AS to talk FTP language directly. Add mail sending, fix misc bugs (RPP)
" 9.0	08/03/76	Implement Multics bootload of FNPs, version 2 CDT (M. Grady)
" ...	........	Add fnp_manager_, modify as_init_ asu_ and admin for FNPs (TAC)
" 9.0a	10/26/76  Bug fixes to 9.0
" 9.1	10/29/76	Change MGT and add lv_request_ calls. TAC
" 9.1a	11/30/76  Fix bugs in management of FNPs and TTY channels. TAC
" ----------------	Release of MR5.0
" 9.2     02/04/77  Add registered dial channels, put more info into PIT,
" ...	........	change login message to Network users. (D. Wells, S. Kent)
" 9.2a	04/30/77	Fix bug whereby users logging into AS 9.2 for the first
"		time got the wrong term type printed for "last login"
" 9.3	06/24/77	Change terminal type management to use names and to obtain
" ...	........	terminal type info from the TTT
" 9.4 	08/30/77	Charge separately for tty and connect time, prepare for
" ...	........	tape and disk charging, fix bugs. FCS, DRV, TAC
" 9.5	09/19/77	Process directory placement, misc. bug fixes. TAC
" ----------------  Release of MR6.0
" 9.5a	01/11/78	Fix bugs in as9.5
" ----------------	Release of MR6.1
" 9.6	05/xx/78	Install and use the RTDT. C.D.Tavares
" 9.7	06/02/78	Send term signal to process being bumped, absentee enhancements (first
" ...	........	batch), variable size pdirs, shift_config_change.ec, misc bug fixes. TAC
" ----------------  Release of MR6.5
" 9.7a	10/xx/78	Fix bugs in proxy absentee job handling. TAC
" 9.8	11/xx/78	Use hash tables for SAT and PDT lookups during logins. TAC
" 10.0	12/15/78	Ring-0 demultiplxing, multiplexer_mgr_, new channel names and sizes. LEJ
" 10.1	12/29/78	Absentee enhancements, phase 1 of second batch. TAC
" ----------------	Release of MR7.0
" 10.2	01/22/79	Change names of default IOSIMS to use iox_. CAH
" 10.3	04/06/79	Absentee enhancements, phase 2 of second batch. Bug fixes, abs suspend. TAC
" 10.4	05/02/79	Bug fixes to 10.3, TAC. Non-MCS FNP, release_channel_no_hangup. LEJ.
"(10.4a)	06/xx/79	Last minute bugfixes for MR7.0a. MCR 3955. TAC
" ----------------	Release of MR7.0a
"(10.5x)	07/27/79	Process preservation across hangups. TAC
"(10.6x)	08/07/79	New pre-access commands modes, echo, terminal_type. LEJ
" 11.0	09/14/79	Rewrite of PNT management to remove size restriction. CAH
" 11.0a	11/27/79	Bug fixes for process preservation. TAC
" ----------------	Beta Test Release of MR8.0
"(11.1)	02/01/80	PNT salvager and bug fixes to PNT software. CAH
" 11.2	02/07/80	Bug fixes to process preservation. TAC
" ----------------	Release of MR8.0
"(11.3)	04/xx/81	Fixes and improvements to dial facility. ENK
" 11.4	06/19/81	AS meters, performance improvements, bugfixes. TAC, ENK, BIM, RSC
" 11.5	07/10/81	UofC accounting changes (multiple rate structures). TAC & ENK for UOFC
" 11.6    08/19/81  Bugfixes problems in AS11.5 accounting changes. ENK & TAC
" ----------------	Release of MR9.0
" 11.7b   12/21/81  Submitted version of AS11.7 & AS11.7a - user_table_entry conversion. ENK.
" 12.0    03/12/82	whotab header. attributes.incl change.  PDT user_warn fields. Fixed bugs.
"		bound_user_control_ => bound_user_ctl_,bound_as_misc_,bound_absentee_ctl_,
"		   bound_as_install_ctl_,bound_ftp_ctl_,bound_daemon_ctl_. ENK
"		New CDT threading strategy. BIM.
"		Re-organized bound_as_mpx_,bound_io_tools_,bound_comm_meters_,bound_admin_tools_. CAH
" 12.1	4/12/82	Various bugfixes. ENK. first phase of initialization changes.
" 12.2	6/10/82	MR10.0 emergency fixes.
" 12.2a   7/01/82   More of the same, in cdt management. BIM
" 12.2b	7/08/82	More of the same, mux_mgr_ early stop_mpx. ENK
" ----------------	Release of MR10.0
" 12.3	7/12/82	Support for re-attaching MCS-ostracized channels. ENK.
" 12.4	9/06/82	dial/slave -user. ENK
" 12.5	10/19/82	bugfixes, as_request_server_. ENK
" 12.5a	11/16/82  fixes to CDT management, unmasking changes. BIM, ENK.
" 12.5b	11/29/82	fix ec-caller command_question, mux failure during init. ENK
" ----------------  Release of MR10.1
" 12.6	05/16/83	generic dial_out destinations (KPL), sty AIM support, etc. ENK.
" 12.7	10/18/83	Mail table support. GMP, Barmar
" 12.8	01/06/84  Added -terminal_id control argument and preaccess command. CLM
" 13.0x   84-06-19  BIM Added most of Channel AIM support.
" 13.1x   84-06-20  BIM Added strict_trusted_path to above, fixed bugs.
" 14.0x   84-07-20  BIM Added login authorization ranges.
" 14.1x 1984-08-01  BIM Recompiled everything in site, promoted, fixed
"		    bug in dialup_.
" 14.2  1984-08-27  BIM Audit changes and bugfixes, submitted for installation.
" 14.2a 1984-09-13  BIM PBF -- initialize anstbl.max_users from tcd config 
"		    card.
" 14.2b 1984-09-16  BIM minor fix to above.
" 14.2c 1984-10-01  BIM PBF -- fix COLTS by fixing bugs in tandd_attach
"		    in dial_ctl_.
" 15.0  1984-11-29  EJS Ring 1 PNT installation. Also new acs directory
"		    (>sc1>admin_acs).
" 16.0  1984-12-04  BIM New System Control, iox message coordinator.
" 16.1  1985-02-20  BIM AS auditing, PBF's to much of the above,
"		daemon command server, com channel info server.
"
" Version in parentheses was installed without updating version number.
" Version ending in a, b, etc. was bugfixes with no new features.
" Version ending in x was experimental and not installed separately.
" Integer part of version number is incremented for major changes,
"  involving restructuring of databases or significant functional changes.

" HISTORY COMMENTS:
"  1) change(86-09-21,Beattie), approve(86-09-22,MCR7542),
"     audit(86-10-31,Brunelle), install(86-11-12,MR12.0-1211):
"     Remove references to the 963 and 029 preaccess commands and
"     remove support for ARDS, 202_ETX, 2741 and 1050 in system
"     interfaces. (version 16.2)
"  2) change(86-09-25,Swenson), approve(87-07-20,MCR7737),
"     audit(87-07-20,GDixon), install(87-08-04,MR12.1-1055):
"     Add fields to support the Login Server User Control environment.
"     This is Answering Service 17.0.
"  3) change(87-03-03,Brunelle), approve(87-07-14,MCR7697),
"     audit(87-07-20,GDixon), install(87-08-04,MR12.1-1055):
"     Added new user signal field of inacrcvd (12) to handle inactivity
"     response from user.
"  4) change(87-04-08,Parisek), approve(87-07-14,MCR7644),
"     audit(87-07-20,GDixon), install(87-08-04,MR12.1-1055):
"     Added disconn (10) to the user signals list.
"                                                      END HISTORY COMMENTS
	name	as_data_
	segdef	BEL
	segdef	CR
	segdef	BS
	segdef	version
	segdef	debug_flag
	segdef	login_words
	segdef	signal_types
	segdef	system_signal_types

	segdef	tty_dim
	segdef	ntty_dim
	segdef	mrd_dim
	segdef	abs_dim
	segdef	g115_dim

	segdef	login_args
	segdef	default_weight
	segdef	as_ring
	segdef	dft_user_ring
	segdef	max_user_ring

	segdef	teens_suffix
	segdef	suffix

	segdef	acct_update_priority
	segdef	request_priority
	segdef	update_priority
	segdef	terminet_tabs_string

	segdef	acsdir
	segdef	ansp
	segdef	as_procid
	segdef	as_tty
	segdef	asmtp
	segdef	autp
	segdef	buzzardp
	segdef	cdtp
	segdef	devtabp
	segdef	dutp
	segdef	ip
	segdef	lct_initialized
	segdef	lct_size
	segdef	ls_request_server_info_ptr
	segdef	ls_message_buffer_cur_lth
	segdef	ls_message_buffer_max_lth
	segdef	ls_message_buffer_ptr
	segdef	mgtp
	segdef	pdtdir
	segdef	pit_ptr
	segdef	rs_ptrs
	segdef	rcpdir
	segdef	rtdtp
	segdef	sat_htp
	segdef	satp
	segdef	sysdir
	segdef	whoptr
	
version:	aci	"17.0",8		dcl as_data_$version char(8)



BEL:	oct	007000000000

CR:	oct	015000000000

BS:	oct	010000000000

default_weight:
	dec	10

as_ring:	dec	4			"Change to 1 someday.
dft_user_ring:
	dec	4		"default user ring number
max_user_ring:
	dec	7		"highest ring number user can get at whotab

login_words:
	zero	0,((last_login_wd-first_login_wd+3)/4)	"number of login words
	dec	0		"padding
first_login_wd:
	aci	"l",16			1
	aci	"login",16		2
	aci	"e",16			3
	aci	"enter",16		4
	aci	"ep",16			5
	aci	"enterp",16		6
	aci	"d",16			7
	aci	"dial",16			8
	aci	"help",16			9
	aci	"HELP",16			10
	aci	"MAP",16			11
	aci	"hello",16		12
	aci	"slave",16		13
	aci	"modes",16		14
	aci	"echo",16			15
	aci	"terminal_type",16		16
	aci	"ttp",16			17
	aci	"logout",16		18
	aci	"hangup",16		19
	aci	"list",16			20
	aci	"create",16		21
	aci	"connect",16		22
	aci	"new_proc",16		23
	aci	"destroy",16		24
	aci	"noecho",16		25
	aci	"terminal_id",16		26
	aci	"tid",16			27
          aci       "access_class",16             28
          aci       "acc",16                      29
	equ	last_login_wd,*

signal_types:
	zero	0,((last_user_sig-first_user_sig+1)/2)	"number of user signal types
	dec	0
first_user_sig:
	aci	"terminat",8	1
	aci	"new_proc",8	2
	aci	"login",8		3
	aci	"logout",8	4
	aci	"lobrief",8	5
	aci	"lhbrief",8	6
	aci	"init_err",8	7
	aci	"no_ioatt",8	8
	aci	"no_initp",8	9
	aci	"disconn",8	10
	aci	"old_args",8	11	obsolete
	aci	"inacrcvd",8	12
	aci	"np",8		13 (never matches, just reserve slot)
	aci	"termsgnl",8	14
	equ	last_user_sig,*

system_signal_types:
	zero	0,((last_system_sig-first_system_sig+1)/2)	" number of system signals
	dec	0
first_system_sig:
	aci	"hangup",8	1
	aci	"shutdown",8	2
	aci	"bump",8		3
	aci	"alarm___",8	4
	aci	"detach",8	5
	aci	"unbump",8	6
	aci	"stopstop",8	7
	aci	"terminat",8	8
	aci	"termstop",8	9
	aci	"cpulimit",8	10
	equ	last_system_sig,*

tty_dim:	aci	"tty_",32
ntty_dim:	aci	"netd_",32
mrd_dim:	aci	"mr_",32
abs_dim:	aci	"abs_io_",32
g115_dim:
	aci	"g115_",32

login_args:
	zero	0,((last_option-first_option+5)/6)	" 6 words per entry.
	dec	0
first_option:
	aci	"-bf",24				 1
	aci	"-brief",24			 2
	aci	"-hd",24				 3
	aci	"-home_dir",24			 4
	aci	"-po",24				 5
	aci	"-process_overseer",24		 6
	aci	"-npf",24				 7
	aci	"-no_print_off",24			 8
	aci	"-pf",24				 9
	aci	"-print_off",24			10
	aci	"-nw",24				11
	aci	"-no_warning",24			12
	aci	"-np",24				13
	aci	"-no_preempt",24			14
	aci	"-force",24			15
	aci	"-md",24				16
	aci	"-mode",24			17
	aci	"-modes",24			18
	aci	"-ns",24				19
	aci	"-no_start_up",24			20
	aci	"-cpw",24				21
	aci	"-change_password",24		22
	aci	"-cdp",24				23
	aci	"-change_default_project",24		24
	aci	"-om",24				25
	aci	"-outer_module",24			26
	aci	"-auth",24			27
	aci	"-authorization",24			28
	aci	"-cda",24				29
	aci	"-change_default_auth",24		30
	aci	"-gpw",24				31
	aci	"-generate_password",24		32
	aci	"-ttp",24				33
	aci	"-terminal_type",24			34
	aci	"-ss",24				35
	aci	"-subsystem",24			36
	aci	"-rg",24				37
	aci	"-ring",24			38
	aci	"-save_on_disconnect",24		39
	aci	"-save",24			40
	aci	"-no_save_on_disconnect",24		41
	aci	"-nosave",24			42
	aci	"-list",24			43
	aci	"-create",24			44
	aci	"-connect",24			45
	aci	"-new_proc",24			46
	aci	"-destroy",24			47
	aci	"-no_hold",24			48
	aci	"-hold",24			49
	aci	"-im",24				50
	aci	"-immediate",24			51
	aci	"-ag",24				52
	aci	"-arguments",24			53
	aci	"-lg",24				54
	aci	"-long",24			55
	aci	"-warning",24			56
	aci	"-user",24			57
	aci	"-tid",24				58
	aci	"-terminal_id",24			59
	equ	last_option,*			" must come after last login option.

suffix:
	aci	"thstndrdthththththth"	"dcl as_data_$suffix dim (0:9) char (2) unal static;
					"0th, 1st, 2nd, 3rd, 4th, 5th, 6th, 7th, 8th, 9th.

teens_suffix:
	aci	"thththththththththth"	"dcl as_data_$teens_suffix dim (10:19) char (2) unal static;
					"10th, 11th, 12th, 13th, 14th, 15th, 16th, 17th, 18th, 19th.

acct_update_priority:			"used by act_ctl_$update.
	dec	1
request_priority:				"used by as_request_$wakeup.
	dec	1
update_priority:				"used by up_sysctl_.
	dec	5

terminet_tabs_string:
	dec	138	"dcl as_data_$terminet_tabs_string char (144) varying external;
	vfd	o9/33,o9/62,o9/15,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/40,o9/33
	vfd	o9/61,o9/15

" NOTE: all following definitions are in the static section

	use	static
ansp:	its	-1,1			"answer_table pointer
asmtp:	its	-1,1			"as meter table pointer
autp:	its	-1,1			"absentee_user_table pointer
buzzardp:	its	-1,1			"dpg_ list of buzzard processes
cdtp:	its	-1,1			"Channel Definition Table pointer
devtabp:	its	-1,1			"device table pointer
dutp:	its	-1,1			"daemon_user_table pointer
ls_message_buffer_ptr:			"pointer to message buffer 
	its	-1,1
ls_request_server_info_ptr:		          "pointer to ls server info
	its	-1,1
mgtp:	its	-1,1			"master group table pointer
pit_ptr:	its	-1,1			"template pit_ptr pointer
ip:	bss	,0			"installation_parameters
rs_ptrs:	its	-1,1			"rate_structure (0) pointer
	its	-1,1			" 1
	its	-1,1			" 2
	its	-1,1			" 3
	its	-1,1			" 4
	its	-1,1			" 5
	its	-1,1			" 6
	its	-1,1			" 7
	its	-1,1			" 8
	its	-1,1			" 9
rtdtp:	its	-1,1			"RTDT pointer
sat_htp:	its	-1,1			"sat hash table pointer
satp:	its	-1,1			"sat pointer
whoptr:	its	-1,1			"whotab pointer
as_procid:				"AS process id
	zero	-1,-1
as_tty:	aci	"??????",6		"AS tty
lct_initialized:				"TRUE if ring0 LCT allocated.
	dec	0
lct_size:	dec	0			"number of channels in LCT.
pdtdir:	aci	"<as_data_$pdtdir>",168	"pdt directory
rcpdir:	aci	"<as_data_$rcpdir>",168	"RCP directory
sysdir:	aci	"<as_data_$sysdir>",168	"AS system control dir
acsdir:	aci	"<as_data_$acsdir>",168	"AS Access Control Segment dir
ls_message_buffer_max_lth:			"max length of ls buffer
	dec	0
ls_message_buffer_cur_lth:			"current length of ls buffer
	dec	0
debug_flag:
	dec	0			"are we debugging
	use	.text.
	join	/static/static
	end




		    as_meter_.pl1                   08/04/87  1506.2rew 08/04/87  1222.6      244332



/****^  ***********************************************************
        *                                                         *
        * 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: style4 */
as_meter_: proc (a_tcpu, a_tidle, a_uidle, a_respons, a_wspage, a_thrash, a_avelig, a_avquln);


/* AS_METER_ - procedure to obtain system metering figures for answering service.

   This program copies the header of the SST and the header of TC_DATA
   from ring 0 and derives some useful figures from the data.

   It also reads the configuration deck and sets data about the configuration
   into a special data base.

   It also contains entry points used for metering answering srvice resource usage: asmt_(init enter exit exit_values).
*/

/* * 	Modification history:
   *	71-02-15, THVV: Based on the "tcm" command by Webber
   *	77-04-12, THVV: Modified to use ring 0 defs and to flush core and AST
   *	77-08-21, B. Greenberg: Modified for syserr log scan.
   *	80-03-02, Tom Casey: Modified to add metering of answering
   *	   service resource usage.
   *	80-11-10, Richard Lamson: Modified to fix untimely death of
   *	   core flush mechanism
   *	81-01-10, E. N. Kittlitz: Modified to only count ON CPUs as ON.
   *	81-02-21, J. Bongiovanni: Modified for system virtual time
   *	81-06-05, T. Casey: Modified for MR9.0 to meter the cost of
   *	   doing the answering service metering.
   *	81-07-23, T. Casey: Modified for MR9.0 to fix bug in handling
   *	   of recursive entries.
   *	81-08-17, T. Casey: Modified for AS11.6, MR9.0, to change
   *	   switches in asmt from bit to fixed bin.
   *	81-11-20, E. N. Kittlitz: Modified for user_table_entry conversion.
   *	82-05-01, E. N. Kittlitz: Modified for new AS initialization.
   *	83-06-08, E. N. Kittlitz: Modified to use config_.
   *	84-01-20, BIM: Removed PML support.
   *	84-10-18, Allen Ball: Modified to reflect in syserr messages
   *	   that there is no more `FDUMP`s.
   *	84-11-11, W. Olin Sibert: Moved syserr log segment damage scan
   *	   mechanism to syserr_log_man_
*/

/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  2) change(87-04-27,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1.
  3) change(87-07-23,Brunelle), approve(87-07-23,MCR7741),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Changed to use sys_log_constants constants on sys_log_ calls.
                                                   END HISTORY COMMENTS */

/* DECLARATIONS */

/* Parameters */

dcl  a_tcpu fixed bin (71);				/* total cpu time available */
dcl  a_tidle fixed bin (71);				/* total idle time */
dcl  a_uidle fixed bin (71);				/* "usable" idle (exclude mp idle) */
dcl  a_respons float bin;				/* estimated response in secs */
dcl  a_wspage fixed bin;				/* number of working-set pages */
dcl  a_thrash float bin;
dcl  a_avelig float bin;
dcl  a_avquln float bin;				/* average queue lth */
dcl  slot_no fixed bin;
dcl  a_pf fixed bin;
dcl  a_vcpu fixed bin (71);
dcl  a_rt fixed bin (71);

/* Automatic */

/* binary */
dcl  damage_count fixed bin (35);
dcl  delta_pf fixed bin (34);
dcl  delta_real_time fixed bin (71);
dcl  delta_vcpu fixed bin (71);
dcl  dump_lth fixed bin;
dcl  ec fixed bin (35);
dcl  i fixed bin;
dcl  now fixed bin (71);
dcl  pf fixed bin;
dcl  sst_buffer (512) fixed bin;
dcl  steps fixed bin (35);
dcl  vcpu fixed bin (71);
dcl  (factor, pre_calls, post_calls, temp) float bin;

/* bit */
dcl  return_values bit (1) aligned;
dcl  (dump_valid, dump_valid_355) bit (1);

/* char */
dcl  crashid char (8) aligned;
dcl  dtstr char (16);
dcl  me char (12);
dcl  (dump_ename, dump_ename_355) char (32) aligned;
dcl  err_msg char (256);

/* ptr */
dcl  asmtep ptr init (null);
dcl  sstp3 ptr;
dcl  (sstp2, tcdp2) ptr;


/* Based */

dcl  asteps (0:3) fixed bin (35) based aligned;
dcl  double fixed bin (71) based aligned;
dcl  1 level (0:3) based aligned,
       2 (ausedp, no_aste) fixed bin (17) unal;
dcl  scaled fixed bin (35, 18) based aligned;
dcl  single fixed bin (35) based aligned;
dcl  words128 (128) fixed bin based;

/* Builtin */

dcl  (addr, addrel, clock, divide, hbound, length, null, ptr, substr) builtin;


/* Entries */

dcl  as_dump_ entry (char (*));
dcl  config_$find entry (char (4) aligned, ptr);
dcl  cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  get_wdir_ entry returns (char (168) aligned);
dcl  hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  hphcs_$flush_ast_pool entry (fixed bin);
dcl  hphcs_$flush_core entry ();
dcl  hphcs_$get_fdump_num entry (fixed bin, bit (1), char (32) aligned, bit (1), char (32) aligned, fixed bin (35));
dcl  ioa_$rsnnl entry options (variable);		/* ctl_str,ret_str,ret_len,...other args ... */
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl  phcs_$ring_0_peek entry (ptr, ptr, fixed bin);
dcl  ring0_get_$definition entry (ptr, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35));
dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  sub_err_ entry () options (variable);
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);
dcl  syserr_log_man_$as_copy_log entry ();
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));

/* External static */

dcl  error_table_$out_of_sequence fixed bin (35) ext static;
dcl  sys_info$max_seg_size fixed bin (35) ext;

/* Internal static */

/* binary - SST and TCM offsets */

dcl  SSTasteps_loc fixed bin (18) static init (0);
dcl  SSTdamage_ct_loc fixed bin (18) static init (0);
dcl  SSTlevel_loc fixed bin (18) static init (0);
dcl  SSTnused_loc fixed bin (18) static init (0);
dcl  SSTpost_purge_calls_loc fixed bin (18) static init (0);
dcl  SSTpre_page_calls_loc fixed bin (18) static init (0);
dcl  SSTpre_page_size_loc fixed bin (18) static init (0);
dcl  SSTthrashing_loc fixed bin (18) static init (0);
dcl  TCMave_eligible_loc fixed bin (18) static init (0);
dcl  TCMavequeue_loc fixed bin (18) static init (0);
dcl  TCMdelta_vcpu_loc fixed bin (18) static init (0);
dcl  TCMidle_loc fixed bin (18) static init (0);
dcl  TCMprocessor_time_loc fixed bin (18) static init (0);
dcl  TCMresponse_count_loc fixed bin (18) static init (0);
dcl  TCMresponse_time_loc fixed bin (18) static init (0);
dcl  TCMsystem_virtual_time_loc fixed bin (18) static init (0);
dcl  TCMworking_set_addend_loc fixed bin (18) static init (0);
dcl  TCMworking_set_factor_loc fixed bin (18) static init (0);
dcl  TCMzero_idle_loc fixed bin (18) static init (0);

/* binary - other */
dcl  MILLION fixed bin (21) static options (constant) init (1000000);
dcl  MAX fixed bin int static init (1);			/* Maximum number of entries. */
dcl  OFFSET fixed bin (71) static options (constant) init (300000000); /* 5 mins */
dcl  core_flush_channel fixed bin (71) static;
dcl  core_flush_time fixed bin (71) static;		/* relative seconds */
dcl  disable_metering bit (1) aligned int static init ("1"b);
dcl  old_ast_steps (0:3) fixed bin (35) static init ((4) 0);
dcl  old_damage_count fixed bin (35) static;
dcl  (ncpu, nmem) fixed bin static;

/* bit */
dcl  asmt_initialized bit (1) aligned int static init (""b);
dcl  debug_sw bit (1) aligned int static init (""b);	/* take asdump on asmt errors, if on */

/* ptr */
dcl  statp ptr int static init (null);			/* pointer to data segment */
dcl  tcdp ptr int static;
dcl  xsstp ptr int static;


/* INCLUDE FILES are at the end, after all the code, but before the message documentation. */

/* MAIN ENTRY POINT as_meter_: proc (eight arguments - see first page) */

	a_tcpu, a_tidle, a_uidle = 0;
	a_respons, a_thrash, a_avelig, a_avquln = 0e0;
	a_wspage = 0;
	if disable_metering then return;

	statistics.index = statistics.index + 1;
	if statistics.index > MAX then do;
	     statistics.index = 1;
	     statistics.wrapped = statistics.wrapped + 1;
	end;

	tcdp2 = addr (statistics.tcdata_contents (statistics.index, 1));
	sstp2 = addr (statistics.sst_contents (statistics.index, 1));
	sstp3 = addr (sst_buffer);

	call phcs_$ring_0_peek (xsstp, sstp3, 512);
	sstp2 -> words128 = sstp3 -> words128;
	call phcs_$ring_0_peek (tcdp, tcdp2, 256);

	a_tcpu = addrel (tcdp2, TCMprocessor_time_loc) -> double - addrel (tcdp2, TCMdelta_vcpu_loc) -> double;
	a_tidle = addrel (tcdp2, TCMidle_loc) -> double;
	a_uidle = addrel (tcdp2, TCMzero_idle_loc) -> double;

	factor = addrel (tcdp2, TCMworking_set_factor_loc) -> scaled;
	pre_calls = addrel (sstp3, SSTpre_page_calls_loc) -> single;
	temp = addrel (sstp3, SSTpre_page_size_loc) -> single;
	if factor = 0e0 then a_wspage = 0;
	else a_wspage = temp / factor - pre_calls * addrel (tcdp2, TCMworking_set_addend_loc) -> single;
	temp = addrel (sstp3, SSTthrashing_loc) -> single;
	post_calls = addrel (sstp3, SSTpost_purge_calls_loc) -> single;
	if post_calls = 0e0 then a_thrash = 0e0;
	else a_thrash = temp / post_calls;

	a_avelig = addrel (tcdp2, TCMave_eligible_loc) -> scaled;
	a_avquln = addrel (tcdp2, TCMavequeue_loc) -> scaled;

	temp = addrel (tcdp2, TCMresponse_time_loc) -> double / 262144e0;
	if addrel (tcdp2, TCMresponse_count_loc) -> single = 0 then a_respons = 0e0;
	else a_respons = temp / addrel (tcdp2, TCMresponse_count_loc) -> single;

/* This section fills in some of the header items in the stat_seg block. */

	call read_deck;

	statistics.time_of = clock ();
	statistics.time (statistics.index) = statistics.time_of;
	statistics.sysid (statistics.index) = substr (whotab.sysid, 1, length (statistics.sysid (statistics.index)));
	statistics.uptime (statistics.index) = whotab.timeup;
	ansp = as_data_$ansp;
	statistics.units (statistics.index) = anstbl.n_units;
	statistics.users (statistics.index) = anstbl.n_users;
	statistics.erfno (statistics.index) = "";	/* System is running now. */
	statistics.crashtime (statistics.index) = 0;
	statistics.ncpu (statistics.index) = ncpu;
	statistics.kmem (statistics.index) = nmem;
	statistics.kbulk (statistics.index) = 0;
	call phcs_$ring_0_peek (ptr (tcdp, TCMsystem_virtual_time_loc),
	     addr (statistics.system_virtual_time (statistics.index)), 2);


/* Check if any AST pool has low steps and force update_vtoce's if needed. */
	if ^debug_sw then do;
	     do i = 0 to 3;
		steps = addrel (sstp3, SSTasteps_loc) -> asteps (i);
		if (steps - old_ast_steps (i)) < addrel (sstp3, SSTlevel_loc) -> level (i).no_aste
		then call hphcs_$flush_ast_pool (i);
		old_ast_steps (i) = steps;
	     end;

	     call scan_syserr_log;
	end;

	return;

/* ADDITIONAL ENTRY POINTS, IN ALPHABETIC ORDER */

asmt_debug: entry;					/* to turn debug_sw on and off */

	debug_sw = ^debug_sw;
	call sys_log_ (SL_LOG, "as_meter_: debug switch turned ^[ON^;OFF^].", debug_sw);
	return;
%page;
asmt_init: entry;					/* Initialize A.S. resource usage metering */

	if ^sc_stat_$Multics_typed | sc_stat_$Go_typed then
	     call sub_err_ (error_table_$out_of_sequence, "as_meter_$asmt_init", "s");
	asmt_initialized = "0"b;			/* not up until we're done */
	debug_sw = as_data_$debug_flag;
	now = clock ();				/* read clock */
	call cpu_time_and_paging_ (pf, vcpu, (0));	/* and meters */
	call hcs_$make_seg ((get_wdir_ ()), "as_meter_table", "", 1010b, asmtp, ec);
	if asmtp = null then do;
	     call sys_log_$error_log (SL_LOG, ec, "as_meter_$asmt_init",
		"Unable to get pointer to as_meter_table; performance metering disabled.");
	     return;
	end;
	call hcs_$truncate_seg (asmtp, (0), ec);	/* zero everything in it */
	if ec ^= 0 then do;
	     call sys_log_$error_log (SL_LOG, ec, "as_meter_$asmt_init",
		"Unable to truncate as_meter_table; performance metering disabled.");
	     return;
	end;

	asmt.version = ASMT_VERSION_1;		/* initialize it */
	asmt.startup_clock = now;			/* remember when we did so */
	asmt.startup_vcpu = vcpu;			/* and remember how much was used before meters were turned on */
	asmt.startup_pf = pf;

/* Meter cost of calls to asmt entry points */
	asmt.asmt_count = asmt.asmt_count + 1;
	asmt.asmt_real_time = asmt.asmt_real_time +
	     (clock () - asmt.startup_clock);
	call cpu_time_and_paging_ (pf, vcpu, (0));
	asmt.asmt_vcpu = asmt.asmt_vcpu +
	     (vcpu - asmt.startup_vcpu);
	asmt.asmt_pf = asmt.asmt_pf +
	     (pf - asmt.startup_pf);

	asmt_initialized = "1"b;

	return;
%page;
asmt_ptr: entry returns (ptr);			/* to save other procs the trouble of initiating as_meter_table */

	return (asmtp);

as_meter_init: entry (atlu, ancrash, anxt_update, aintv);

dcl  atlu fixed bin (71),				/* time of last update in prev run (return) */
     ancrash fixed bin,				/* Number of users thought to be on at crash. */
     anxt_update fixed bin (71),			/* time of next accounting update */
     aintv fixed bin (71);				/* interval in seconds */

	whotab.erfno = "";				/* Assume didn't crash */
	debug_sw = as_data_$debug_flag;
	if ^debug_sw then do;
	     call hphcs_$get_fdump_num (dump_lth, dump_valid, dump_ename, dump_valid_355, dump_ename_355, ec);
	     if ec = 0 then
		if dump_valid then do;		/* Was a dump taken? */
		     crashid = substr (dump_ename, 15); /* Yes. Get dump ID */
		     whotab.erfno = crashid;
		     if ancrash = 0 then ancrash = 1;	/* Make sure crash is noted, if a dump was taken. */
		     call sys_log_ (SL_LOG, "as_meter_: DUMP number is ^a", crashid);
		end;
	end;
	whotab.lastsd = atlu;			/* Initialize whotab. */
	if ancrash ^= 0 then			/* Were there any users who didn't log out? */
	     if whotab.erfno = "" then		/* Yes. So we crashed. Was there a dump? */
		whotab.erfno = "crash";		/* No. Just indicate crash. */

	call ring0_get_$segptr ("", "sst", xsstp, ec);	/* Locate the config info.. */
	if ec ^= 0 then call error ("sst");
	call ring0_get_$segptr ("", "tc_data", tcdp, ec);
	if ec ^= 0 then call error ("tc_data");

	call getloc (xsstp, "asteps", SSTasteps_loc);
	call getloc (xsstp, "damaged_ct", SSTdamage_ct_loc);
	call getloc (xsstp, "level", SSTlevel_loc);
	call getloc (xsstp, "nused", SSTnused_loc);
	call getloc (xsstp, "post_purge_calls", SSTpost_purge_calls_loc);
	call getloc (xsstp, "pre_page_calls", SSTpre_page_calls_loc);
	call getloc (xsstp, "pre_page_size", SSTpre_page_size_loc);
	call getloc (xsstp, "thrashing", SSTthrashing_loc);
	call getloc (tcdp, "ave_eligible", TCMave_eligible_loc);
	call getloc (tcdp, "avequeue", TCMavequeue_loc);
	call getloc (tcdp, "delta_vcpu", TCMdelta_vcpu_loc);
	call getloc (tcdp, "idle", TCMidle_loc);
	call getloc (tcdp, "processor_time", TCMprocessor_time_loc);
	call getloc (tcdp, "response_count", TCMresponse_count_loc);
	call getloc (tcdp, "response_time", TCMresponse_time_loc);
	call getloc (tcdp, "system_virtual_time", TCMsystem_virtual_time_loc);
	call getloc (tcdp, "working_set_addend", TCMworking_set_addend_loc);
	call getloc (tcdp, "working_set_factor", TCMworking_set_factor_loc);
	call getloc (tcdp, "zero_idle", TCMzero_idle_loc);

	call read_deck;				/* Get config, for first maxu auto call. */

	call hcs_$make_seg ((get_wdir_ ()), "stat_seg", "", 1011b, statp, ec);
	if statp = null then call error ("stat_seg");
	if statistics.time_of > atlu then atlu = statistics.time_of;
	whotab.lastsd = atlu;			/* Might be better figure. */

	if statistics.index = 0 then statistics.index = 1;/* Stat_seg did not exist before */
	statistics.erfno (statistics.index) = whotab.erfno; /* Patch up last entry before crash. */
	statistics.crashtime (statistics.index) = whotab.lastsd;
	MAX = divide (sys_info$max_seg_size - STAT_header_lth, STAT_entry_lth, 17, 0);

/* Get initial values for AST steps */

	sstp3 = addr (sst_buffer);
	call phcs_$ring_0_peek (xsstp, sstp3, 512);
	do i = 0 to 3;
	     old_ast_steps (i) = addrel (sstp3, SSTasteps_loc) -> asteps (i);
	end;

	call ipc_$create_ev_chn (core_flush_channel, ec);
	if ec ^= 0 then call error ("flush evchn");
	call ipc_$decl_ev_call_chn (core_flush_channel, core_flush, null, CORE_FLUSH_PRIO, ec);
	if ec ^= 0 then call error ("flush call chn");
	core_flush_time = anxt_update - OFFSET + aintv * MILLION;
	call timer_manager_$alarm_wakeup (core_flush_time, "00"b, core_flush_channel);
	if ^debug_sw then
	     call hphcs_$flush_core;			/* get ball rolling */
	core_flush_time = aintv;			/* do it every so often */

	old_damage_count = 0;

	if ^debug_sw then
	     call scan_syserr_log;

	disable_metering = "0"b;			/* Turn on the metering. */

bust_out: return;

as_meter_stop: entry;

	disable_metering = "1"b;
	return;

core_flush: entry (dataptr);

dcl  dataptr ptr;

	call timer_manager_$alarm_wakeup (core_flush_time, "11"b, core_flush_channel);
	if ^debug_sw then
	     call hphcs_$flush_core;

	return;

/* This entry point is called at the beginning of execution of a subsystem whose usage is being metered. */

enter: entry (slot_no);

	me = "enter";

	if ^asmt_initialized then return;		/* don't fault if called before initialization */

	if slot_no <= 0 | slot_no > hbound (asmt.entry, 1) then do;
bad_slot:	     call ioa_$rsnnl ("as_meter_$^a: called with slot_no=^d.", err_msg, (0), me, slot_no);
	     call error_print;
	     return;
	end;

	now = clock ();				/* read clock */
	call cpu_time_and_paging_ (pf, vcpu, (0));	/* and meters */

	asmt.update_in_progress = 1;			/* so as_meters command can detect an inconsistent copy */

	asmtep = addr (asmt.entry (slot_no));		/* get ptr to table entry for this subsystem */

	if asmte.entered > 0 then do;			/* if subsystem is already entered */
	     if substr (recursion_possible, slot_no, 1) then do; /* if recursive calls to it are legal */
		asmt.global_entered = asmt.global_entered + 1; /* just increment the various entry counters */
		asmte.entered = asmte.entered + 1;
		asmte.entry_count = asmte.entry_count + 1;
		asmte.recursive_entry_count = asmte.recursive_entry_count + 1;
		goto finish_update;			/* and leave without changing the usage values */
	     end;

/* Probably the subsystem took a fault and never called the exit entry point. Complain and then clean up. */

	     call date_time_ (asmte.update_clock, dtstr); /* format time of original entry */
	     call ioa_$rsnnl ("as_meter_$enter: called with slot_no ^d already entered at ^a.", err_msg, (0), slot_no, dtstr);
	     call error_print;
	     if asmte.x ^= 0 then do;			/* clear x values, if any */
		asmte.x_vcpu = 0;
		asmte.x_real_time = 0;
		asmte.x_pf = 0;
		asmte.x = 0;
	     end;
	     asmt.global_entered = asmt.global_entered - 1;
	     asmte.entered = 0;
	end;

	else do;					/* Normal case: subsystem not presently entered */
	     asmt.global_entered = asmt.global_entered + 1; /* count subsystems presently entered */
	     asmte.entered = 1;			/* mark this subsystem as entered */
	     asmte.entry_count = asmte.entry_count + 1;	/* count entries to this subsystem */
	     asmte.entry_pf = pf;			/* remember page faults at entry */
	     asmte.entry_vcpu = vcpu;			/* and vcpu */
	end;

	asmte.update_clock = now;			/* record time of this update */

finish_update:					/* come here to finish update */
	asmt.latest_clock = now;			/* remember current time in header */
	asmt.latest_vcpu = vcpu;			/* and also current usage figures */
	asmt.latest_pf = pf;

/* Meter the cost of calls to asmt entry points */
	asmt.asmt_count = asmt.asmt_count + 1;
	asmt.asmt_real_time = asmt.asmt_real_time +
	     (clock () - asmt.latest_clock);
	call cpu_time_and_paging_ (pf, vcpu, (0));
	asmt.asmt_vcpu = asmt.asmt_vcpu +
	     (vcpu - asmt.latest_vcpu);
	asmt.asmt_pf = asmt.asmt_pf +
	     (pf - asmt.latest_pf);

	asmt.update_in_progress = 0;			/* mark table as consistent now */

	return;

exit: entry (slot_no);

	me = "exit";
	return_values = ""b;			/* don't try to return the usage values */
	goto exit_common;


/* This entry point is like the above, but it also returns the computed usage values to the caller. */

exit_values: entry (slot_no, a_pf, a_vcpu, a_rt);

	me = "exit_values";
	return_values = "1"b;			/* return the computed usage values to the caller */
	a_pf, a_vcpu, a_rt = 0;			/* zero return values; don't return garbage if there's an error */

exit_common:

	if ^asmt_initialized then return;

	if slot_no <= 0 | slot_no > hbound (asmt.entry, 1) then goto bad_slot;

	now = clock ();
	call cpu_time_and_paging_ (pf, vcpu, (0));
	asmt.update_in_progress = 1;			/* mark table as temporarily inconsistent */

	asmtep = addr (asmt.entry (slot_no));		/* get pointer to table entry for this subsystem */

	if asmte.entered <= 0 then do;
	     call ioa_$rsnnl ("as_meter_$^a: called with slot_no ^d not entered (^d).",
		err_msg, (0), me, slot_no, asmte.entered);
	     call error_print;
	end;

	else do;
	     asmte.entered = asmte.entered - 1;		/* decrement recursive call counter */

	     if asmt.global_entered <= 0 then do;	/* and, unless there is an error */
		call ioa_$rsnnl ("as_meter_$^a: called (for slot_no ^d) with global_entered = ^d",
		     err_msg, (0), me, slot_no, asmt.global_entered);
		call error_print;
		asmt.global_entered = 0;
	     end;
	     else asmt.global_entered = asmt.global_entered - 1; /* decrement global entry counter */


	     if asmte.entered = 0 then do;		/* if subsystem is no longer entered, update its meters */

		delta_real_time = now - asmte.update_clock; /* compute values of usage during this entry */
		delta_vcpu = vcpu - asmte.entry_vcpu;
		delta_pf = pf - asmte.entry_pf;

		asmte.update_clock = now;		/* remember time of update */

		asmte.tot_real_time = asmte.tot_real_time + delta_real_time; /* update total values */
		asmte.tot_vcpu = asmte.tot_vcpu + delta_vcpu;
		asmte.tot_pf = asmte.tot_pf + delta_pf;

		if return_values then do;		/* if caller wants usage values, return the total figures */
		     a_rt = delta_real_time;
		     a_vcpu = delta_vcpu;
		     a_pf = delta_pf;
		end;

		if asmte.x ^= 0 then do;		/* if we must exclude the usage charged to called subsystems */
		     delta_real_time = delta_real_time - asmte.x_real_time; /* do it now */
		     delta_vcpu = delta_vcpu - asmte.x_vcpu;
		     delta_pf = delta_pf - asmte.x_pf;

		     asmte.x_real_time = 0;		/* clear the x values */
		     asmte.x_vcpu = 0;
		     asmte.x_pf = 0;
		     asmte.x = 0;			/* remember that there are no x values */
		end;

		asmte.real_time = asmte.real_time + delta_real_time; /* update the "this subsystem only" meters */
		asmte.vcpu = asmte.vcpu + delta_vcpu;
		asmte.pf = asmte.pf + delta_pf;

		if asmt.global_entered > 0 then	/* if other subsystems are entered, record the usage that we just
						   metered, so we can deduct it from their usage when they exit */
		     do i = 1 to hbound (asmt.entry, 1);/* scan for entered subsystems */

		     asmtep = addr (asmt.entry (i));	/* NOTE that we just clobbered asmtep */
		     if asmte.entered > 0 then do;	/* if this subsystem is presently entered */
			asmte.x_real_time = asmte.x_real_time + delta_real_time;
			asmte.x_vcpu = asmte.x_vcpu + delta_vcpu;
			asmte.x_pf = asmte.x_pf + delta_pf;
			asmte.x = 1;		/* remember that this subsystem has x values */
		     end;
		end;				/* end global_entered > 0 */
	     end;					/* end update of subsystem's meters */
	end;					/* end subsystem was entered */

	goto finish_update;

read_config: entry (a_ncpu, a_kmem, a_kbulk);

dcl  (a_ncpu, a_kmem, a_kbulk) fixed bin;

	call read_deck;				/* Find out current configuration. */
	a_ncpu = ncpu;
	a_kmem = nmem;
	a_kbulk = 0;				/* someday we'll take out bulk */

	return;

/* INTERNAL PROCEDURES, IN ALPHABETIC ORDER */

error: proc (id);

dcl  id char (*);

	call sys_log_$error_log (SL_LOG_BEEP, ec, "as_meter_", "Problem getting ""^a"". Metering disabled.", id);
	go to bust_out;

     end error;

error_print: proc;					/* called on errors in asmt entry points */

	call sys_log_ (SL_LOG_SILENT, "^a", err_msg);
	if debug_sw then
	     call as_dump_ (err_msg);
	return;

     end error_print;

getloc: proc (p, name, locn);

dcl  p ptr, name char (*), locn fixed bin (18);
dcl  offset fixed bin (18);

	call ring0_get_$definition (p, "", name, offset, (0), ec);
	if ec ^= 0 then call error (name);
	locn = offset;

     end getloc;

read_deck: proc;

	ncpu, nmem = 0;
	cpu_cardp, mem_cardp = null;
	do while ("1"b);
	     call config_$find ("cpu", cpu_cardp);
	     if cpu_cardp = null then go to found_all_cpus;
	     if cpu_card.state = "on" then ncpu = ncpu + 1;
	end;
found_all_cpus:
	if ncpu = 0 then call error ("config_deck");	/* config_ couldn't find a cpu card */
	do while ("1"b);
	     call config_$find ("mem", mem_cardp);
	     if mem_cardp = null then return;
	     if mem_card.state = "on" then nmem = nmem + mem_card.size;
	end;

     end read_deck;

scan_syserr_log: proc;

/* Get all seg/vol damage messages from last time till now  */
/* We rely on syserr_log_man_ to interpret them and spit them out */

	damage_count = addrel (sstp3, SSTdamage_ct_loc) -> single;
	if damage_count > old_damage_count
	then call syserr_log_man_$as_copy_log ();

	old_damage_count = damage_count;

     end scan_syserr_log;

/* format: off */
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_meter_numbers;
%page; %include as_meter_table;
%page; %include as_wakeup_priorities;
%page; %include config_cpu_card;
%page; %include config_mem_card;
%page; %include sc_stat_;
%page; %include stat_seg;
%page; %include sys_log_constants;
%page; %include user_table_header;
%page; %include whotab;

/* format: on */
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   as_meter_: FDUMP number is NNN

   S:	as (severity1)

   T:	$init

   M:	The system is coming up after a crash.  There is a dump,
   created by the bce dump command, in the DUMP partition.  Usually,
   system_start_up.ec copies this dump into the directory >dumps.

   A:	Follow site instructions concerning the processing of
   online dumps.  The normal procedure is to log in Print_Dump.SysDaemon
   and request that it process the dump.


   Message:
   as_meter_: Problem getting "ITEM".  Metering disabled.

   S:	as (severity2)

   T:	$init

   M:	The metering module cannot obtain a pointer to the ring 0
   hardcore data item ITEM, used in calculating system usage.  Metering
   figures are scrambled, but the system should be able to run.

   A:	$inform

   END MESSAGE DOCUMENTATION */

     end as_meter_;




		    astty_.pl1                      07/20/88  1307.0r w 07/19/88  1536.5      266157



/****^  ***********************************************************
        *                                                         *
        * 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: style4 */

astty_: proc;

/* ASTTY_ - the Answering Service User Terminal IO Module (formerly aswa_)
   this procedure provides an I/O-switch type write around
   for the answering service.

   Originally, this program handled TTY, NET (old NCP), and G115 protocol.
   Now, it only handles tty, by calling hcs_$tty_*. This removes the need
   for an IOCB per channel.

   Initially coded by Michael J. Spier, March 2 1970.
   Modified 7/22/71 by Edwin W. Meyer, Jr. to include calls for the ARPA Computer Network.
   Test mode removed 11/72 THVV
   Modified 750226 by PG to split astty_$tty_order into $tty_order and $tty_changemodes
   Modified by T. Casey, November 1976 to have changemode check for old mode string too long and not return error code.
   Modified by Robert Coren, July 1977, to process set_term_type order
   Modified by Robert Coren, summer 1978, to use hcs_$tty_get_line and to add get_chars entry point
   Modified August 1979 by Larry Johnson for getmodes entry.
   Modified May 15 1981 by E. N. Kittlitz. tty_read maxlength changed from 100 to 300,
   tty_order to return real status code for dial_out.
   Modified February 1982 by E. N. Kittlitz for error_log, no_error_log entries.
   Modified February 1983 by E. N. Kittlitz for selective tracing.
   Modified 84-04-02 BIM. Removed all multiple "dim" support.
   And fix code return to return -1 ONLY if channel is HUNG UP.
   (io no permission).
   Modified 1984-10-01 BIM to improve severity selection for tracing.
   Now all tracing goes into the log.
*/

/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  2) change(87-03-17,LJAdams), approve(87-04-03,MCR7646),
     audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030):
     Changed ttd_version to ttd_version_3.
  3) change(87-03-17,Beattie), approve(87-04-06,MCR7656),
     audit(87-08-03,Parisek), install(87-08-04,MR12.1-1055):
     Supports use of IOCBs when connecting to channels that cannot be
     supported by tty_, ie, hasp operator subchannels when set for login
     service.
                                                   END HISTORY COMMENTS */

/* builtins */

dcl  (addr, codeptr, length, rtrim, substr, null) builtin;

/* external static */

dcl  error_table_$smallarg fixed bin (35) external static;

/* entries */

dcl  ioa_$rsnnl entry () options (variable);
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);
dcl  ttt_info_$terminal_data entry (char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  hcs_$tty_abort entry (fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  hphcs_$tty_write_force entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_detach entry (fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_detach_new_proc entry (fixed bin, bit (36) aligned, fixed bin, fixed bin (35));
dcl  hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35));
dcl  hcs_$tty_index entry (char (*) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$tty_read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_get_line entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, bit (1), fixed bin, fixed bin (35));
dcl  hcs_$tty_state entry (fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* DECLARATION OF INTERNAL STATIC VARIABLES */

dcl  el_severity fixed bin int static init (0);
dcl  trace_sw bit (1) aligned int static init ("0"b);
dcl  trace_error_sw bit (1) aligned int static init ("0"b);
dcl  trace_call_sw bit (1) aligned int static init ("0"b);
dcl  trace_select_sw bit (1) aligned int static init ("0"b);
dcl  trace_select_channel char (32) varying int static init ("");
dcl  trace_io_sw bit (1) aligned int static init ("0"b);

/* automatic */

dcl  (nelem, nelemt, offset) fixed bin;
dcl  (iox_nelem, iox_nelemt) fixed bin (21);
dcl  iox_code fixed bin (35);
dcl  nl_found bit (1);
dcl  obsolete bit (1) aligned;
dcl  entrypoint char (9);
dcl  changemode_entry bit (1);
dcl  iocb_ptr ptr;
dcl  order_name char (32);
dcl  order_ptr ptr;
dcl  io_linel fixed bin (21);
dcl  line_status_storage bit (72) aligned;
dcl  ME char (6) int static init ("astty_") options (constant);
        

dcl  1 terminal_data like terminal_type_data;

dcl  1 modes aligned,				/* for order (modes) call */
       2 size fixed bin,
       2 string char (512) unal;

/* based */

dcl  io_line char (io_linel) based (mp);

/* error table */

dcl  error_table_$io_no_permission fixed bin (35) ext static;
dcl  error_table_$mpx_down fixed bin (35) ext static;
dcl  error_table_$line_status_pending fixed bin (35) ext static;
dcl  error_table_$not_a_valid_iocb fixed bin (35) ext static;
%page;
/* ============================================================= */

/* TTY_INDEX - ATTACH THE DEVICE SPECIFIED BY "NAME" AND ASSIGN IT A DEVICE INDEX */

tty_index: entry (p, code);

dcl  p ptr parameter;
dcl  code fixed bin (35) parameter;

	code = 0;
	cdtep = p;				/* copy ptr */

	if cdte.use_iocb then
	     if cdte.iocbp = null () then call create_iocb;

	call hcs_$tty_index (cdte.name, cdte.twx, cdte.state, code);

	call print_num ("index", cdte.twx);
	go to check_state_return;

/* TTY_EVENT - ASSOCIATE THE DEVICE WITH AN EVENT CHANNEL NAME */

tty_event: entry (p, code);

	call validate_cdte ("event");

	if cdte.use_iocb then do;
	     call iox_$control ((cdte.iocbp), "set_event_channel", addr (cdte.event), iox_code);
	     call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
	     if code = 0 then code = iox_code;		/* give precedence to state control order */
	end;
	else call hcs_$tty_event (cdte.twx, cdte.event, cdte.state, code);

	call print ("event");
	cdte.wakeup_handler = ""b;			/* assume dialup_ handles wakeups */
	go to check_state_return;


/* TTY_CHANGEMODE - SET THE DEVICE MODES */

tty_changemode:
     entry (p, bv_new_modes, code);

/* parameters to tty_changemode */

dcl  bv_new_modes char (*) unaligned parameter;

	changemode_entry = "1"b;
changemode_join:
	call validate_cdte ("changemode");

	modes.size = length (modes.string);		/* set maximum returned length */
	if changemode_entry then modes.string = bv_new_modes; /* set new modes */
	else modes.string = "";
re_mode:
	if cdte.use_iocb
	then do;
	     call iox_$modes ((cdte.iocbp), modes.string, "", iox_code);
	     call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
	     if code = 0 then code = iox_code;		/* give precedence to state control order */
	end;
	else call hcs_$tty_order (cdte.twx, "modes", addr (modes), cdte.state, code);
	call check_line_status (re_mode, "changemode");
	if code ^= 0 then
	     if code = error_table_$smallarg then	/* ... not enough room for returned mode string */
		code = 0;

	if ^changemode_entry then do;
	     bv_modes = modes.string;
	     call print ("getmode");
	end;
	else call print_arg ("changemode", bv_new_modes);
	go to check_state_return;


/* TTY_GETMODE - GET THE DEVICE MODES */

tty_getmode:
     entry (p, bv_modes, code);

dcl  bv_modes char (*);

	changemode_entry = "0"b;
	go to changemode_join;


/* TTY_ORDER - REQUEST MISCELLANEOUS DEVICE-DEPENDENT FUNCTIONS */

tty_order:
     entry (p, bv_order, bv_order_ptr, code);

/* parameters to tty_order */

dcl  (bv_order char (*),
     bv_order_ptr ptr) parameter;

	call validate_cdte ("order");
	order_ptr = bv_order_ptr;
	order_name = bv_order;

	if ^cdte.use_iocb & (order_name = "set_term_type")
	then do;					/* imitate tty_ for this one */
	     terminal_data.version = ttd_version_3;
	     call ttt_info_$terminal_data (order_ptr -> set_term_type_info.name, (cdte.line_type),
		(cdte.baud_rate), addr (terminal_data), code);
	     if code ^= 0 then do;
		call sys_log_$error_log (el_severity, code, ME,
		     "^a has undefined terminal type ^a for set_term_type order.",
		     cdte.name, order_ptr -> set_term_type_info.name);
		go to general_return;
	     end;

	     order_name = "set_terminal_data";
	     order_ptr = addr (terminal_data);
	end;

re_order:
	call print_arg ("order", bv_order);

	if cdte.use_iocb
	then do;
	     call iox_$control ((cdte.iocbp), order_name, order_ptr, iox_code);
	     call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
	     if code = 0 then code = iox_code;		/* give precedence to state control order */
	end;
	else call hcs_$tty_order (cdte.twx, order_name, order_ptr, cdte.state, code);
	call check_line_status (re_order, "order");

	if order_name = "hangup" then
	     if cdte.use_iocb then do;
		call destroy_iocb;
		call create_iocb;
		call hcs_$tty_index (cdte.name, cdte.twx, cdte.state, code);
	     end;

	go to check_state_return;

/* TTY_STATE - GET THE STATE OF THE DEVICE */

tty_state: entry (p, code);

	call validate_cdte ("state");

	if cdte.use_iocb
	then do;
	     if cdte.iocbp = null () then do;
		cdte.state = 0;			/* channel not set up yet */
		code = 0;
	     end;
	     else do;
		call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
		if code = error_table_$not_a_valid_iocb
		then do;				/* should not happen but just in case */
		     cdte.state = 0;
		     cdte.iocbp = null ();
		     code = 0;
		end;
	     end;
	end;
	else call hcs_$tty_state (cdte.twx, cdte.state, code);

	call print_num ("state", cdte.state);

/* Error code processing is different here ! */

	if code = error_table_$io_no_permission | code = error_table_$mpx_down /* twx valid, but noone home */
	then do;
	     code = 0;				/* we can report a legitimate and accurate state */
	     if cdte.state > TTY_HUNG
	     then do;
		call sys_log_ (el_severity, "^a: tty_state returned ^d for hung-up line ^a.", ME, cdte.state, cdte.name);
		cdte.state = 0;			/* Lie, to get good results. */
	     end;
	end;
	return;					/* we assume state is 0 or -1 in the io_no_permission case */


/* TTY_ABORT - ABORT ALL PENDING I/O ON THE DEVICE */

tty_abort: entry (p, abortflag, code);

dcl  abortflag fixed bin;

	call validate_cdte ("abort");
re_abort:
	if cdte.use_iocb
	then do;
	     if abortflag = 1 | abortflag = 3		/* reset read */
	     then do;
		call iox_$control ((cdte.iocbp), "resetread", null (), iox_code);
		call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
		if code = 0 then code = iox_code;	/* give precedence to state control order */
		if code ^= 0 then go to bad_abort;
	     end;

	     if abortflag = 2 | abortflag = 3		/* reset write */
	     then do;
		call iox_$control ((cdte.iocbp), "resetwrite", null (), iox_code);
		call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
		if code = 0 then code = iox_code;	/* give precedence to state control order */
	     end;
	end;
	else call hcs_$tty_abort (cdte.twx, abortflag, cdte.state, code);

bad_abort:
	call check_line_status (re_abort, "abort");
	call print_num ("abort", abortflag);
	go to check_state_return;


/* TTY_GET_CHARS - READ WHATEVER INPUT IS AVAILABLE */

tty_get_chars: entry (p, mp, ml, code);

	nelem = 300;
	nelemt = 0;
	offset = 0;
	ml = 0;					/* safe */
	call validate_cdte ("get_chars");
	entrypoint = "get_chars";

re_get_chars:
	if cdte.use_iocb
	then do;
	     iox_nelem = nelem;
	     call iox_$get_chars ((cdte.iocbp), mp, iox_nelem, iox_nelemt, iox_code);
	     nelemt = iox_nelemt;
	     call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
	     if code = 0 then code = iox_code;		/* give precedence to state control order */
	end;
	else call hcs_$tty_read (cdte.twx, mp, offset, nelem, nelemt, cdte.state, code);
	call check_line_status (re_get_chars, "get_chars");
	go to trace_read;


/* TTY_READ - READ IN A LINE FROM THE DEVICE */

tty_read: entry (p, mp, ml, code);

dcl  mp ptr, ml fixed bin;

	nelem = 300;				/* min(ftp_dialup_ buff size, dialup_ buff size) */
	nelemt = 0;
	offset = 0;
	ml = 0;
	entrypoint = "read";
	call validate_cdte ("read");

re_get_line:
	if cdte.use_iocb
	then do;
	     iox_nelem = nelem;
	     call iox_$get_line ((cdte.iocbp), mp, iox_nelem, iox_nelemt, iox_code);
	     nelemt = iox_nelemt;
	     call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
	     if code = 0 then code = iox_code;		/* give precedence to state control order */
	end;
	else call hcs_$tty_get_line (cdte.twx, mp, offset, nelem, nelemt, nl_found, cdte.state, code);
	call check_line_status (re_get_line, "read");

trace_read:
	call print_num (entrypoint, nelemt);
	if trace_io_sw then do;
	     io_linel = nelemt;
	     call print_arg (entrypoint, io_line);
	end;
	ml = nelemt;
	go to check_state_return;


/* TTY_WRITE - write out a line on the device. */

tty_write: entry (p, mp, mo, ml1, mt, code);

dcl  (mo, ml1, mt) fixed bin;
dcl  based_chars (0:1) char (1) based unal;		/* used for bumping string pointers */
dcl  data_ptr pointer;

	mt = 0;
	call validate_cdte ("write");
re_write:
	if cdte.use_iocb
	then do;
	     data_ptr = addr (mp -> based_chars (mo));
	     iox_nelem = ml1;
	     call iox_$put_chars ((cdte.iocbp), data_ptr, iox_nelem, iox_code);
	     call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
	     if code = 0 then code = iox_code;		/* give precedence to state control order */
	     if code = 0 then mt = ml1;
	end;
	else call hcs_$tty_write (cdte.twx, mp, mo, ml1, mt, cdte.state, code);
	call check_line_status (re_write, "write");

	call print_num ("write", ml1);
	if trace_io_sw then do;
	     io_linel = ml1;
	     call print_arg ("write", io_line);
	end;

	go to check_state_return;

/* TTY_FORCE - WRITE OUT A LINE ON THE DEVICE (use special "force" mode) */

tty_force: entry (p, mp, ml, code);

	nelem = ml;
	nelemt = 0;
	offset = 0;

	call validate_cdte ("force");

re_write_force:
	if cdte.use_iocb
	then do;					/* this will work on a well configured system */
	     iox_nelem = nelem;
	     call iox_$put_chars ((cdte.iocbp), mp, iox_nelem, iox_code);
	     call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
	     if code = 0 then code = iox_code;		/* give precedence to state control order */
	     if code = 0 then nelemt = nelem;
	end;
	else call hphcs_$tty_write_force (cdte.twx, mp, offset, nelem, nelemt, cdte.state, code);
	call check_line_status (re_write_force, "write_force");

	call print_num ("force_write", nelem);
	if trace_io_sw then do;
	     io_linel = nelem;
	     call print_arg ("force_write", io_line);
	end;

	if nelemt = ml then return;
	if cdte.use_iocb then go to check_state_return;	/* one chance only for IOCBs */
re_force_abort:
	call hcs_$tty_abort (cdte.twx, 2, cdte.state, code);
	call check_line_status (re_force_abort, "write_force(abort)");
re_write_force_2:
	call hphcs_$tty_write_force (cdte.twx, mp, offset, nelem, nelemt, cdte.state, code);
	call check_line_status (re_write_force_2, "write_force(2)");
	go to check_state_return;

/* TTY_DETACH - DETACH THE DEVICE AND MAKE IT UNKNOWN  (AND AVAILABLE) */

tty_detach: entry (p, detachflag, code);

dcl  detachflag fixed bin;
dcl  dflag fixed bin;

	call validate_cdte ("detach");

	if cdte.use_iocb & cdte.iocbp ^= null () then do;
	     dflag = detachflag;
	     call iox_$control ((cdte.iocbp), "detach_user_process", addr (dflag), iox_code);
	     if iox_code ^= 0 then			/* need to try all possible avenues to get into hcs_$tty_detach */
		call hcs_$tty_detach (cdte.twx, detachflag, cdte.state, iox_code);

	     call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
	     if code = 0 then code = iox_code;		/* give precedence to state control order */
	     call destroy_iocb ();
	end;
	else call hcs_$tty_detach (cdte.twx, detachflag, cdte.state, code);

	call print_num ("detach", detachflag);
	return;

/* TTY_NEW_PROC - force tty to attach to new process */

tty_new_proc: entry (p, pid, code);

dcl  pid bit (36) aligned;

	call validate_cdte ("new_proc");
	if cdte.use_iocb
	then do;
	     call iox_$control ((cdte.iocbp), "assign_to_user_process", addr (pid), iox_code);
	     call iox_$control ((cdte.iocbp), "state", addr (cdte.state), code);
	     if code = 0 then code = iox_code;		/* give precedence to state control order */
	end;
	else call hcs_$tty_detach_new_proc (cdte.twx, pid, cdte.state, code);
	call print ("new_proc");
	go to check_state_return;
%page;
/* Trace package */

trace_on: entry;

dcl  cu_$arg_count entry entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  argc fixed bin;
dcl  argp ptr;
dcl  argl fixed bin (21);
dcl  arg char (argl) based (argp);

	trace_io_sw = "0"b;
	go to trace_join;

trace_io: entry;
	trace_io_sw = "1"b;

trace_join:
	trace_sw = "1"b;				/* tracing or logging */
	trace_call_sw = "1"b;			/* definitely tracing */
	trace_select_sw = "0"b;
	call cu_$arg_count (argc, (0));
	if argc = 0 then go to trace_report_return;
	call cu_$arg_ptr (1, argp, argl, (0));
	trace_select_sw = "1"b;
	trace_select_channel = arg;

trace_report_return:
	call sys_log_ (SL_LOG, "^a: tracing is ^[on^[ for channel ^a^;^s^].^;off. ^2sError logging is ^[on, severity ^d^;off^].^]",
	     ME, trace_call_sw, trace_select_sw, trace_select_channel, trace_sw, el_severity);
	return;

trace_off: entry;
	trace_call_sw = "0"b;			/* no more tracing  */
	trace_io_sw = "0"b;
	trace_sw = trace_error_sw;			/* are we still error logging? */
	go to trace_report_return;

log_error: entry;
	el_severity = SL_LOG_SILENT;
	go to log_error_join;

log_error_1: entry;
	el_severity = SL_LOG;

log_error_join:
	trace_sw = "1"b;				/* logging or tracing */
	trace_error_sw = "1"b;			/* definitely error logging */
	go to trace_report_return;

no_log_error: entry;
	trace_error_sw = "0"b;			/* no more error logging */
	trace_sw = trace_call_sw;			/* still tracing? */
	go to trace_report_return;
%page;
/* Internal procedures used to write out tracing messages and log errors. */

print: proc (chars);

dcl  chars char (*);
dcl  lsv fixed bin;
dcl  trace_it bit (1) aligned;

	call should_trace (lsv, trace_it);
	if ^trace_it then return;
	call sys_log_$error_log (lsv, code, ME, "^a ^d ^a", cdte.name, cdte.state, chars);

     end print;


print_arg:
     procedure (bv_arg1, bv_arg2);

dcl  (bv_arg1, bv_arg2) char (*) unaligned parameter;
dcl  lsv fixed bin;
dcl  trace_it bit (1) aligned;

	call should_trace (lsv, trace_it);
	if ^trace_it then return;
	call sys_log_$error_log (lsv, code, ME, "^a ^d ^a ^a", cdte.name, cdte.state, bv_arg1, bv_arg2);

     end print_arg;


print_num:
     procedure (bv_arg1, bv_arg2);

dcl  (bv_arg1 char (*) unaligned,
     bv_arg2 fixed bin) parameter;

dcl  eleven_digits picture "-----------9";		/* 11 digits plus sign */

dcl  verify builtin;

dcl  idx fixed bin;

	if ^trace_call_sw & code = 0 then return;	/* nothing to do */
	eleven_digits = bv_arg2;			/* convert to characters */
	idx = verify (eleven_digits, " ");
	if idx = 0 then idx = 1;			/* if no blanks present, use whole string */

	call print_arg (bv_arg1, substr (eleven_digits, idx));

     end print_num;


should_trace: proc (lsv, trace_it);
dcl  lsv fixed bin;
dcl  trace_it bit (1) aligned;

should_trace_channel: proc returns (bit (1) aligned);
	     if ^trace_call_sw then return ("0"b);
	     else if trace_select_sw then		/* the beginning of this channel's name */
		return (trace_select_channel = substr (cdte.name, 1, length (trace_select_channel)));
	     else return ("1"b);

	end should_trace_channel;

	trace_it = "0"b;
	if ^trace_sw
	then return;
	trace_it = "1"b;
	if code ^= 0 & trace_error_sw then		/* we want to log error */
	     if trace_call_sw then
		if should_trace_channel () then lsv = SL_LOG; /* also tracing, make it print */
		else trace_it = ""b;
	     else lsv = el_severity;			/* error trace, let user decide if we print */
	else do;
	     trace_it = should_trace_channel ();
	     lsv = SL_LOG_SILENT;			/* no error log, just trace */
	end;
	return;
     end should_trace;

/* Checks for line status or hungup characters */

check_line_status:
     procedure (retry_label, caller);

declare  retry_label label local;
declare  acode fixed bin (35);
declare  caller char (32);
declare  octalstatus char (24);

	if code = 0 then return;
	if code ^= error_table_$line_status_pending
	then do;
	     if code = error_table_$io_no_permission | code = error_table_$mpx_down | cdte.state <= TTY_HUNG
	     then
HUNG_UP:		do;
		if cdte.state > TTY_HUNG then
		     call sys_log_$error_log (el_severity, code, ME,
			"^a state ^d > TTY_HUNG on hung-up error code.", cdte.name, cdte.state);

		code = -1;			/* dialup_ expects this */
		call destroy_iocb ();
		go to general_return;
	     end;
	     call print_arg (caller, "ERROR");
	     go to general_return;
	end;
	call hcs_$tty_order (cdte.twx, "line_status", addr (line_status_storage),
	     cdte.state,
	     acode);
	if acode ^= 0 then do;			/* if we got line_status_pending, we had to be dialed up */
	     if acode = error_table_$io_no_permission | code = error_table_$mpx_down
		| cdte.state <= TTY_HUNG
	     then go to HUNG_UP;
	     call sys_log_$error_log (el_severity, acode, ME,
		"^a ^d line_status failed after line_status_pending", cdte.name, cdte.state);
	     code = acode;
	     go to general_return;
	end;

	octalstatus = "";
	call ioa_$rsnnl ("^o", octalstatus, (0), line_status_storage);
	call print_arg ("line_status", octalstatus);
	go to retry_label;
     end check_line_status;
%skip (4);
create_iocb:
     procedure;					/* the cdte.iocbp is expected to be null */

	call iox_$find_iocb ((cdte.name), iocb_ptr, code);
	if code ^= 0 then do;
	     call sys_log_$error_log (el_severity, code, ME, "error finding an IOCB for channel ^a.",
		cdte.name);
	     cdte.state = 0;
	     goto general_return;
	end;

	cdte.iocbp = iocb_ptr;

	call iox_$attach_ptr ((cdte.iocbp),
	     "hasp_stream_ -target hasp_workstation_ -device teleprinter -no_block -comm hasp -tty " ||
	     rtrim (cdte.name) || " -suppress_dial_manager", codeptr (astty_), code);
	if code ^= 0 then do;
	     call sys_log_$error_log (el_severity, code, ME, "error attaching IOCB for channel ^a.",
		cdte.name);
	     cdte.state = 0;
	     call iox_$destroy_iocb ((cdte.iocbp), (0));
	     cdte.iocbp = null ();
	     goto general_return;
	end;

	call iox_$open ((cdte.iocbp), Stream_input_output, obsolete, code);
	if code ^= 0 then do;
	     call sys_log_$error_log (el_severity, code, ME, "error opening IOCB for channel ^a.",
		cdte.name);
	     cdte.state = 0;
	     call iox_$detach_iocb ((cdte.iocbp), (0));
	     call iox_$destroy_iocb ((cdte.iocbp), (0));
	     cdte.iocbp = null ();
	     goto general_return;
	end;

     end create_iocb;
%skip (4);
destroy_iocb:
     procedure;

	if cdte.use_iocb then
	     if cdte.iocbp ^= null () then do;
		call iox_$close ((cdte.iocbp), (0));	/* get rid of IOCB */
		call iox_$detach_iocb ((cdte.iocbp), (0));
		call iox_$destroy_iocb ((cdte.iocbp), (0));
		cdte.iocbp = null ();
	     end;

     end destroy_iocb;
%skip (4);
validate_cdte:
     procedure (caller);

declare  caller char (32);

	code = 0;
	cdtep = p;
	if (cdte.use_iocb & cdte.iocbp = null () & ^(caller = "state" | caller = "detach"))
	     | (^cdte.use_iocb & cdte.twx = 0) then do;	/* not currently valid channel */
	     cdte.state = TTY_HUNG;
	     code = -1;
	     call destroy_iocb ();
	     call print_arg (caller, "call with invalid cdte");
	     go to general_return;
	end;
	return;
     end validate_cdte;

general_return:
	return;

check_state_return:					/* one last chance to note hangup */

/**** The contract between us, the hardcore, and dialup_ is complex.
      tty_index will return io_no_permission if the channel is
      TTY_MASKED, TTY_HUNG_UP (TTY_HUNG) or TTY_LISTENING (TTY_KNOWN).
      dialup_ wants to hear a -1 under the same conditions.
      The fact that the channel is not dialed up takes precedence
      over any other error, since it conditions dialup_'s handling
      of the error.

      This code might do the wrong thing if the line is TTY_KNOWN
      and the operation was valid in that state.
*/

	if code ^= 0 then
	     if cdte.state <= TTY_HUNG | code = error_table_$io_no_permission | code = error_table_$mpx_down
	     then do;
		if cdte.state > TTY_HUNG
		then call sys_log_$error_log (el_severity, code, ME,
			"^a ^d state > TTY_HUNG on hung-up error code.", cdte.name, cdte.state);
		code = -1;
		call destroy_iocb;
	     end;
	return;

%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   astty_: ERROR_TABLE_MESSAGE CHANNEL has undefined terminal type TERM_TYPE for set_term_type order.

   S:     $as0 or $as1

   T:     $run

   M:     The system received the ERROR_TABLE_MESSAGE when an attempt was made
   to set the terminal type of CHANNEL to TERM_TYPE.
   Suspect the terminal type is not known on to the system.  The set_term_type
   control order was ignored.

   A:     $inform

   Message:
   astty_: tty_state returned SSSS for hung-up line CHANNEL.

   S:     $as0 or $as1

   T:     $run

   M:     In processing the astty_$tty_state entry, a call to hcs_$tty_state
   returned a state value of SSSS for hung-up
   CHANNEL which indicates that the channel is active.  However, the returned
   error code indicated that the channel is hung-up.  The channel will be
   hungup.

   A:     $inform

   Message:
   astty_: ERROR_TABLE_MESSAGE CHANNEL state SSSS > TTY_HUNG on hung-up error code.

   S:     $as0 or $as1

   T:     $run

   M:     An error code of ERROR_TABLE_MESSAGE was returned while
   servicing CHANNEL indicating that the channel is not useable.  However, the
   state SSSS of the channel indicates that the channel was active, thus the
   CHANNEL state is inconsistant.  The channel will be hungup.

   A:     $inform

   Message:
   astty_: ERROR_TABLE_MESSAGE CHANNEL SSSS line_status failed after line_status_pending

   S:     $as0 or $as1

   T:     $run

   M:     System received the ERROR_TABLE_MESSAGE when it tried to do a line
   status control order on CHANNEL in state SSSS after it received a
   line_status_pending error code.  The error code for ERROR_TABLE_MESSAGE was
   returned back to the caller.

   A:     $inform

   Message:
   astty_: ERROR_TABLE_MESSAGE error finding an IOCB for channel CCCC.

   S:     $as0 or $as1

   T:     $run

   M:     The system received the ERROR_TABLE_MESSAGE when it attempted to find
   an IOCB for channel CCCC.  The channel was then hungup.

   A:     $inform

   Message:
   astty_: ERROR_TABLE_MESSAGE error attaching IOCB for channel CCCC.

   S:     $as0 or $as1

   T:     $run

   M:     The system received the ERROR_TABLE_MESSAGE attempting to attach to
   channel CCCC using an IOCB.  The channel was then hungup.

   A:     $inform

   Message:
   astty_: ERROR_TABLE_MESSAGE error opening IOCB for channel CCCC.

   S:     $as0 or $as1

   T:     $run

   M:     The system received the ERROR_TALE_MESSAGE attemping to open the
   channel CCCC using an IOCB.  The channel was then hungup.

   A:     $inform

   Message:
   astty_: ERROR_TABLE_MESSAGE CHANNEL NN TEXT

   S:	$as0 or $as1

   T:	$run

   M:	This is tracing or error logging output.
   This output may appear in the AS log, or be printed on the severity1 stream
   as directed by astty_ trace and log_error requests described below.

   A:	$ignore
   Tracing and logging is controlled by the following entries, which
   may be typed as commands in admin mode.
   .br
   astty_$trace - causes tracing of all calls to astty_
   .br
   astty_$notrace - disables tracing
   .br
   astty_$log_error - logs calls to astty_ that get errors. does not print.
   .br
   astty_$log_error_1 - logs and prints calls to astty_ that get errors.
   .br
   astty_$no_log_error - disables error logging.
   .br

   END MESSAGE DOCUMENTATION */

%page;
%include author_dcl;
%page;
%include cdt;
%page;
%include dialup_values;
%page;
%include iox_modes;
%page;
%include set_term_type_info;
%page;
%include terminal_type_data;
%page;
%include sys_log_constants;

     end astty_;




		    asu_.pl1                        05/02/89  1156.0rew 05/02/89  1154.2      586089



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * 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-01-29,Herbst), approve(87-07-13,MCR7697),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
     Changed internal procedure BLAST_CHANNEL to BLAST_USER.
     Changed $blast_user to pass initial ring number to send_system_message_.
  2) change(86-03-11,MSharpe), approve(87-07-13,MCR7690),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
     initiated P_code to 0 in "bump_user", so that it doesn't return a non-zero
     code  that it has received from the caller.
  3) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  4) change(86-06-30,Swenson), approve(87-07-13,MCR7737),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
     Added $setup_login_server_handle entry to initialize the handle in the
     UTE.
  5) change(87-02-24,Brunelle), approve(87-07-13,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Added parameter to internal procedure $BLAST_USER to signal whether this
     is a INACTIVITY or WARN message.
  6) change(87-04-09,Brunelle), approve(87-07-13,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Added entrypoint $reschedule_bump_timer to cancel the current bump timer
     and reschedule to new time.
  7) change(87-04-27,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  8) change(87-05-06,Brunelle), approve(87-07-13,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Fixed call to BLAST_USER in blast_user entrypoint to pass P_utep instead
     of utep.
  9) change(87-07-16,GDixon), approve(87-07-16,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use named constants when testing ute.preempted.
 10) change(87-07-22,GDixon), approve(87-07-22,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct several minor errors found during auditing.
      B) Document undoc's sys_log_ calls.
 11) change(88-07-15,Brunelle), approve(88-09-13,MCR7980),
     audit(88-09-13,Beattie), install(88-09-16,MR12.2-1112):
     Pass entire UTE to send_system_message_ so it can get whatever info it
     needs about the user.
 12) change(88-12-09,Parisek), approve(89-04-05,MCR8086),
     audit(88-04-25,Beattie), install(89-05-02,MR12.3-1038):
     Release the UTE associated with a terminal in a login connect loop
     when the channel associated with that terminal is removed via the
     "remove" request.
                                                   END HISTORY COMMENTS */

/* format: style4 */

asu_:
     procedure ();

/* Answering service utility package

   Coded by Michael D. Schroeder, June 1969
   Revised for new System/User Control, and converted to PL/1
   by Michael J. Spier, January 1970
   Modified 750225 by PG to change calls to astty_$tty_order to pass argument pointer,
   .	and to create astty_$tty_changemode.
   Modified 750228 by PG to log all errors in asu_attach and asu_listen, and then remove line.
   Modified 750502 by PG to add asu_$reset
   Modified 750616 by PG to completely rewrite asu_attach, fixing several bugs
   Modified 750821 by PG & THVV for CDT
   Modified 760625 by Roy P. Planalp to introduce calls to network module ftp_dialup_
   .	 which performs the function of AS module dialup_ for Network FTP channels
   Modified 760819 by Roy Planalp to send ftp-format msgs when bumping or writing to ftp users,
   and to add utility routine to format ftp msgs.
   Modified August 1976 by T. Casey to make attach and attach_channel handle case of FNP not being up yet.
   Modified October 1976 by T. Casey to fix bug in error handling in attach.
   Modified September 1977 by T. Casey to fix bugs and make channel deletions reversible during the same bootload.
   Modified October 1977 by T. Casey to add send_term_signal entry.
   Modified January 1978 by T. Casey to fix bugs in previous modification.
   Modified May 1978 by T. Casey to add check_for_stopped_process entry, and to
   .	preserve privileged attachments of slave channels across FNP crashes,
   .	by having the listen entry point check for that case.
   Modified Fall 1978 by L.E.Johnson for ring zero demultiplexing.
   Modified March 1979 by T. Casey for MR7.0a to add suspend_process and release_suspended_process entries.
   Modified July 1979 by T. Casey for MR8.0 to support process preservation across hangups.
   Modified December 1980 by E. N. Kittlitz for bugfixes
   Modified March 1981 by Robert Coren to check for TANDD service type
   Modified June 1981 by T. Casey for MR9.0 for new wakeup priorities.
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified December 1981, E. N. Kittlitz.  whotab suspended/disconnected bits.
   Modified May 1982, E. N. Kittlitz. New AS initialization.
   Modified June 1982, B. I. Margulies, protect multiplexers from removes.
   Modified 84-04-02, BIM, remove references to cdte.dim
   and add reset_access_class.
   Modified 1984-08-07 BIM to reset_access_class at attach_channel
   and to give up as soon as we get a hangup error.
   Modified 84-10-03 by E. Swenson to incorporate Jim Falksen's changes
   for date_time_$format.
   Modified 84-11-27 by E. Swenson for new IPC validation.  Adds entry
   start_process which kicks a process out of the intitial blocked
   state.
   Modified 85-02-13 by E. Swenson for asu_$blast_user, asu_$blast_channel.
   Modified 85-11-18 by Steve Herbst to make $blast_user call send_system_message_.
*/

/* Parameters */

dcl  P_code fixed bin (35) parameter;
dcl  P_error_message char (*) parameter;		/* error message for caller */
dcl  P_message char (*) parameter;			/* message to blast on terminal */
dcl  P_utep ptr parameter;

dcl  (bv_ptr_1 ptr,					/* pointer which appears in parameter position 1 */
     p2 ptr,
     bv_code_2 fixed bin (35),			/* error code which appears in parameter position 2 */
     bv_tty_name char (*)				/* argument to asu_attach */
     ) parameter;

/* Conditions */

dcl  cleanup condition;

/* Builtins */

dcl  (addr, baseno, bit, clock, divide, index, length, mod, null, rtrim, substr, unspec) builtin;

/* Entries */

dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  astty_$tty_detach entry (ptr, fixed bin, fixed bin (35));
dcl  astty_$tty_event entry (ptr, fixed bin (35));
dcl  astty_$tty_force entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  astty_$tty_index entry (ptr, fixed bin (35));
dcl  astty_$tty_order entry (ptr, char (*), ptr, fixed bin (35));
dcl  astty_$tty_state entry (ptr, fixed bin (35));
dcl  asu_$asu_listen entry (ptr, fixed bin (35));
dcl  asu_$attach_channel entry (ptr, fixed bin (35));
dcl  asu_$release_ate entry (ptr, fixed bin (35));
dcl  asu_$channel_in_use entry (ptr) returns (bit (1) aligned);
dcl  convert_status_code_ entry (fixed bin (35), char (*) aligned, char (*) aligned);
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  dial_ctl_$dial_term entry (ptr);
dcl  dialup_ entry;
dcl  dpg_ entry (ptr, char (*));
dcl  ftp_dialup_ entry;
dcl  ftp_dialup_$init entry;
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  hphcs_$get_ipc_operands entry (bit (36) aligned, fixed bin (18), fixed bin (35), fixed bin (35));
dcl  hphcs_$ips_wakeup entry (bit (36) aligned, char (*));
dcl  hphcs_$process_status entry (ptr);
dcl  hphcs_$set_cpu_monitor entry (bit (36) aligned, fixed bin (71), fixed bin (35));
dcl  (ioa_$rsnnl, ioa_$rs) entry options (variable);
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$unmask_ev_calls entry (fixed bin (35));
dcl  ipc_validate_$encode_event_channel_name entry (fixed bin (18), fixed bin (35), bit (3) aligned, fixed bin (15),
	fixed bin (3), bit (1) aligned, fixed bin (18), fixed bin (71));
dcl  send_system_message_ entry (ptr, ptr, fixed bin (35));
dcl  sub_err_ entry () options (variable);
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
dcl  user_table_mgr_$allocate entry (fixed bin) returns (ptr);
dcl  user_table_mgr_$free entry (ptr);

/* External */

dcl  (as_error_table_$bump_mins_msg,
     as_error_table_$bump_secs_msg,
     as_error_table_$from_multics_msg,
     as_error_table_$inactive,
     as_error_table_$tty_already,
     as_error_table_$tty_dim_err,
     as_error_table_$tty_is_master,
     as_error_table_$tty_no_room,
     as_error_table_$warn_msg) fixed bin (35) external;

dcl  (error_table_$action_not_performed,
     error_table_$null_info_ptr,
     error_table_$out_of_sequence,
     error_table_$undefined_order_request) fixed bin (35) ext static;

/* Based */

dcl  based_area area based (get_system_free_area_ ());

/* Constants */

dcl  ME char (32) initial ("asu_") internal static options (constant);
dcl  NL char (1) aligned int static options (constant) init ("
");

/* Internal Static */

dcl  ftp_dialup_init bit (1) int static init ("0"b);
dcl  (from_mx_fmt, bump_min_fmt, bump_sec_fmt) char (100) aligned int static;

/* Automatic */

dcl  activity_can_unbump bit (1) aligned init ("0"b);	/* controls ate field */
dcl  bump_added_info char (32);			/* for bump_mins and bump_secs */
dcl  cdtex fixed bin;
dcl  code fixed bin (35);
dcl  entry_name char (32) varying;			/* for printing entry point name in error messages */
dcl  error_message char (256) automatic;
dcl  (i, savi) fixed bin;				/* temps */
dcl  just_listen bit (1) aligned;
dcl  lng fixed bin;					/* temp */
dcl  long char (100) aligned;				/* Used by write_message to get message */
dcl  msg char (150) aligned, mstring char (200) aligned;	/* temps */
dcl  multics_msg_date char (64) varying;		/* for from_multics_msg */
dcl  old_ips_mask bit (36) aligned;			/* former IPS mask */
dcl  old_state fixed bin;
dcl  prefix char (100) aligned;			/* temp */
dcl  r_factor fixed bin (35);				/* ditto */
dcl  r_offset fixed bin (18);				/* IPC operands for initial wakeup */
dcl  shxx char (8) aligned;
dcl  start_proc_chn fixed bin (71);			/* event channel for start wakeup for process */

/* Program */
%page;
/* ASU_ATTACH - Called by admin to listen to an existing line which had previously been removed or detached.
*/

asu_attach:
     entry (bv_tty_name, bv_code_2);

	ansp = as_data_$ansp;
	just_listen = ""b;
	bv_code_2 = 0;				/* be sure to return zero unless something goes wrong */
	if bv_tty_name = as_tty then go to master_error;
	if bv_tty_name = anstbl.as_tty then do;		/* check for restricted tty name */

master_error:
	     bv_code_2 = as_error_table_$tty_is_master;
	     return;
	end;

	cdtp = scdtp;				/* unsave ptr to CDT */

/* CHANGE THIS TO USE cdt_mgr_ */

	do cdtex = 1 to cdt.current_size;
	     cdtep = addr (cdt.cdt_entry (cdtex));
	     if cdte.in_use ^= NOW_FREE & cdte.name = bv_tty_name
	     then goto found_cdte;
	end;					/* if we fall thru, the channel is not in the CDT */
	call sys_log_ (SL_LOG,
	     "asu_: ^a is not in CDT and so cannot be attached",
	     bv_tty_name);
	bv_code_2 = error_table_$action_not_performed;	/* tell admin that something went wrong,
						   but we already told the operator about it */
	return;
found_cdte:
	if cdte.in_use = CHANNEL_DELETED then do;
	     call sys_log_ (SL_LOG,
		"asu_: ^a has been deleted by a CDT installation, and so cannot be attached", bv_tty_name);
	     bv_code_2 = error_table_$action_not_performed; /* it didn't work and we already said why */
	     return;
	end;

	if cdte.in_use = NOT_CONFIGURED then do;
	     call sys_log_ (SL_LOG,
		"asu_: ^a was not configured at bootload time, and so cannot be attached.",
		bv_tty_name);
	     bv_code_2 = error_table_$action_not_performed; /* it didn't work and we already said why */
	     return;
	end;

	if cdte.current_service_type = MPX_SERVICE then do;
	     call sys_log_ (SL_LOG,
		"asu_: ^a in use as a multiplexer and cannot be attached.",
		bv_tty_name);
	     bv_code_2 = error_table_$action_not_performed;
	     return;
	end;

	if cdte.current_service_type = TANDD_SERVICE then do;
	     call sys_log_ (SL_LOG,
		"asu_: ^a in use for T & D and cannot be attached.",
		bv_tty_name);
	     bv_code_2 = error_table_$action_not_performed;
	     return;
	end;

	if cdte.in_use ^= NOW_HUNG_UP then do;		/* Gack! User exists! */
	     old_state = cdte.state;			/* well, maybe not. let's see */
	     call astty_$tty_state (cdtep, code);
	     if (old_state ^= cdte.state) | (cdte.state < TTY_DIALED) then
		call sys_log_ (SL_LOG,
		     "asu_: ^a has in_use = ^d, current state = ^d^[, CDTE.state was ^d^;^s^].",
		     cdte.name, cdte.in_use, cdte.state, (old_state ^= cdte.state), old_state);
	     if cdte.state < TTY_DIALED then just_listen = "1"b;

	     else do;				/* it seems ther really is a user on the channel */
		bv_code_2 = as_error_table_$tty_already;/* so complain and refuse to attach it again */
		return;
	     end;
	end;

	if cdte.state = TTY_MASKED then do;
	     call sys_log_ (SL_LOG, "asu_: unmasking channel ^a.",
		cdte.name);
	     call astty_$tty_order (cdtep, "unmask", null (), code);
	     if code ^= 0 &
		code ^= error_table_$undefined_order_request then do; /* if we don't have the right hardcore, too bad */
		bv_code_2 = code;
		call sys_log_$error_log (SL_LOG, code, "asu_",
		     "unable to unmask channel ^a.", cdte.name);
		bv_code_2 = code;
		return;
	     end;
	end;

	if cdte.current_service_type = MC_SERVICE then do;
	     call sys_log_ (SL_LOG,
		"asu_: ^a is in use by the message coordinator and cannot be attached.", cdte.name);
	     bv_code_2 = error_table_$action_not_performed; /* it didn't work and we already said why */
	     return;
	end;

	if cdte.service_type = ANS_SERVICE |		/* If permanently registered to Ans Svc */
	     cdte.service_type = SLAVE_SERVICE |	/* or a slave channel */
	     cdte.service_type = FTP_SERVICE |
	     cdte.service_type = DIAL_OUT_SERVICE then do;/* or a dial out channel */
	     cdte.current_service_type = cdte.service_type; /* give it back */
	     if just_listen then do;
		call sys_log_ (SL_LOG,
		     "asu_: ^a is already attached; will try to listen to it again", cdte.name);
		bv_code_2 = 0;
	     end;
	     else call asu_$attach_channel (cdtep, bv_code_2);
	     if bv_code_2 = 0 then			/* if attached ok, try listen. This happens for the operator */
		call asu_$asu_listen (cdtep, bv_code_2);/* command attach only, not for as_init_'s attach calls */
	end;
	else if cdte.current_service_type = ANS_SERVICE	/* Or if temporarily registered to AS */
	     | cdte.current_service_type = FTP_SERVICE
	     | cdte.current_service_type = INACTIVE	/* or if it is not doing anything at the moment */
	then do;					/* let dialup_ have it */
	     if cdte.current_service_type = INACTIVE then
		cdte.current_service_type = ANS_SERVICE;
	     if just_listen then do;
		call sys_log_ (SL_LOG,
		     "asu_: ^a is already attached; will try to listen to it again", cdte.name);
		bv_code_2 = 0;
	     end;
	     else call asu_$attach_channel (cdtep, bv_code_2);
	     if bv_code_2 = 0 then			/* see comments above */
		call asu_$asu_listen (cdtep, bv_code_2);
	end;

	else do;
	     call sys_log_ (SL_LOG,
		"asu_: ^a cannot be attached because its service type is ^[MC^;unknown^] (^d).",
		cdte.name, (cdte.service_type = MC_SERVICE), cdte.service_type);
	     code = error_table_$action_not_performed;
	end;
	return;


/* ATTACH_ATE - Called to obtain an ATE for the channel. */

attach_ate: entry (bv_ptr_1, bv_code_2);

	cdtep = bv_ptr_1;
	utep = user_table_mgr_$allocate (PT_INTERACTIVE);
	if utep = null () then do;
	     bv_code_2 = as_error_table_$tty_no_room;
	     return;
	end;

	call ipc_$decl_ev_call_chn (ute.event, dialup_, utep, INT_LOGIN_PRIO, code);
	if code ^= 0 then do;			/* if either call failed, complain and get out immediately */
	     call sys_log_$error_log (SL_LOG_BEEP, code, "asu_$attach_ate",
		"Unable to create event channel for new UTE ^p", utep);
	     bv_code_2 = as_error_table_$tty_no_room;
	     return;
	end;

	ute.tty_name = cdte.name;			/* Fill in new ATE. */
	ute.active = cdte.in_use;

	cdte.process = utep;			/* cross-link entries */
	ute.channel = cdtep;

	ute.count = 0;
	bv_code_2 = 0;
	return;
%page;
/* RELEASE_ATE - Drop the Answer Table entry associated with a channel */

release_ate: entry (bv_ptr_1, bv_code_2);

	cdtep = bv_ptr_1;
	utep = cdte.process;
	bv_code_2 = 0;
	if utep = null then return;
	ansp = as_data_$ansp;
	if baseno (utep) ^= baseno (ansp) then do;	/* trap bug */
	     call sys_log_ (SL_LOG_SILENT,
		"asu_$release_ate: bad cdte.process (^p) for ^a", cdte.process, cdte.name);
	     return;
	end;
	call user_table_mgr_$free (utep);
	cdte.process = null;
	return;
%page;
/* ATTACH_CHANNEL - called to attach a specific Channel Definition Table entry. */

attach_channel: entry (bv_ptr_1, bv_code_2);

	cdtep = bv_ptr_1;
	bv_code_2 = 0;
	entry_name = "attach_channel";

	if cdte.current_service_type = INACTIVE then do;	/* if channel was detached or removed */
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: attach channel not done on ^a: current service type = INACTIVE", cdte.name);
	     bv_code_2 = error_table_$action_not_performed;
	     return;				/* then don't attach it now */
	end;

	if cdte.current_service_type = MPX_SERVICE then do;
	     call sys_log_ (SL_LOG,
		"asu_: attach channel not done on ^a: current service type = MPX_SERVICE", cdte.name);
	     bv_code_2 = error_table_$action_not_performed;
	     return;
	end;

	call reset_access_class (cdtep);		/* recurse -- this gets dial_out channels into a known state W.R.T. access class. */
	call astty_$tty_index (cdtep, code);		/* get devx from hardcore */
	if code ^= 0 then call error ("tty_index");	/* probably mispelled, or not configured */

	if cdte.event = 0 then do;
	     call ipc_$create_ev_chn (cdte.event, code);	/* Make event-call channel to run tty. */
	     if code ^= 0 then call error ("create_ev_chn"); /* this is bad news! */
	end;

	if cdte.service_type = FTP_SERVICE
	then do;
	     if ^ftp_dialup_init
	     then do;				/* only attempt to reference Network software */
		call ftp_dialup_$init;		/* if the user attaches Network channels */
		ftp_dialup_init = "1"b;
	     end;
	     call ipc_$decl_ev_call_chn (cdte.event, ftp_dialup_, cdtep, INT_LOGIN_PRIO, code);
	end;
	else call ipc_$decl_ev_call_chn (cdte.event, dialup_, cdtep, INT_LOGIN_PRIO, code);
	if code ^= 0 then call error ("decl_ev_call_chn");/* this line has just died. */

	call astty_$tty_event (cdtep, code);		/* Tell hardcore name of event channel. */
	if code ^= 0 then call error ("tty_event");	/* quit if get error */

/* Setting of line type here allows CDT installation to change a line's type.
   Except for that, setting of line type is done at initialization time */
	if cdte.line_type ^= 0 then do;		/* if line type given, set it */
	     i = cdte.line_type;			/* get it into a full word */
	     call astty_$tty_order (cdtep, "set_line_type", addr (i), code);
	     if code ^= 0 then
		call error ("set_line_type");
	end;

/* Don't listen yet; FNPs might not be up. We have grabbed the channel, though */

	return;


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

/* The following entry point is called to enable for listening a known, hungup, channel */

asu_listen:
     entry (bv_ptr_1, bv_code_2);

	entry_name = "asu_listen";

	cdtp = scdtp;				/* copy saved ptr to CDT */
	cdtep = bv_ptr_1;				/* Get ptr to chn */
	bv_code_2 = 0;				/* initialize error code */

	if asu_$channel_in_use (cdtep) then do;
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: listen not done on ^a: IN_USE with state = ^d, in_use = ^d, tra_vec = ^d",
		cdte.name, cdte.state, cdte.in_use, cdte.tra_vec);
	     bv_code_2 = error_table_$action_not_performed;
	     return;				/* if channel in use, leave it alone */
	end;

	if cdte.current_service_type = INACTIVE then do;	/* if channel was detached or removed */
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: listen not done on ^a: current service type = INACTIVE", cdte.name);
	     bv_code_2 = error_table_$action_not_performed;
	     return;				/* don't listen to it */
	end;

	if cdte.current_service_type = MPX_SERVICE then do; /* if channel was detached or removed */
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: listen not done on ^a: current service type = MPX_SERVICE", cdte.name);
	     bv_code_2 = error_table_$action_not_performed;
	     return;				/* don't listen to it */
	end;
	if cdte.current_service_type = TANDD_SERVICE then do; /* if channel was detached or removed */
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: listen not done on ^a: current service type = TANDD_SERVICE", cdte.name);
	     bv_code_2 = error_table_$action_not_performed;
	     return;				/* don't listen to it */
	end;

	if cdte.service_type = DIAL_OUT_SERVICE then do;	/* initialize cdte for dial out */
	     cdte.tra_vec = WAIT_SLAVE_REQUEST;
	     cdte.process = null ();
	     cdte.dialed_to_procid = "0"b;
	     cdte.in_use = NOW_HUNG_UP;
	     cdte.current_service_type = cdte.service_type;
	     return;
	end;

	if cdte.current_service_type = MC_SERVICE then do;
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: listen not done on ^a: current service type = MC", cdte.name);
	     bv_code_2 = error_table_$action_not_performed;
	     return;				/* This here entry ignores MC */
	end;

	call astty_$tty_event (cdtep, code);		/* be sure we are the channel's user process - we should be,
						   but there are ways to get here where we might not be */
	if code ^= 0 then call error ("tty_event");

	call astty_$tty_order (cdtep, "listen", null, code); /* Tell dim to accept calls on this line */
	if code ^= 0 then call error ("listen");	/* quit if any error. */

	if cdte.state < TTY_KNOWN then do;
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: listen failed on ^a. state=^d", cdte.name, cdte.state);
	     bv_code_2 = error_table_$action_not_performed;
	     return;				/* Make sure that channel is indeed being listened to. */
	end;

/* Check for a slave channel that has been priv-attached and is waiting for a dialup */

	if cdte.current_service_type = SLAVE_SERVICE
	     & cdte.tra_vec = WAIT_FIN_PRIV_ATTACH
	     & cdte.process ^= null
	     & cdte.dialed_to_procid ^= ""b then ;	/* leave it alone */

	else do;					/* otherwise wait for what is appropriate to its service type */
	     if cdte.service_type = SLAVE_SERVICE then	/* slave device set transfer vector */
		cdte.tra_vec = WAIT_SLAVE_REQUEST;	/* to ignore channel until requested */
	     else cdte.tra_vec = WAIT_DIALUP;		/* Set transfer vector to print greeting. */
	     cdte.process = null;			/* .. no ATE yet */
	     cdte.user_name = "";
	end;

	cdte.in_use = NOW_LISTENING;
	return;					/* listen */


reset_access_class:
     entry (bv_ptr_1);

	cdtep = bv_ptr_1;

	cdte.current_access_class_valid = "0"b;
	cdte.current_access_class = ""b;
	if aim_check_$equal (cdte.access_class (1), cdte.access_class (2))
	then do;
	     cdte.current_access_class_valid = "1"b;
	     cdte.current_access_class = cdte.access_class;
	end;
	return;


error: procedure (comment);				/* errors from asu_$attach and asu_$listen come here */

declare  comment char (*);

	if code = -1 then				/* astty_ uses -1 to mean channel hung up */
						/* if an operation failed and astty_ censored the code to -1 */
						/* then we give up here and now. */
	     go to nonlocal_return_label;		/* let caller continue - don't drop the channel */

error_join:
	call sys_log_$error_log (SL_LOG_BEEP, code, "asu_",
	     "^a ^a error; will remove channel ^a ^a",
	     entry_name, comment, cdte.name, cdte.comment);
	call asu_remove (cdtep);			/* make it go away */
						/* recurse ! */
	bv_code_2 = as_error_table_$tty_dim_err;	/* return standard code */
	goto nonlocal_return_label;			/* get out of internal proc and return from external one */

     end error;

nonlocal_return_label: return;			/* return from the external procedure */

/* ============================================================= */

/* the remove entry point is called to completely remove a tty channel from the system */
/* the phone is hung up; if it is a dialed console it is cleaned out;
   if it is a process it is destroyed.  The event channel remains, however,
   because there is no sure-fire way to get ring-0 to never send wakeups. */

asu_remove: entry (p2);

	cdtep = p2;				/* copy into automatic */
	if cdte.current_service_type = MPX_SERVICE
	then do;
	     call sys_log_ (SL_LOG,
		"asu_: ^a is a multiplexer and cannot be removed.", cdte.name);
	     return;				/* no error code, so we cannot return it */
	end;
	call astty_$tty_index (cdtep, code);		/* This resets channel switches, and gets devx again. */
	if code = 0 then do;			/* Only mess with it if channel does exist. */
	     call astty_$tty_order (cdtep, "hangup", null, code); /* Hang phone. */
	     cdte.tra_vec = WAIT_HANGUP;		/* There will be a hangup wakeup */
						/* this will be reset if there is a process to be destroyed */
	     call astty_$tty_detach (cdtep, 0, code);	/* Detach console from process. */
	     call ipc_$drain_chn (cdte.event, code);	/* Flush any pending wakeups. */
	end;
	if as_data_$ansp ^= null then			/* If answering service started, we're cool */
	     if cdte.service_type = ANS_SERVICE | cdte.service_type = FTP_SERVICE
	     then do;
		if cdte.dialed_to_procid ^= "0"b then	/* call dial_ctl_ if slave */
		     call dial_ctl_$dial_term (cdtep);
		else if cdte.in_use = NOW_HAS_PROCESS	/* Has a process? */
		then do;
						/* (this code should be in dialup_) */
		     utep = cdte.process;		/* Answering service channel. */
		     call dpg_ (utep, "error");	/* destroy it */
		     ute.login_flags.noprint = "1"b;
		     ute.logout_type = "remo";
		     cdte.tra_vec = WAIT_REMOVE;	/* Set dialup control point. */
		     ute.destroy_flag = WAIT_LOGOUT;	/* tell act_ctl_ */
		     return;			/* dialup_ will do the rest */
		end;
	     end;

	     else if cdte.service_type = DIAL_OUT_SERVICE then /* auto call line ? */
		if cdte.dialed_to_procid ^= "0"b then call dial_ctl_$dial_term (cdtep);

	if cdte.in_use ^= NOW_HAS_PROCESS then do;	/* if process is being destroyed, must keep cdte "live" a while */
						/* leave tra_vec at WAIT_HANGUP */
	     cdte.in_use = NOW_HUNG_UP;		/* otherwise, remember it is hung up */
	     cdte.current_service_type = INACTIVE;	/* ignore channel until CDT installation or next bootload */
	     if cdte.n_disconnected_procs > 0 then	/* release the UTE of the current connection
						   we must be in a login connect loop since our
		                                           in_use state is less than HAS_PROCESS. */
		call asu_$release_ate (cdtep, code);
	end;

	if cdte.tra_vec = WAIT_FIN_TANDD_ATTACH then	/* we don't want it to stay this way when reattached */
	     cdte.tra_vec = WAIT_DIALUP;
	return;

/* ============================================================= */


/* The remove_cdte entry point is called when a cdte is so messed up that we
   don't know what to do. We used to crash the system, but that is too drastic.
   Now, we just complain a lot, and then try to get rid of the channel and its
   cdte, so the problem does not happen repeatedly */

remove_cdte: entry (bv_ptr_1);

	cdtep = bv_ptr_1;
	cdtp = scdtp;

	if baseno (cdtp) ^= baseno (cdtep) then do;	/* just as unlikely as anything else */
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: cdtep (^p) not cdt (^p)", cdtep, cdtp);
	     return;
	end;

	call astty_$tty_state (cdtep, code);
	if code ^= 0 then do;
	     if code = -1 then			/* channel hung up */
		call sys_log_ (SL_LOG_SILENT, "asu_: cdte ^p (^a) hung up",
		     cdtep, cdte.name);
	     else do;
		call sys_log_$error_log (SL_LOG_SILENT, code,
		     "asu_$remove_cdte", "cdte ^p error from tty_state", cdtep);
		return;				/* if tty_state fails, tty_hangup and detach probably will too */
	     end;
	end;

	call sys_log_ (SL_LOG_SILENT,
	     "asu_: cdte ^p (^a) state ^d in use ^d tra vec ^d",
	     cdtep, cdte.name, cdte.state, cdte.in_use, cdte.tra_vec);


	call asu_remove (cdtep);
	return;

/* ============================================================= */


/* This entry point is a function that tells the caller whether or not a channel is in use.
   A channel is considered to be in use if it is dialed up and a user has typed something,
   such as the login or dial commands, or if a process has it attached, as a slave,
   dial out, etc. channel. If it is merely dialed up, it is considered not in use,
   which is partly by design and partly by necessity: a hardwired channel always
   looks dialed up, even if there is no user doing anything to or with it.

   This function is used in place of less accurate, in-line decisions regarding
   channel activity, in various answering service procedures, such as:
   -	The count_fnp_users procedure in admin, which counts used channels on an FNP;
   -	the check in fnp_manager_$fnp_listen, to avoid re-listening to a used channel.

*/

channel_in_use: entry (bv_ptr_1) returns (bit (1) aligned);

	cdtp = scdtp;				/* copy saved ptr to CDT */
	cdtep = bv_ptr_1;				/* and ptr to CDT entry */

	if cdte.twx = 0 then go to return_false;	/* if no devx, can't be in use */

	if cdte.state <= TTY_KNOWN then		/* if hung up or listening */
	     goto return_false;			/* clearly not in use */


	if cdte.in_use <= NOW_LISTENING then		/* clearly not in use, but cdte inconsistent */
	     goto return_false;			/* say it's not in use - let caller feel free to fix it up */

	if cdte.in_use >= NOW_LOGGED_IN then		/* clearly in use */
	     goto return_true;			/* I think? */

/* cdte.in_use = NOW_DIALED, so the decision gets more complicated */

	if cdte.tra_vec >= WAIT_LOGIN_ARGS then		/* if user is logging in, or past that stage */
	     if cdte.tra_vec < WAIT_HANGUP then		/* and not on the way out */
		goto return_true;			/* this one is definitely not clear */

/* any other criteria to look at? */

/* if not, fall thru and say not in use */

return_false: return (""b);

return_true: return ("1"b);

/* ============================================================= */

/* The find_process entry is called to locate a user process in the various possible user tables.
   It looks for absentees, daemons, and interactive users, and returns
   a pointer to the answer table - style entry for the user.
   A flag is also set telling what kind of user was found. */

find_process: entry (a_pid, a_type, outp);

dcl  a_pid bit (36) aligned,				/* process id to look up user entry for */
     a_type fixed bin,				/* 1 = ia, 2 = abs, 3 = dmn */
     outp ptr;					/* ptr to entry in anstbl or aut or dut */

	a_type = PT_INTERACTIVE;
	ansp = as_data_$ansp;
	do i = 1 to anstbl.current_size;		/* interactive users first */
	     utep = addr (anstbl.entry (i));		/* Locate anwwer table entry */
	     if ute.active = NOW_HAS_PROCESS then	/* Gotta have process */
		if ute.proc_id = a_pid then go to afnd; /* processid must match */
	end;
	a_type = PT_ABSENTEE;
	autp = as_data_$autp;
	do i = 1 to autp -> autbl.current_size;		/* no, well try absentees */
	     utep = addr (autp -> autbl.entry (i));
	     if ute.active ^= NOW_FREE then		/* Is slot in use? */
		if ute.proc_id = a_pid then go to afnd;
	end;
	a_type = PT_DAEMON;
	dutp = as_data_$dutp;
	do i = 1 to dutbl.current_size;		/* Scan daemon table. */
	     utep = addr (dutbl.entry (i));		/* Get ptr to daemon entry. */
	     if ute.active = NOW_HAS_PROCESS then	/* Should have a process. */
		if ute.proc_id = a_pid then do;	/* Is this process the one we look for? */
afnd:		     outp = utep;			/* whee */
		     return;
		end;
	end;
	outp = null;				/* Couldn't find it. */
	a_type = 0;				/* ... */
	return;					/* sorry */


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

/* The check_for_stopped_process entry is called when a wakeup like "logout"
   or "bump" is received for a process whose tra_vec indicates that it has
   already been bumped or logged out, and is waiting for a "stopstop" wakeup.
   We check the actual state of the process (5 = stopped) and print a message
   indicating what we found. If state = 5 we return "1"b so the caller knows
   it is safe to finish destroying the process, even though the stopstop
   never arrived (apparently it was lost). */

check_for_stopped_process: entry (P_utep, caller_name) returns (bit (1) aligned);

dcl  caller_name char (*);


	utep = P_utep;
	if utep = null then return (""b);		/* avoid fault when channel has no process */
	process_status_return.target_proc = ute.proc_id;
	call hphcs_$process_status (addr (process_status_return));
	if process_status_return.up_exec = 5 then do;
	     call sys_log_ (SL_LOG,
		"asu_: (called by ^a) ^a.^a ^a was already stopped and will be destroyed (stopstop wakeup was lost)",
		caller_name, ute.person, ute.project, ute.tty_name);
	     return ("1"b);
	end;
	else do;
	     call sys_log_ (SL_LOG,
		"asu_: (called by ^a) ^a.^a ^a is not stopped (state = ^d) even though destroy flag = ^d;
it might not be possible to destroy this process",
		caller_name, ute.person, ute.project, ute.tty_name, process_status_return.up_exec, ute.destroy_flag);
	     return (""b);
	end;

/* ======================================================= */

/* Utility entry to write a message which is in the form of a system error code.
   Usually these codes are in as_error_table_.
   The message is splashed on the user's console. */

write_chn_message: entry (chnp, mescode, short, P_code);

dcl  chnp ptr;
dcl  channel_call bit (1) init ("0"b);

	cdtep = chnp;				/* Get channel ptr */
	channel_call = "1"b;

write_message: entry (P_utep, mescode, short, P_code);

dcl  mescode fixed bin (35),				/* system error code */
     short char (8) aligned;				/* shortinfo */

	P_code = 0;
	call convert_status_code_ (mescode, short, long); /* decode message */
	if ^channel_call then do;
	     utep = P_utep;				/* copy arg */
	     if ute.queue = 0 & ^ute.adjust_abs_q_no then do; /* if interactive, see if channel exists */
		cdtep = ute.channel;		/* Get channel ptr */
	     end;
	     else if ute.queue > 0 | ute.adjust_abs_q_no then return; /* if absentee, quit */
	end;

	if long = "" then return;			/* May have null value. */
	if ^channel_call then
	     if ute.queue = -1 then do;		/* DAEMON */
		call sys_log_ (SL_LOG, rtrim (long));	/* There is intentionally no operator */
		return;				/* documentation for this arbitrary message. */
	     end;

	call ioa_$rs ("^a", mstring, i, long);
	if cdtep ^= null then do;
	     if cdte.service_type = FTP_SERVICE then
		mstring = format_ftp_msg ((long), i, i, 030);
	end;
	if channel_call then
	     call astty_$tty_force (cdtep, addr (mstring), i, P_code);
	else
	     call BLAST_USER (utep, substr (mstring, 1, i),
		"0"b /* already formatted */, "0"b /* not a warn */,
		error_message, P_code);
	return;
%page;
/* ======================================================= */

/* Utility entry to bump a user. Makes nice message and splats it on his console. */

bump_code: entry (P_utep, mcode, mshort, P_code, grctim);

dcl  mcode fixed bin (35),				/* message code */
     mshort char (8) aligned;

	utep = P_utep;
	call convert_status_code_ (mcode, mshort, prefix);
	if mcode = as_error_table_$inactive then do;
	     activity_can_unbump = "1"b;
	     bump_added_info = " unless you become active";
	end;
	else bump_added_info = "";
	go to bjoin;

bump_user: entry (P_utep, wrd, P_code, grctim);

dcl  wrd char (*),					/* message */
     grctim fixed bin;				/* seconds allowed for user cleanup */

	P_code = 0;
	utep = P_utep;				/* copy ptr into auto */
	prefix = wrd;				/* Set up message */
	bump_added_info = "";

bjoin:
	ansp = as_data_$ansp;
	anstbl.current_time = clock ();
	if ute.preempted >= PREEMPT_BUMPED then do;	/* if user has already been bumped, don't do it again */
	     ute.uflags.activity_can_unbump = "0"b;	/* nothing can save him */
	     return;
	end;
	ute.uflags.activity_can_unbump = activity_can_unbump; /* inactive? start working and save your process */

	if ute.at.no_warning then goto omit_warning;	/* if user said -no_warning then don't warn him */
	if ute.queue ^= 0 | ute.adjust_abs_q_no then goto omit_warning; /* if absentee or daemon, there's nobody to warn */

	if grctim = 0 then msg = "";			/* if immediate kill */
	else do;					/* given some grace */
	     if mod (grctim, 60) = 0 then call ioa_$rsnnl (bump_min_fmt,
		     msg, lng, divide (grctim, 60, 17, 0), bump_added_info);
	     else call ioa_$rsnnl (bump_sec_fmt, msg, lng, grctim, bump_added_info);
	end;
	multics_msg_date = date_time_$format ("date_time", anstbl.current_time, "", "");
	call ioa_$rs (from_mx_fmt, mstring, lng, multics_msg_date, prefix, msg);
	cdtep = ute.channel;			/* Locate channel */
	if cdtep ^= null () then do;			/* check for FTP service */
	     if cdte.service_type = FTP_SERVICE then do;
		if grctim = 0
		then mstring = format_ftp_msg (mstring, lng, lng, 434);
		else mstring = format_ftp_msg (mstring, lng, lng, 030);
	     end;
	end;

	error_message = "";

	call BLAST_USER (P_utep, substr (mstring, 1, lng),
	     "0"b /* already formatted */, "1"b /* bump message */,
	     error_message, P_code);
	if P_code ^= 0 & P_code ^= error_table_$action_not_performed then
	     call sys_log_$error_log (SL_LOG_SILENT, P_code,
		"asu_$bump_user",
		"^a Sending blast message to ^a.^a on ^a", error_message,
		ute.person, ute.project, ute.tty_name);

omit_warning:
	ute.preempted = PREEMPT_BUMPED;		/* Mark "waiting bump" */
	call timer_manager_$alarm_wakeup ((grctim), "11"b, ute.event);
	return;					/* Done. */
%page;
reschedule_bump_timer:
     entry (P_utep, grctim);

/* this entry reschedules the inactivity check timer to new time.
   It was put here since the bump entries set the orignal timer and is in a common place */

	utep = P_utep;

/* kill current bump timeout */
	call timer_manager_$reset_alarm_wakeup (ute.event);

/* reschedule for new time */
	call timer_manager_$alarm_wakeup ((grctim), "11"b, ute.event);

	return;
%page;
unbump_user:
     entry (P_utep, P_code);

/**** This entry provides an interface to unbump a user. */

	call process_proc_term_request ("unbump");
	return;
%page;
terminate_user:
     entry (P_utep, P_code);

/**** This entry provides an interface to terminate a user. */

	call process_proc_term_request ("terminate");
	return;
%page;
disconnect_user:
     entry (P_utep, P_code);

/**** This entry provides an interface to disconnect a user. */

	call process_proc_term_request ("hangup");
	return;
%page;
detach_user:
     entry (P_utep, P_code);

/**** This entry provides an interface to detach a user. */

	call process_proc_term_request ("detach");
	return;
%page;
send_term_signal: entry (P_utep, a_logout_index) returns (bit (1) aligned);

dcl  a_logout_index fixed bin;
dcl  term_cpu_limit fixed bin (71);
dcl  term_realtime_limit fixed bin (71);

	utep = P_utep;
	if utep = null then return (""b);		/* don't blow up because of a careless caller */
	if ute.preempted >= PREEMPT_TERM_SENT then	/* if term already sent or not to be sent */
	     return (""b);				/* tell caller to kill process immediately */

	ute.logout_index = a_logout_index;		/* remember what we were doing to this user */
	ute.preempted = PREEMPT_TERM_SENT;		/* remember that we sent term */
	call hphcs_$ips_wakeup (ute.proc_id, "trm_");	/* send it */
	term_cpu_limit = installation_parms.term_cpu_time_seconds * 1000000;
	if term_cpu_limit <= 0 then term_cpu_limit = 5000000;
	term_realtime_limit = installation_parms.term_real_time_seconds;
	if term_realtime_limit <= 0 then term_realtime_limit = installation_parms.warning_time;
	ute.ignore_cpulimit = ""b;			/* enable cpulimit timer for this process */
	call hphcs_$set_cpu_monitor (ute.proc_id, term_cpu_limit, code); /* set cpu time limit */
	call timer_manager_$alarm_wakeup (term_realtime_limit, "11"b, ute.event); /* and real time limit */

	return ("1"b);				/* tell caller to wait for termsgnl from process */

suspend_process: entry (P_utep);

	utep = P_utep;				/* copy ptr to user table entry */
	if utep = null then do;			/* trap bug */
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: suspend_process called with null UTE ptr.");
	     return;
	end;

	if ute.sus_sent & ^ute.ignore_cpulimit then do;	/* trap different bug */
	     call sys_log_ (SL_LOG,
		"asu_$suspend_process: ^a.^a ^a is already suspended",
		ute.person, ute.project, ute.tty_name);
	     return;
	end;

/* Compute real and cpu time limits (borrow variables from send_term_signal). Ensure reasonable values. */

	term_cpu_limit = installation_parms.sus_cpu_time_seconds * 1000000;
	if term_cpu_limit <= 0 then term_cpu_limit = 5000000;
	term_realtime_limit = installation_parms.sus_real_time_seconds;
	if term_realtime_limit <= 0 then term_realtime_limit = 180;

/* Set flags in user table entry */

	ute.suspended = ""b;			/* clear flag that says when process has responded */
	ute.sus_sent = "1"b;			/* we will, in a few lines */
	ute.ignore_cpulimit = ""b;			/* enable cpulimit timer for this process */
	ute.sus_channel = 0;			/* clear any possible garbage */

/* Send sus_ and set real and cpu timers */

	call hphcs_$ips_wakeup (ute.proc_id, "sus_");
	call hphcs_$set_cpu_monitor (ute.proc_id, term_cpu_limit, code);
	call timer_manager_$alarm_wakeup (term_realtime_limit, "11"b, ute.event);

	return;
%page;
release_suspended_process: entry (P_utep);

	utep = P_utep;				/* copy ptr to user table entry */
	if utep = null then do;			/* trap bug */
	     call sys_log_ (SL_LOG_SILENT,
		"asu_: release_suspended_process called with null UTE ptr");
	     return;
	end;

	if ^ute.sus_sent then do;			/* trap other bug */
	     call sys_log_ (SL_LOG_SILENT,
		"asu_$release_suspended_process: ^a.^a ^a is not suspended",
		ute.person, ute.project, ute.tty_name);
	     return;
	end;

	ute.ignore_cpulimit = "1"b;			/* "turn off" the cpulimit timer */
	if ute.suspended then do;			/* if process already responded to sus_ */
	     whotab.e (ute.whotabx).suspended = ""b;	/* publish it */
	     ute.suspended, ute.sus_sent = ""b;		/* clear the switches */
	end;
	else call timer_manager_$reset_alarm_wakeup (ute.event); /* if not, turn off the alarm timer */
						/* and wait until it responds, before sending the wakeup */

	return;

/* ============================================================= */

/* Entry to unclog backed-up table installations by forcing the
   answer_table lock, setting the update pending flag, and unmasking ips signals and
   event calls.  Just for good measure, a wakeup is also sent (otherwise
   we might have to wait until dialup_ gets invoked). */

reset:
     entry;

	ansp = as_data_$ansp;
	savi = anstbl.lock_count;
	anstbl.lock_count = 0;			/* clear the lock */
	code = 0;
	i = -1;
	do while (code = 0);
	     call ipc_$unmask_ev_calls (code);
	     i = i + 1;				/* count up depth of masking */
	end;
	call hcs_$set_ips_mask ((36)"1"b, old_ips_mask);	/* unmask all IPS channels */

	call sys_log_ (SL_LOG,
	     "asu_: lock was ^d, ev call mask was ^d, ips mask was ^12.3b", savi, i, old_ips_mask);

/* It is possible that we have "lost" an alarm timer.  We will set up a new one to go off in a few seconds,
   which should shake loose any that are waiting for the lost one to go off.  The new timer will actually
   serve a useful purpose; it will wakeup the table updating program to see if any installations are
   pending.   If timer_manager_ is busted so completely that this new timer never goes off, things
   are so messed up it isn't funny.  */

	call timer_manager_$alarm_wakeup (5, "11"b /* rel secs */, anstbl.update_channel);
	return;


format_ftp_msg:
     entry (P_bufr, P_in_lng, P_lng, P_ftp_code) returns (char (200) aligned);

/* formats messages for channels of FTP service_type, as specified in */
/* Arpanet protocol for server-FTP */

dcl  P_bufr char (200) aligned,
     P_lng fixed bin,
     P_ftp_code fixed bin,
     P_in_lng fixed bin;

dcl  result picture "999b";
dcl  min builtin;

	i = min (999, P_ftp_code);
	result = i;
	return (format_ftp_output (P_bufr, P_in_lng, P_lng, (result)));


init: entry;

	if ^sc_stat_$Multics_typed | sc_stat_$Go_typed then
	     call sub_err_ (error_table_$out_of_sequence, "asu_$init", "s");
	ftp_dialup_init = "0"b;
	call convert_status_code_ (as_error_table_$from_multics_msg, shxx, from_mx_fmt);
	call convert_status_code_ (as_error_table_$bump_mins_msg, shxx, bump_min_fmt);
	call convert_status_code_ (as_error_table_$bump_secs_msg, shxx, bump_sec_fmt);

	return;
%page;
start_process:
     entry (P_utep);

/**** This entry is used to start a process.  Initially, a process is in
      the blocked state awaiting a wakeup to get it running.  This entry
      provides that wakeup.  It is called by dialup_, absentee_user_manager_,
      and daemon_user_manager_. */

	utep = P_utep;

/**** Before we send a wakeup to the process, we must construct an event
      channel which will pass the IPC event channel validation tests.  To
      do this, we must learn the values of R-Offset and R-Factor for a
      process.  */

	call hphcs_$get_ipc_operands (ute.proc_id, r_offset, r_factor, code);
	if code = 0 then do;
	     call ipc_validate_$encode_event_channel_name (r_offset, r_factor, "000"b /* flags */, 1 /* index */, 4 /* ring */, "1"b /* regular */, 1 /* unique id */, start_proc_chn);

/**** Kick the process loose from initial block state */
	     call hcs_$wakeup (ute.proc_id, start_proc_chn, -1, code);
	     if code ^= 0 then			/* log any error for debugging */
		call sys_log_$error_log (SL_LOG_SILENT, code, ME,
		     "Sending initial wakeup to ^w (^a.^a)",
		     ute.proc_id, ute.person, ute.project);
	end;
	else call sys_log_$error_log (SL_LOG_SILENT, code, ME,
		"Retrieving the values of R-Offset and R-Factor for ^w (^a.^a)",
		ute.proc_id, ute.person, ute.project);

	return;
%page;
/* format: style5,ind5 */

blast_user:
     entry (P_utep, P_message, P_error_message, P_code);

	if P_utep = null () then
	     do;
	     call sys_log_$error_log (SL_LOG_SILENT, 0,
	         "asu_: blast_user called with null UTE ptr");
	     P_error_message = "utep = null ()";
	     P_code = error_table_$action_not_performed;
	     end;
	else
	     call BLAST_USER (P_utep, P_message, "1"b /* needs formatting */,
	         "0"b /* warn message */, P_error_message, P_code);

	return;
%page;
/**** format: style4 */
%page;
setup_login_server_handle:
     entry (P_utep);

/**** This entry, give a UTE pointer, initializes the value of
      ute.login_server_handle.our_handle, used for login server to
      answering service communications. */

	if P_utep = null () then
	     call sys_log_$error_log (SL_LOG_SILENT, 0, "asu_: setup_login_server_handle called with null UTE ptr.");
	else do;
	     utep = P_utep;
	     uc_ls_handle_ptr = addr (ute.login_server_info.our_handle);
	     uc_ls_handle.process_type = ute.process_type;
	     uc_ls_handle.ute_index = ute.ute_index;
	     uc_ls_handle.unique_id = substr (bit (clock (), 54), 18, 36);
	end;
	return;
%page;
format_ftp_output:
     proc (P_message, P_msg_lng, P_new_lng, P_ftp_code) returns (char (200) aligned);

dcl  P_message char (200) aligned,
     P_msg_lng fixed bin,
     P_new_lng fixed bin,
     P_ftp_code char (4) aligned;

dcl  build_string char (200) varying,
     i fixed bin,
     temp fixed bin;

	build_string = P_ftp_code;

	if P_msg_lng = 0
	then do;					/* caller had nothing to say */
	     build_string = build_string || NL;
	     P_new_lng = 5;
	     return (build_string);
	end;

	i = 1;

	temp = index (substr (P_message, i, P_msg_lng - i + 1), NL);

	do while ((temp ^= P_msg_lng - i + 1) & (temp ^= 0));
						/* while we are not at the last line in the message */
	     substr (build_string, 4, 1) = "-";		/* indicate this is a multiple line msg */
	     build_string = build_string || substr (P_message, i, temp);
	     i = i + temp;
	     temp = index (substr (P_message, i, P_msg_lng - i + 1), NL);
	end;

	if substr (build_string, 4, 1) = "-"
	then do;
	     build_string = build_string || P_ftp_code;	/* multiple concatenations are inefficient */
	     build_string = build_string || substr (P_message, i, P_msg_lng - i + 1); /* so build it up piece by piece */
	end;
	else build_string = build_string || substr (P_message, i, P_msg_lng - i + 1);
	P_new_lng = length (build_string);

	return (build_string);

     end format_ftp_output;
%page;
BLAST_USER:
     procedure (P_utep, P_message, P_need_formatting, P_bump_msg, P_error_message, P_code);

dcl  P_utep ptr parameter;
dcl  P_message char (*) parameter;
dcl  P_need_formatting bit (1) aligned parameter;
dcl  P_bump_msg bit (1) aligned parameter;
dcl  P_error_message char (*) parameter;
dcl  P_code fixed bin (35) parameter;

	utep = P_utep;
	if ute.at.no_warning then do;
	     call ioa_$rsnnl ("^a.^a has ""no_warning""", P_error_message,
		(0), ute.person, ute.project);
	     P_code = error_table_$action_not_performed;
	     return;
	end;

/**** If there is a process, use the new system message facility to send
      the message.  Otherwise, try to blast the channel, if there is one. */

	if ute.active < NOW_HAS_PROCESS then do;
	     if ute.channel ^= null () then do;
		call astty_$tty_force ((ute.channel), addr (P_message),
		     length (rtrim (P_message)), P_code);
		P_error_message = "";
		return;
	     end;
	     else do;
		P_code = error_table_$action_not_performed;
		P_error_message = "";
		return;
	     end;
	end;

	system_message_text_len = length (P_message);

	begin;
dcl  formatted_message char (system_message_text_len + 100);
dcl  warn_template char (100) aligned;

	     if P_need_formatting then do;
		call convert_status_code_ (as_error_table_$warn_msg, (""), warn_template);
		call ioa_$rsnnl (warn_template, formatted_message, (0),
		     date_time_$format ("date_time", clock (), "", ""), P_message);
	     end;
	     else
		formatted_message = P_message;

	     system_message_text_len = length (rtrim (formatted_message));
	     system_message_ptr = null;
	     on cleanup begin;
		if system_message_ptr ^= null then free warn_system_message in (based_area);
	     end;
	     allocate warn_system_message in (based_area) set (system_message_ptr);

	     unspec (warn_system_message) = "0"b;
	     warn_system_message.header.version = SYSTEM_MESSAGE_VERSION_1;
	     if P_bump_msg then do;
		warn_system_message.header.type = SYSTEM_MESSAGE_TYPE_AS_INACTIVITY;
		warn_system_message.header.type_version = SYSTEM_MESSAGE_AS_INACTIVITY_V1;
	     end;
	     else do;
		warn_system_message.header.type = SYSTEM_MESSAGE_TYPE_AS_WARN;
		warn_system_message.header.type_version = SYSTEM_MESSAGE_AS_WARN_V1;
	     end;
	     warn_system_message.caller = "";
	     warn_system_message.text_len = length (rtrim (formatted_message));
	     warn_system_message.text = formatted_message;
	end;					/* end begin block */

	call send_system_message_ (utep, system_message_ptr, P_code);
	if P_code ^= 0 then
	     do;
	     call ioa_$rsnnl ("Calling send_system_message_ on process_id ^w",
		P_error_message, (0), ute.proc_id);
	     return;
	end;

	free warn_system_message in (based_area);
	P_error_message = "";
	return;
     end BLAST_USER;
%page;
process_proc_term_request:
     procedure (P_action_string);

/**** This internal procedure is called by the unbump_user, disconnect_user,
      terminate_user, and detach_user entrypoints. */

dcl  P_action_string char (*) parameter;

dcl  event_message fixed bin (71) automatic;
dcl  event_message_str char (8) automatic;

	utep = P_utep;
	event_message_str = P_action_string;
	code = 0;
	if utep = null () then
	     code = error_table_$null_info_ptr;
	else do;
	     unspec (event_message) = unspec (event_message_str);
	     call hcs_$wakeup (as_data_$as_procid, ute.event, event_message,
		code);
	end;
	P_code = code;
	return;
     end process_proc_term_request;

/* format: off */
%page; %include absentee_user_table;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_wakeup_priorities;
%page; %include author_dcl;
%page; %include cdt;
%page; %include dialup_values;
%page; %include daemon_user_table;
%page; %include installation_parms;
%page; %include line_types;
%page; %include process_status_return;
%page; %include sc_stat_;
%page; %include sys_log_constants;
%page; %include system_message;
%page; %include uc_ls_handle;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   asu_: lock was N, ev call mask was M, ips mask was ZZZZZZ

   S:	as (severity1)

   T:	In response to an operator reset command.

   M:	N is the value of anstbl.lock_value, M is the value of event call masking.
   ZZZZZZ was the ips mask.
   This message verifies that the reset
   command was given, and what effect it had.

   A:	$ignore

   Message:
   asu_: CHANNEL is not in CDT and so cannot be attached

   S:	as (severity1)

   T:	$run

   M:	An attach command specified an unknown CHANNEL.
   No action was taken.

   A:	Enter a correct command.


   Message:
   asu_: CHANNEL has been deleted by a CDT installation and so cannot be
   attached.

   S:	as (severity1)

   T:	$run

   M:	An attach command specified a CHANNEL that has been deleted.
   No action was taken.

   A:	Enter a correct command.


   Message:
   asu_: CHANNEL cannot be attached because its service type is TYPE (N).

   S:	as (severity1)

   T:	$run

   M:	An attach command specified a CHANNEL whose service type
   does not permit it to be attached.
   No action was taken.

   A:	Enter a correct command.


   Message:
   asu_: CHANNEL was not configured at bootload time, and so cannot be
   attached.

   S:	as (severity1)

   T:	$run

   M:	An attach command specified a CHANNEL that cannot be used
   until the next bootload.  No action was taken.

   A:	Enter a correct command.


   Message:
   asu_: CHANNEL is in use by the message coordinator and cannot be attached.

   S:	as (severity1)

   T:	$run

   M:	An operator attach command specified a message coordinator CHANNEL.
   The channel was not attached.

   A:	Enter a correct command.


   Message:
   asu_: ERROR_MESSAGE.  ENTRY OPERATION error; will remove channel CHANNEL 
   DESC

   S:	as (severity1)

   T:	$run

   M:	A channel error has occurred on CHANNEL.  DESC is the comment field
   for the channel given in its Channel Definition Table (CDT) entry.
   ERROR_MESSAGE gives the text describing the error code returned by
   the operation in progress.
   OPERATION may be create_ev_chn, decl_event_call_chn, listen, set_term_type,
   tty_event or tty_index, dependent upon the operation in progress when
   the error occurred.
   ENTRY specifies the asu_ entrypoint that was running when the operation
   was performed on the channel.  It may be asu_listen or attach_channel.
   The channel will be removed from use.

   A:	It may be necessary to busy out the modem for the channel.


   Message:
   asu_: cdtep (CCC|ZZZ) not cdt (YYY|0)

   S:	as (severity0)

   T:	$run

   M:	$err
   Remove_cdte is trying to get rid of a channel which is no good.

   A:	$ignore


   Message:
   asu_: cdte CCC|XXX (CHANNEL) hung up

   S:	as (severity0)

   T:	$run

   M:	Remove_cdte is trying to get rid of a channel.
   The indicated CHANNEL is in the hung up state.

   A:	$ignore


   Message:
   asu_$remote_cdte: ERROR_MESSAGE. cdte CCC|XXX error from tty_state

   S:	as (severity0)

   T:	$run

   M:	Remove_cdte is trying to get rid of a channel.
   It cannot obtain the line state.

   A:	$ignore


   Message:
   asu_: cdte CCC|XXX (CHANNEL) state A in use B tra vec C

   S:	as (severity0)

   T:	$run

   M:	Remove_cdte is trying to get rid of a channel.
   It first logs the state of the line.

   A:	$ignore


   Message:
   asu_: (called by PROCEDURE) USER.PROJ CHN was already stopped and will be destroyed (stopstop wakeup was lost)

   S:	as (severity1)

   T:	In response to an operator command to bump or log out an interactive,
   absentee, or daemon user.

   M:	The process being bumped or logged out was found to be in the stopped state
   (partially logged out). A wakeup from ring zero indicating that the process
   was stopped and could be destroyed was apparently lost. Destruction of the
   process will be completed.

   A:	$inform

   Message:
   asu_: (called by PROCEDURE) USER PROJ CHN is not stopped (state = S) even
   though destroy flag = D;
   it might not be possible to destroy this process

   S:	as (severity1)

   T:	In response to an operator command to bump or log out an interactive,
   absentee, or daemon user.

   M:	The process being bumped or logged out was found to be partially
   logged out already, but not in the stopped state. An attempt will be made to
   destroy this process, but it might fail.

   A:	$inform

   Message:
   asu_: unmasking channel CHANNEL.

   S:	as (severity1)

   T:	In response to an operator command to attach a channel which has
   been masked by MCS.

   M:	A special order is issued to MCS to unmask CHANNEL, and the
   channel should then be available for regular use.

   A:	$ignore


   Message:
   asu_: MESSAGE. unable to unmask channel CHANNEL.

   S:	as (severity1)

   T:	In response to an operator command to attach a channel which had
   been masked by MCS.

   M:	The CHANNEL could not be unmasked.

   A:	$inform


   Message:
   asu_: ENTRYPOINT called with null UTE ptr.

   S:     as (severity0)

   T:	ENTRYPOINT may be suspend_process or setup_login_server_handle.  
   suspend_process was called by one of the process termination handlers
   to suspend an interactive process whose terminal disconnected, or to suspend
   an absentee process via the operator "abs suspend" command.  
   setup_login_server_handler was called in response to a validate, connect, 
   new_proc, or destroy request from a login server.

   M:     Programming error in the process termination handlers, or the
   login server support of the Answering Service.

   A:	$inform

 
   Message:
   asu_: CHANNEL in use as a multiplexer and cannot be attached.

   S:	$as0

   T:	When issuing an operator attach command for a channel.

   M:	CHANNEL is operating as a multiplexer, supporting one or more 
   channels.  It cannot be attached directly.  The attach operation fails.

   A:	$tryagain

   Message:
   asu_: CHANNEL in use for T & D and cannot be attached.

   S:	as (severity1)

   T:	$run

   M:	An operator attach command specified a CHANNEL being tested via
   Test and Diagnostic routines.   The channel was not attached.

   A:	$tryagain


   Message:
   asu_: CHANNEL has in_use = N, current state = S, {CDTE.state was OS}

   S:	$as1

   T:	When the operator attempts to attach the channel.

   M:	The Channel Definition Table (CDT) entry for CHANNEL is in an
   inconsistent state.  See dialup_values.incl.pl1 for a description of
   the in_use and state values.  The old state value OS is displayed only if 
   it differs from the current state.

   A:	$tryagain


   Message:
   asu_: CHANNEL is already attached; will try to listen to it again

   S:	$as1

   T:	When the operator attempts to attach a channel.

   M:	The CHANNEL was already attached by the Answering Service, but was
   not dialed up.  The Answering Service will attempt to listen for dialups
   on the channel.

   A: 	$tryagain

 
   Message:
   asu_: Unable to create event channel for new UTE LOCATION

   S:	$as2

   T:	$run

   M:	$err

   A:	$notify


   Message:
   asu_$release_ate: bad cdte.process (LOCATION) for CHANNEL

   S:	$as0

   T:	$run

   M:	$err  When asked to release a User Table Entry (UTE) for an 
   interactive process, the cdte.process pointer (LOCATION) did not point into 
   the answer table.  The UTE was not released.

   A:	$ignore


   Message:
   asu_:  attach channel not done on CHANNEL; service type = TYPE

   S:	$as0

   T:	When attaching channels to the Answering Service.

   M:	The CHANNEL was found in an inactive state (TYPE = INACTIVE), or
   was found to be a multiplexer channel (TYPE = MULTIPLEXER).  It was not
   attached.  $err

   A:	$ignore


   Message:
   asu_: listen not done on CHANNEL: IN_USE with state = STATE, 
   in_use = IN_USE, tra_vec = CURRENT_OPERATION

   S:	$as0

   T:	When the Answering Service tries to listen to the channel.

   M:	The Channel Definition Table (CDT) entry for CHANNEL is in an
   inconsistent state.  See dialup_values.incl.pl1 for a description of
   the state, in_use and tra_vec values.

   A:	$ignore


   Message:
   asu_:  listen not done on CHANNEL; current service type = TYPE

   S:	$as0

   T:	When the Answering Service tried to listen to the channel.

   M:	The CHANNEL was found in an inactive state (TYPE = INACTIVE), 
   was found to be a multiplexer channel (TYPE = MULTIPLEXER), was found to
   be in use by the message coordinator (TYPE = MC), or was found to
   be attached for Testing and Diagnostics (TYPE = TANDD_SERVICE).  The attempt
   to listen on the channel failed.  $err

   A:	$ignore


   Message:
   asu_: listen failed on CHANNEL:  state = N

   S:	$as0

   T:	When attempting to listen for dialups on the channel.

   M:	The Channel Definition Table (CDT) entry for CHANNEL has an
   invalid state value N.  Channel listening will not occur.

   A:	 $ignore


   Message:
   asu_: CHANNEL is a multiplexer and cannot be removed.

   S:	$as1

   T:	When the operator attempts to remove a channel.

   M:	CHANNEL is a multiplexer channel which handles data for one or
   more subchannels.  Such multiplexers are not attached by the Answering
   Service, and therefore cannot be removed.

   A:	  $tryagain


   Message: 
   asu_$bump_user: ERROR_MESSAGE. BLAST_MESSAGE. Sending blast message to
   PERSON.PROJECT on CHANNEL

   S:	$as0

   T:	$run

   M:	An error occurred while attempting to send an operator warning 
   message to PERSON.PROJECT on CHANNEL.  ERROR_MESSAGE is the text associated
   with the error which occurred.  BLAST_MESSAGE is the undelivered operator
   warning.

   A:	 $ignore

   Message:
   asu_$suspend_process: PERSON.PROJECT CHANNEL is already suspended

   S:	$as1

   T: 	asu_$suspend_process was called by one of the process termination 
   handlers to suspend an interactive process whose terminal disconnected, or 
   to suspend an absentee process via the operator "abs suspend" command.  

   M:	The process is already suspended.  The current request will be
   ignored.

   A:	$ignore


   Message:
   asu_$release_suspended_process: PERSON.PROJECT CHANNEL is not suspended

   S:	$as0

   T:	Called in response to an operator "abs release" command, or in
   response to a user reconnecting to an interactive process.

   M:	One of the process termination handlers is incorrectly calling
   to release a process which is not currently suspended.

   A:	$ignore


   Message:
   asu_: ERROR_MESSAGE.  Sending initial wakeup to PROCESS_ID (PERSON.PROJECT)

   S:	$as0

   T:	Called at process creation to start the process running.

   M: 	ERROR_MESSAGE is the text of an error which occurred attempting
   to send a wakeup to PERSON.PROJECT.  As a result of this error, process
   creation will fail.

   A:	$ignore


   Message:
   asu_: ERROR_MESSAGE. Retrieving the values of R-0ffset and R-Factor for
   PROCESS_ID (PERSON.PROJECT).

   S:	$as0

   T:	Called at process creation.

   M:	asu_$start_process called hphcs_$get_ipc_operands.  This call failed
   with an error whose text is shown as ERROR_MESSAGE.  As a result, the
   process will not be started.

   A:	$ignore


   END MESSAGE DOCUMENTATION */

     end asu_;




		    cpg_.pl1                        07/20/88  1307.0r w 07/19/88  1536.6      202815



/****^  ***********************************************************
        *                                                         *
        * 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: style4 */

cpg_: proc (p, code);

/* CPG_ - Create Process Group.

   This program is called by dialup_, absentee_user_manager, and
   daemon_user_manager_ to create user processes.

   It fills in the PIT (Process Initialization Table) with arguments and
   info for the new process, and passes its arguments to the hardcore in
   a structure called "create_info".

   The hardcore will allocate an APT entry and fill in the process ID,
   copy the template PIT into a real PIT for the process, and start the
   process up.

   See act_proc_ and initialize_process_ for how a process gets going.

   Spier 2/13/69
   modified by Dennis Capps 3/22/72
   modified by Richard G. Bratt 10/11/72 to pass the offset of pit.homedir to act_proc
   daemons, kst_size etc added 10/13/72 THVV
   Modified 740731 by PG for AIM stuff.
   Modified by T. Casey on 24 Oct 75 to unpack initproc and subsystem from ate.init_proc and copy them into create_info.
   Modified 760601 by PG to factor installation_parms.abs_cpu_limit into absentee job cpu limit.
   Modified 761229 by D. M. Wells to put more TTY info into PIT (line_type, etc.)
   Modified 770623 by Robert Coren to use names instead of numbers for terminal types.
   Modified August 1977 by FCSmith for separate TTY and connect time charging,
   .		and by T. Casey to give "p" tag to proxy absentee processes,
   .			and to set up an any other handler to catch faults occurring while creating process.
   Modified January 1978 by T. Casey to fix bugs in previous modification.
   Modified May 1978 by T. Casey to use ate.pdir_quota in determining process directory quota.
   Modified November 1978 by T. Casey for MR7.0 absentee control parameters.
   Modified July 1979 by T. Casey for MR8.0 to add set_pit_tty_info entry point for process preservation across hangups.
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures (UNCA).
   Modified March 1980 by Tom Casey to add metering.
   Modified May 1980 by R. McDonald to include page charging. (UNCA)
   Modified December 1980 by E. N. Kittlitz for foreground timax fix.
   Modified June 1981 by E. N. Kittlitz for UNCA rate structures, page charging.
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified April 1982, E. N. Kittlitz. New AS initialization
   Modified October 1982, E. N. Kittlitz. request_id in pit.
   Modified 84-04-02 BIM. Removed terminal_access_class from PIT, its
   available from tty_.
   Modified 84-09-12 BIM added login auth range, since HC is not interested
   in min.
   Modified 1984-10-05 BIM to remove communications.
   Modified 1984-12-27 Keith Loepere for pdir dir_quota.
   Modified 1985-01-18 by E. Swenson for new AS auditing.
   Modified 1985-04-19 by E. Swenson to not catch signal_io_ condition.
*/

/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  2) change(86-05-19,Gilcrease), approve(86-05-20,MCR7370),
     audit(86-06-25,Lippard), install(86-06-30,MR12.0-1082):
               Implement -truncate absout files. SCP6297.
  3) change(87-04-27,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  4) change(87-05-12,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
     Use constants in dialup_values.incl.pl1 to set instance tag.
  5) change(87-05-13,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
     Reorganized to set structure elements in their order of declaration, and
     to make code more readable and more similar to that in its login server
     counterpart, uc_create_process_.pl1.
  6) change(87-11-19,Parisek), approve(88-02-11,MCR7849),
     audit(88-03-01,Lippard), install(88-07-13,MR12.2-1047):
     Fill in pit.min_ring & pit.max_ring from the equivelent ute elements.
     SCP6367.
                                                   END HISTORY COMMENTS */

/* Parameters */

dcl  p ptr parameter;
dcl  code fixed bin (35) parameter;

/* External Entries */

dcl  as_access_audit_$process entry (ptr, fixed bin (17), char (*));
dcl  as_dump_ entry (char (*) aligned);
dcl  as_meter_$enter entry (fixed bin);
dcl  as_meter_$exit entry (fixed bin);
dcl  astty_$tty_order entry (ptr, char (*), ptr, fixed bin (35));
dcl  condition_ entry (char (*), entry);
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); /* Zero a segment */
dcl  hphcs_$create_proc entry (ptr, fixed bin (35));
dcl  hphcs_$set_pit_tty_info entry (bit (36) aligned, ptr, fixed bin (35));
dcl  ioa_$rsnnl entry options (variable);
dcl  pdir_volume_manager_$select_pdir_volume entry (ptr, fixed bin (35));
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);

/* External */

dcl  error_table_$action_not_performed ext fixed bin (35);

/* Internal Static */

dcl  DEFAULT_LOT_SIZE fixed bin int static init (512);	/* dft size of linkage offset table */
dcl  DEFAULT_KST_SIZE fixed bin int static init (0);	/* dft size of known segment table -- let hardcore set */
dcl  DEFAULT_CLS_SIZE fixed bin (35) int static init (65536); /* dft size of combined linkage */
dcl  static_label label int static;

/* Builtins */

dcl  (addr, binary, bit, clock, divide, fixed, length, null, rtrim, rel, 
      string, substr, unspec) builtin;

/* Automatic */

dcl  aip ptr;					/* arg_info pointer */
dcl  argp ptr;
dcl  ciptr ptr;					/* pointer to create_ info_area */
dcl  1 create_info_area like create_info aligned;		/* Scratch area for create info structure. */
dcl  dummy_code fixed bin (35);
dcl  i fixed bin;
dcl  length_of_pit fixed bin;				/* size of fixed part of pit */
dcl  length_of_arguments fixed bin;
dcl  number_of_arguments fixed bin;
dcl  1 old_terminal_info aligned,			/* for use by old info order */
       2 junk (3) fixed bin,
       2 old_type fixed bin;				/* only field we're interested in */
dcl  pdtep ptr;
dcl  pit_size fixed bin;				/* actual pit size */
dcl  timax fixed bin;				/* "ti_max" scheduler parameter determines priority */

/* Based */

dcl  lengths (number_of_arguments) based fixed bin aligned;
dcl  xstring char (length_of_arguments) based aligned;	/* For getting absentee arguments */

/* Constant */

%page;
/* Program */

/*
cpg_: proc (p, code); */
cpg_abs: entry (p, code);
cpg_daemon: entry (p, code);

	code = 0;					/* clear error code */
	ansp = as_data_$ansp;
	static_label = ucs_return;			/* place for signal handler to go */
	call condition_ ("any_other", ucs_);		/* catch faults, take asdump, return to caller */
	call as_meter_$enter (CPG_METER);
	utep = p;					/* copy argument */
	pdtep = ute.pdtep;
	pit_ptr = as_data_$pit_ptr;			/* copy static ptr to automatic */

	call hcs_$truncate_seg (pit_ptr, 0, code);	/* Clear pit */
	if code ^= 0 then do;			/* If cannot truncate, we will die. */
	     call sys_log_$error_log (SL_LOG_BEEP, code, "cpg_",
		"Cannot truncate pit_temp_");
	     goto exit;				/* Return with error. */
	end;

	pit.version = PIT_version_3;			/* put in version number of PIT */
	pit.process_type = ute.process_type;		/* put in type of process */
	pit.login_responder = substr (ute.init_proc, 1, ute.ip_len); /* Initial procedure. */
	pit.homedir = ute.home_dir;			/* set home directory */
	pit.project = ute.project;			/* project name */
	pit.account = " ";				/* unused */
	pit.n_processes = ute.n_processes;		/* set number of processes */
	pit.login_time = ute.login_time;		/* set time logged in */
	pit.proc_creation_time = clock ();		/* say when this process was made */
	pit.old_proc_cpu = ute.cpu_usage;		/* set total cputime for old processes */
	pit.user_weight = ute.user_weight;		/* 10 for normal user */
	pit.anonymous = ute.anonymous;		/* 1 if anonymous */
	pit.login_name = ute.person;			/* user's name  */
	pit.logout_pid = anstbl.as_procid;		/* processid of ans service */
	pit.logout_channel = ute.event;		/* name of logout event channel */
	pit.group = ute.group;			/* party group */
	pit.min_ring = ute.lowest_ring;		/* lowest ring */
	pit.max_ring = ute.highest_ring;		/* highest ring */
	string (pit.at) = string (ute.at);		/* copy user-control attributes */
	pit.whox = ute.whotabx;			/* user's own who table index */
	pit.outer_module = ute.outer_module;		/* Terminal outer module. */
	pit.dont_call_init_admin = ute.uflags.dont_call_init_admin;
	pit.terminal_access_class = ""b;		/* not used */
	pit.dollar_charge = user.dollar_charge;
	pit.dollar_limit = user.dollar_limit;
	pit.shift_limit (*) = user.shift_limit (*);
	pit.logins = user.logins;
	pit.crashes = user.crashes;
	pit.interactive (*) = user.interactive (*);
	pit.absentee (*) = user.absentee (*);
	pit.iod (*) = user.iod (*);
	pit.devices (*) = user.devices (*);
	pit.time_last_reset = user.time_last_reset;
	pit.absolute_limit = user.absolute_limit;	/* Non-monthly limit */
	pit.absolute_spent = user.absolute_spent;	/* Spending */
	pit.absolute_cutoff = user.absolute_cutoff;	/* Date to reset spending */
	pit.absolute_increm = user.absolute_increm;	/* Reset code. 0 = don't, 1 = daily, etc. */
	pit.rs_number = ute.rs_number;		/* make rate structure available to the user */
	pit.request_id = ute.request_id;		/* absentee request id or 0 */
	pit.authorization_range = ute.process_authorization_range;

          if ute.process_type = PT_INTERACTIVE then do;
	     ute.tag = TAG_INTERACTIVE;		/* tag for interactive processes is "a" */
	     timax = -1;				/* timax for interactive process is system standard */
	     pit.cant_bump_until = ute.cant_bump_until;
	     pit.abs_queue = -1;			/* not absentee. */
	     call set_tty_info();
set_tty_info: procedure;				
	         cdtep = ute.channel;			/* Interactive user has a channel, so */
	         pit.charge_type = cdte.charge_type;
	         pit.term_type_name = cdte.current_terminal_type;
	         pit.line_type = cdte.cur_line_type;
	         call astty_$tty_order (cdtep, "info",
		    addr (old_terminal_info), dummy_code);
	         pit.tty_type = old_terminal_info.old_type;
						/* this is here ONLY so that old user_info_$tty_type
						   entry will still work after new_proc */
	         pit.service_type = cdte.service_type;
	         pit.tty_answerback = cdte.tty_id_code;
	         pit.tty = cdte.name;			/* channel id for user's TTY */
	         pit.old_tty = "";
	         if length (rtrim (pit.tty)) <= length (pit.old_tty) then
		    pit.old_tty = rtrim (pit.tty);
	    end set_tty_info;
	end;

	else if ute.process_type = PT_DAEMON then do;	/* daemon process */
	     ute.tag = TAG_DAEMON;
	     timax = -1;
	     pit.cant_bump_until = ute.cant_bump_until;
	     pit.abs_queue = -1;			/* not absentee */
	     pit.charge_type = 0;
	     pit.term_type_name = "";
	     pit.line_type = LINE_MC;
	     pit.tty_type = 0;
	     pit.service_type = ANS_SERVICE;
	     pit.tty_answerback = rtrim (ute.tty_name);
	     pit.tty = ute.tty_name;			/* source name */
	     pit.old_tty = "";
	     if length (rtrim (pit.tty)) <= length (pit.old_tty) then
		pit.old_tty = rtrim (pit.tty);
	end;

	else do;					/* absentee, use abs_user_table entry */
	     if ute.abs_attributes.proxy then
		ute.tag = TAG_PROXY;		/* tag for proxy absentee processes is "p" */
	     else ute.tag = TAG_ABSENTEE;		/* tag for regular absentee processes is "m" */
	     if ute.queue > 0 then do;		/* in array range ? */
		timax = installation_parms.abs_timax (ute.queue);
		if timax < 1000000 then timax = -1;	/* insure value is nice */
	     end;
	     else timax = -1;			/* interactive default */
	     pit.cant_bump_until = 0;			/* Never happen for absentee */
	     pit.abs_queue = ute.queue;		/* might come in handy */
	     pit.charge_type = 0;
	     pit.term_type_name = "Absentee";
	     pit.line_type = LINE_UNKNOWN;
	     pit.tty_type = 0;
	     pit.service_type = ANS_SERVICE;
	     pit.tty_answerback = "";
	     pit.tty = ute.tty_name;
	     pit.old_tty = "";
	     if length (rtrim (pit.tty)) <= length (pit.old_tty) then
		pit.old_tty = rtrim (pit.tty);
	end;

	pit.standby = ute.standby_line;		/* 1 if standby. What means for abs and daemon? */
	pit.login_line = "";			/* not used */
	pit.input_seg = ute.input_seg;		/* abs pathname of input stream */
	pit.output_seg = ute.output_seg;		/* abs pathname of output */
	pit.max_cpu_time = ute.max_cpu_time;		/* cpu time limit */
	string (pit.abs_attributes) = "0"b;		/* copy ute abs_attributes bits */
	pit.restartable = ute.restartable;
	pit.user_deferred_until_time = ute.user_deferred_until_time;
	pit.proxy = ute.proxy;
	pit.set_bit_cnt = ute.set_bit_cnt;
	pit.truncate_absout = ute.truncate_absout;
	pit.restarted = ute.restarted;
	aip = addr (pit.start_arg_info);
	pit.arg_info_ptr = fixed (rel (aip));
	pit.old_proc_core = ute.mem_usage;		/* - and total memory usage */
	pit.old_proc_io_ops = 0;			/* change when charging for i/o begins */

						/* login arguments, if any */
	number_of_arguments = ute.arg_count;
	aip -> arg_info.arg_count = number_of_arguments;
	if number_of_arguments > 0 then do;
	     length_of_arguments = ute.ln_args;
	     aip -> arg_info.ln_args = length_of_arguments;
	     argp = ute.arg_lengths_ptr;
	     do i = 1 to number_of_arguments;		/* Set array of arg lengths */
		aip -> arg_info.arg_lengths (i) = argp -> lengths (i);
	     end;
	     if length_of_arguments > 0 then do;
		argp = ute.args_ptr;			/* The argument string itself */
		aip -> arg_info.args = argp -> xstring;
	     end;
	end;
	else length_of_arguments, aip -> arg_info.ln_args = 0;

	length_of_pit = binary (rel (addr (pit.start_arg_info)), 18);
						/* This works since pp has zero offset. */
	i = divide (length_of_arguments + 3, 4, 35, 0);
	pit_size = length_of_pit + number_of_arguments + i + 2;

	ciptr = addr (create_info_area);		/* Get ptr to create-info area */


/* Fill in create_info structure and call the hardcore to create process */

	code = 0;					/* clear errcode */

	if anstbl.processid_index > 262140 | anstbl.processid_index < 0 then
	     anstbl.processid_index = 0;		/* reset when out of range */
	anstbl.processid_index = anstbl.processid_index + 1; /* increment process id index */
						/* place in lower 18 bits of process id */
	ciptr -> create_info.processid.rel_apte = ""b;
	ciptr -> create_info.processid.unique_index = bit (fixed (anstbl.processid_index, 18), 18);
	ciptr -> create_info.version = version_of_create_info;
	ciptr -> create_info.term_channel = pit.logout_channel;
	ciptr -> create_info.term_processid = pit.logout_pid;
	ciptr -> create_info.words_of_pit = pit_size;	/* fill in length of PIT */

	if ute.pdir_quota > 0 then			/* if a nonzero pdir quota was given in the PDT and SAT */
	     ciptr -> create_info.record_quota = ute.pdir_quota; /* use it instead of the default in communications */
	else ute.pdir_quota,			/* be sure actual quota is in user table entry */
	     ciptr -> create_info.record_quota =
	     installation_parms.default_pdir_seg_quota;
	ciptr -> create_info.ppml = 0;		/* OBSOLETE */


	ciptr -> create_info.initial_ring = ute.initial_ring;
	ciptr -> create_info.highest_ring = ute.highest_ring;
	ciptr -> create_info.timax = timax;		/* set timax of process */
	ciptr -> create_info.account_ptr = null;	/* not used in this implementation */
	ciptr -> create_info.pit_ptr = pit_ptr;		/* pointer to template of pit */
	call ioa_$rsnnl ("^[anonymous^s^;^a^].^a.^a",
	     ciptr -> create_info.process_group_id, (0), ute.anonymous = 1,
	     ute.person, ute.project, ute.tag);
	ciptr -> create_info.user_processid = "";	/* not used in this implementation */
	ciptr -> create_info.account_id = pit.account;	/* fill in name of account */
	ciptr -> create_info.homedir = rel (addr (pit.homedir)); /* fill in offset of home dir in pit */
	ciptr -> create_info.lot_in_stack = "1"b;	/* Default is to put lot in stack */
	if ute.lot_size = 0 then ciptr -> create_info.lot_size = DEFAULT_LOT_SIZE;
	else if ute.lot_size > 0 then ciptr -> create_info.lot_size = ute.lot_size;
	else do;
	     ciptr -> create_info.lot_size = -(ute.lot_size);
	     ciptr -> create_info.lot_in_stack = "0"b;
	end;
	ciptr -> create_info.cls_in_stack = "0"b;	/* ... and to give cls its own segment */
	if ute.cls_size = 0 then ciptr -> create_info.cls_size = DEFAULT_CLS_SIZE;
	else if ute.cls_size > 0 then ciptr -> create_info.cls_size = ute.cls_size;
	else do;
	     ciptr -> create_info.cls_size = -(ute.cls_size);
	     ciptr -> create_info.cls_in_stack = "1"b;
	end;
	if ute.kst_size = 0 then ciptr -> create_info.kst_size = DEFAULT_KST_SIZE;
	else ciptr -> create_info.kst_size = ute.kst_size;
	ciptr -> create_info.dont_call_init_admin = ute.uflags.dont_call_init_admin;
	ciptr -> create_info.audit = ute.audit;
	ciptr -> create_info.process_authorization = ute.process_authorization;
	ciptr -> create_info.max_process_authorization = ute.process_authorization_range (2);
	ciptr -> create_info.work_class = ute.work_class; /* set work_class of process */
	ciptr -> create_info.subsystem = substr (ute.init_proc, ute.ip_len + 1, ute.ss_len);
	ciptr -> create_info.dir_quota = installation_parms.default_pdir_dir_quota;
	ute.pdir_dir_quota = ciptr -> create_info.dir_quota;


	call pdir_volume_manager_$select_pdir_volume (utep, code); /* choose volume for process directory */
	if code ^= 0 then				/* if problem, complain */
	     call sys_log_$error_log (SL_LOG_BEEP, code, "cpg_", "Assigning pdir volume for ^a",
		ciptr -> create_info.process_group_id);
	call hphcs_$create_proc (ciptr, code);		/* but try to create process anyway. */

/* The 36-bit process ID has upper 18 bits = process's APTE index, lower 18 bits unique.
   Thus we don't know the value until after the call to the harcore. */

	ute.proc_id = unspec(ciptr -> create_info.processid);

	if code = 0 then				/* Caller will log an error in process creation */
	     call as_access_audit_$process (utep, AS_AUDIT_PROCESS_CREATE,
		"");

exit:	call as_meter_$exit (CPG_METER);
	return;					/* done */

ucs_return:					/* come here via nonlocal goto from any_other handler */
	code = error_table_$action_not_performed;	/* tell caller we failed */
	return;					/* don't try the meter exit call - that may have caused the fault */
%page;
/* To tell existing process about its new tty channel. */

set_pit_tty_info: entry (p, code);

	code = 0;					/* clear error code */
	ansp = as_data_$ansp;
	static_label = ucs_return;			/* place for signal handler to go */
	call condition_ ("any_other", ucs_);		/* catch faults, take asdump, return to caller */
	call as_meter_$enter (CPG_METER);
	utep = p;					/* copy argument */
	pdtep = ute.pdtep;
	pit_ptr = as_data_$pit_ptr;			/* copy static ptr to automatic */
	length_of_pit = binary (rel (addr (pit.start_arg_info)), 18);
						/* This works since pp has zero offset. */

	call hcs_$truncate_seg (pit_ptr, 0, code);	/* Clear pit */
	if code ^= 0 then do;			/* If cannot truncate, we will die. */
	     call sys_log_$error_log (SL_LOG_BEEP, code, "cpg_", "Cannot truncate pit_temp_");
	     goto exit;				/* Return with error. */
	end;

	pit.outer_module = ute.outer_module;		/* Terminal outer module, so we can switch on reconnect */
	call set_tty_info();
	call hphcs_$set_pit_tty_info (ute.proc_id, pit_ptr, code);
	goto exit;				/* code is goto exited to caller */

%page;
ucs_: proc (mcptr, condname, coptr, infoptr, continue);

dcl  mcptr ptr parameter;
dcl  condname char (*) parameter;
dcl  coptr ptr parameter;
dcl  infoptr ptr parameter;
dcl  continue bit (1) parameter;

dcl  err_msg char (120) aligned;
dcl  non_local_exit bit (1);
dcl  as_check_condition_ entry (char (*), bit (1), bit (1));

	call as_check_condition_ (condname, continue, non_local_exit);
	if continue | non_local_exit then
	     return;

	call ioa_$rsnnl ("cpg_: Error: ^a attempting to create process for ^a.^a",
	     err_msg, (0),
	     condname, ute.person, ute.project);
	call sys_log_ (SL_LOG_BEEP, "^a", err_msg);
	call as_dump_ (err_msg);
	go to static_label;

     end ucs_;

/* format: off */
%page; %include answer_table;
%page; %include access_audit_bin_header; /* not used, but PL/I needs it */
%page; %include as_audit_structures;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_meter_numbers;
%page; %include author_dcl;
%page; %include cdt;
%page; %include create_info;
%page; %include dialup_values;
%page; %include installation_parms;
%page; %include line_types;
%page; %include pdt;

dcl  pdtp ptr automatic init (null);			/* pdt needs it  */
%page; %include pit;
%page; %include sc_stat_;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
/* format: on */
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   cpg_: ERROR_MESSAGE. Cannot truncate pit_temp_

   S:	as (severity2)

   T:	$run

   M:	The system was unable to clear its temporary segment while
   attempting to log in a user.
   The user will be unable to log in.

   A:	$contact

   Message:
   cpg_: ERROR_MESSAGE. Assigning pdir volume for USER

   S:	as (severity2)

   T:	$run

   M:	The system was unable to assign a logical volume on which
   to place the process directory of a user. The user might not be
   able to log in

   A:	$contact


   Message:
   cpg_: Error: CONDITION attempting to create process for NAME.PROJ

   S:	as (severity1)

   T:	$run

   M:	A supervisor error prevented creation of a process for the
   user NAME.PROJ. An Answering Service dump was performed and the
   user was logged out if possible.

   A:	$note
   If this message is printed at every login, it is probably wise
   to shut the system down and perform a bootload operation.


   END MESSAGE DOCUMENTATION */

     end cpg_;




		    device_acct_.pl1                07/13/88  1114.4r w 07/13/88  0938.0      138825



/****^  ***********************************************************
        *                                                         *
        * 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: style4 */
device_acct_: proc;

/* DEVICE_ACCT_ - program to account for process device usage  */
/* Written by VanVleck ---
   Modified 8/1/77 by Greenberg for $broom
   .            and by T. Casey to lock the pdt entry while modifying it
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures (UNCA).
   Modified June 1981 by E. N. Kittlitz for UNCA rate structures
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified May 1982, E. N. Kittlitz. New AS initialization.
*/


/****^  HISTORY COMMENTS:
  1) change(87-04-26,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  2) change(87-07-20,GDixon), approve(87-07-20,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Add operator message documentation.
      B) Use sys_log_constants.incl.pl1 for severity parameter to sys_log_.
                                                   END HISTORY COMMENTS */


dcl  (addr, clock, null) builtin;

dcl  cur_rs_ptr ptr;
dcl  devep ptr;					/* ptr to entry in device table */
dcl  pdtep ptr;					/* ptr to entry in pdt to be charged */
dcl  (dix, dix1) fixed bin;				/* subscript in device table */
dcl  cost float bin;				/* cost, for setup operation. */

dcl  unlock_pdte_sw bit (1) aligned;			/* to remember to unlock the pdt entry */
dcl  ec fixed bin (35);				/* errcode */

dcl  error_table_$lock_wait_time_exceeded ext fixed bin (35);
dcl  error_table_$locked_by_this_process ext fixed bin (35);
dcl  error_table_$out_of_sequence fixed bin (35) ext static;


dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  (sys_log_$error_log, sys_log_) entry options (variable);
dcl  (ipc_$mask_ev_calls, ipc_$unmask_ev_calls) 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  sub_err_ entry () options (variable);


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

on:  entry (a_dev, a_devname, a_utep);

dcl  a_dev fixed bin,				/* device type number */
     a_devname char (*),				/* device identifier */
     a_utep ptr;					/* ptr ot answer table entry */

	if a_dev = 0 then return;			/* see comments in devid.incl.pl1 */
	ansp = as_data_$ansp;
	anstbl.current_time = clock ();		/* use accurate clock value to start charging */
	if devtab.freep = 0 then do;			/* Allocate new device table entry. */
	     dix, devtab.current_size = devtab.current_size + 1;
	     devep = addr (devtab.entry (dix));		/* Grew new entry. */
	end;
	else do;					/* Re-use free entry from free chain. */
	     dix = devtab.freep;
	     devep = addr (devtab.entry (dix));
	     devtab.freep = process_chain_f;		/* Shorten free chain by one. LIFO */
	end;

	utep = a_utep;				/* Copy ptr to anstbl */
	ute.ndevices = ute.ndevices + 1;		/* Count devices. */
	deve.process_chain_f = ute.device_head;		/* Set up chain pointers in new entry. */
	deve.process_chain_b = 0;			/* Add new entry to front of chain. */
	ute.device_head = dix;			/* Make anstbl entry point at new entry. */
	if ute.device_tail = 0 then ute.device_tail = dix;
	if deve.process_chain_f ^= 0
	then addr (devtab.entry (deve.process_chain_f)) -> deve.process_chain_b = dix;

	deve.mount_time, deve.update_time = anstbl.current_time; /* Fill in device entry. */
	deve.devid = a_dev;
	deve.dev_name = a_devname;
	deve.pdtep = ute.pdtep;			/* set pointer to accounting data. */
	deve.state = 1;

	return;

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

setup: entry (a_dev, a_devname, a_utep);

dcl  devtab_ix fixed bin;				/* id of device that the setup is being done on */

	if a_dev = 0 then return;			/* see comments in devid.incl.pl1 */
	utep = a_utep;				/* Copy ptr to anstbl entry. */
	pdtep = ute.pdtep;				/* Extract ptr to pdt entry. */
	if lock_pdte () then do;			/* if we can't lock PDT entry, user gets out of being charged */
	     if a_dev = devtab_ix_tape then devtab_ix = devtab_ix_tape_mt; /* tape setup */
	     else if a_dev = devtab_ix_disk then devtab_ix = devtab_ix_disk_mt; /* io disk setup */
	     else devtab_ix = 0;			/* something else - should never happen */
	     if devtab_ix ^= 0 then do;		/* see comments in devid.incl.pl1 */
		devtab.usage_total (devtab_ix) = devtab.usage_total (devtab_ix) + 1;
		ansp = as_data_$ansp;
		cost = rs_ptrs (ute.rs_number) -> rate_structure.device_price (devtab_ix, anstbl.shift); /* Obtain price for setup operation. */
		user.devices (devtab_ix) = user.devices (devtab_ix) + cost;
		user.dollar_charge = user.dollar_charge + cost;
		user.absolute_spent = user.absolute_spent + cost;
		ute.session_cost = ute.session_cost + cost;
	     end;
	     call unlock_pdte;
	end;
	return;					/* All done. */

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

off: entry (a_dev, a_devname, a_utep);

	if a_dev = 0 then return;			/* see comments in devid.incl.pl1 */
	utep = a_utep;				/* Copy ptr to anstbl entry. */
	do dix = ute.device_head repeat (deve.process_chain_f) while (dix ^= 0); /* Scan chain */
	     devep = addr (devtab.entry (dix));
	     if deve.devid = a_dev & deve.dev_name = a_devname then do; /* got it */
	          ansp = as_data_$ansp;
		anstbl.current_time = clock ();	/* use accurate clock value to compute charges */
		call upcharge;
		call free_devtab_entry;
		return;
	     end;
	end;

	call sys_log_ (SL_LOG_SILENT,
	     "device_acct_$off: device ^d (^a, ^a) not in device table for ^a.^a",
	     a_dev, installation_parms.devtab (a_dev).device_id, a_devname, ute.person, ute.project);
	return;					/* device table probably messed up. nothing operator can do */


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

update: entry (a_utep);				/* called by act_ctl_ */

	utep = a_utep;				/* Copy ptr to anstbl entry. */
	ansp = as_data_$ansp;
	if ute.ndevices = 0 then return;		/* If no device chain, quit. */
	do dix = ute.device_head repeat (deve.process_chain_f) while (dix ^= 0);
	     devep = addr (devtab.entry (dix));
	     call upcharge;				/* $$$$$ */
	end;

	return;					/* All through. */

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

broom: entry (a_utep);				/* Charge and clean up all process entries. */

	utep = a_utep;
	if ute.ndevices = 0 then return;		/* avoid some paging */

	ansp = as_data_$ansp;
	anstbl.current_time = clock ();		/* use accurate clock value to compute charges */
	do dix = ute.device_head repeat dix1 while (dix ^= 0); /* dix1 is set by the free_devtab_entry internal procedure */
	     devep = addr (devtab.entry (dix));
	     call upcharge;				/* charge to this point */
	     call free_devtab_entry;
	end;
	return;

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

init: entry;					/* Called by as_init_ */

	if ^sc_stat_$Multics_typed | sc_stat_$Go_typed then do;
	     ec = error_table_$out_of_sequence;
	     go to init_sub_err;
	end;
          ansp = as_data_$ansp;
	call hcs_$make_seg (anstbl.sysdir, "device_table", "", 1010b, devtabp, ec);
	if devtabp = null then go to init_error;

	call hcs_$truncate_seg (devtabp, 0, ec);	/* zero the entire segment */
	if ec ^= 0 then go to init_error;
	devtab.current_size = 0;			/* Clean up device table. */
	devtab.freep = 0;				/* Make it all empty. */
	devtab.version = DEVTAB_version;		/* Set state. */
	devtab.n_devices = 0;

/* Look up the devtab entries for tape, tape_mt, disk, and disk_mt, and remember their indices in static variables */

	do devtab_ix_tape = 1 to installation_parms.ndevices /* look up tape in devtab */
	     while (installation_parms.devtab (devtab_ix_tape).device_id ^= dev_id (dev_tape));
	end;
	if devtab_ix_tape = installation_parms.ndevices + 1 then /* if not there, we won't charge for tape */
	     devtab_ix_tape = 0;

	do devtab_ix_tape_mt = 1 to installation_parms.ndevices /* look up tape_mt in devtab */
	     while (installation_parms.devtab (devtab_ix_tape_mt).device_id ^= dev_id (dev_tape_mt));
	end;
	if devtab_ix_tape_mt = installation_parms.ndevices + 1 then /* if not there, we won't charge for tape mounts */
	     devtab_ix_tape_mt = 0;

	do devtab_ix_disk = 1 to installation_parms.ndevices /* look up disk in devtab */
	     while (installation_parms.devtab (devtab_ix_disk).device_id ^= dev_id (dev_disk));
	end;
	if devtab_ix_disk = installation_parms.ndevices + 1 then /* if not there, we won't charge for disk */
	     devtab_ix_disk = 0;

	do devtab_ix_disk_mt = 1 to installation_parms.ndevices /* look up disk_mt in devtab */
	     while (installation_parms.devtab (devtab_ix_disk_mt).device_id ^= dev_id (dev_disk_mt));
	end;
	if devtab_ix_disk_mt = installation_parms.ndevices + 1 then /* if not there, we won't charge for disk mounts */
	     devtab_ix_disk_mt = 0;

	return;

init_error: call sys_log_$error_log (SL_LOG_BEEP, ec, "device_acct_$init",
	     "device_table");
init_sub_err: call sub_err_ (ec, "device_acct_$init", "s");

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

upcharge: proc;

dcl  delta fixed bin (71),				/* Delta time for usage. */
     cost float bin (63);				/* Charge for the time. */

	pdtep = deve.pdtep;				/* Get ptr to place where charges go. */
	if pdtep ^= ute.pdtep then do;		/* trap bug in maintenance of device table threads */
	     call sys_log_ (SL_LOG_BEEP,
	          "device_acct_: deve.pdtep (^p) not = ute.pdtep (^p) for ^a.^a",
		pdtep, ute.pdtep, ute.person, ute.project);
	     return;
	end;

	if lock_pdte () then do;			/* if we can't lock PDT entry, user gets out of being charged */
	     delta = anstbl.current_time - deve.update_time; /* Calculate time mounted. */
	     deve.update_time = anstbl.current_time;
	     devtab.usage_total (deve.devid) = devtab.usage_total (deve.devid) + delta;
	     cost = rs_ptrs (ute.rs_number) -> rate_structure.device_price (deve.devid, anstbl.shift) * delta / 36e8;
	     user.devices (deve.devid) = user.devices (deve.devid) + cost;
	     user.dollar_charge = user.dollar_charge + cost;
	     user.absolute_spent = user.absolute_spent + cost;
	     ute.session_cost = ute.session_cost + cost;
	     call unlock_pdte;
	end;
	return;

     end upcharge;

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

free_devtab_entry: proc;

	dix1 = deve.process_chain_f;			/* Save for broom loop. */

	if deve.process_chain_f = 0 then ute.device_tail = deve.process_chain_b;
	else addr (devtab.entry (deve.process_chain_f)) -> deve.process_chain_b = deve.process_chain_b;

	if deve.process_chain_b = 0 then ute.device_head = deve.process_chain_f;
	else addr (devtab.entry (deve.process_chain_b)) -> deve.process_chain_f = deve.process_chain_f;

	ute.ndevices = ute.ndevices - 1;		/* Decrement count in ATE */
	deve.state = 0;				/* free */
	deve.process_chain_f = devtab.freep;		/* thread to free list */
	deve.process_chain_b = -1;			/* watch for bugs */
	devtab.freep = dix;
	return;

     end free_devtab_entry;

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

lock_pdte: proc returns (bit (1) aligned);

	unlock_pdte_sw = "1"b;			/* remember to unlock it */
	call ipc_$mask_ev_calls ((0));		/* in case we have to wait on the lock */
	call set_lock_$lock (user.lock, 15, ec);	/* wait 15 seconds only */
	call ipc_$unmask_ev_calls ((0));		/* unmask before doing anything else, so we don't forget */

/* an undocumented feature of ipc_ masking is that it counts mask and unmask calls,
   and does the right thing - so we can unmask here without worrying about whether
   the caller of device_acct_ was already masked (which he sometines is).
   If he is, the process stays masked in spite of our unmasking.
*/

	if ec = error_table_$lock_wait_time_exceeded then do; /* if we could not lock it */
	     call sys_log_$error_log (SL_LOG_BEEP, ec, "device_acct_",
		"Attempting to lock PDT entry of ^a.^a",
		ute.person, ute.project);		/* tell the operator */
	     unlock_pdte_sw = ""b;			/* don't try to unlock it */
	     return (""b);				/* tell our caller what happened */
	end;

	else if ec = error_table_$locked_by_this_process then /* caller of device_acct_ already had it locked */
	     unlock_pdte_sw = ""b;			/* so remember to leave it that way */

	return ("1"b);				/* tell caller that it is locked */

     end lock_pdte;

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

unlock_pdte: proc;

	if unlock_pdte_sw then
	     call set_lock_$unlock (user.lock, (0));

	return;

     end unlock_pdte;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   device_acct_: deve.pdtep (PTR1) not = ute.pdtep (PTR2) for PERSON.PROJECT.

   A:	$as2

   T:	$run

   M:	The Project Definition Table entry pointer (PTR1) stored in the
   device table for PERSON.PROJECT differs from the PDT entry pointer stored
   in that user's User Table Entry (UTE).  $err

   A:	$notify


   Message:
   device_acct_: ERROR_MESSAGE.  Attempting to lock PDT entry of PERSON.PROJECT

   S:	$as2

   T:	$run

   M:	An attempt was made to lock the Project Definition Table (PDT) entry
   for PERSON.PROJECT to update device usage charges for the user.  Locking
   did not succeed within 15 seconds, so the charges were not updated.  If
   the attempt occurred during an accounting update, the charges will continue
   to accrue until the next update, at which time locking the PDT entry is
   again attempted.  If the original attempt occurred as part of a
   logout or new_proc operation, the device charges are lost.

   A:    $notify_sa


   Message:
   device_acct_$init: ERROR_MESSAGE.  device_table

   S: 	$as2

   T:	$init

   M:	An error occurred which initializing the device_table.  ERROR_MESSAGE
   is the text associated with the error code describing the error.  Device
   accounting is disabled, and system initialization fails.

   A:	$notify


   Message:
   device_acct_$off: device N (ACCT_TYPE_NAME, DEV_NAME) not in device table for PERSON.PROJECT

   S: 	$as0

   T:	$run

   M:	Device DEV_NAME, which has device accounting type number N associated
   with ACCT_TYPE_NAME devices, was not found in PERSON.PROJECT's device 
   table entries.  Probable cause is damage to the device table.

   A:	$notify_sa

   END MESSAGE DOCUMENTATION */

%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include devid;
%page; %include devtab;
%page; %include installation_parms;
%page; %include pdt;

dcl  pdtp ptr automatic init (null);			/* pdt needs it. */
%page; %include rate_structure;
%page; %include sc_stat_;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

     end device_acct_;




		    dialup_.pl1                     10/14/90  0953.4rew 10/14/90  0948.1     1601199



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * 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: style4 */

dialup_: proc (msg_ptr);

/**** This program, perhaps better called interactive_user_manager_ for
      consistency, handles all the communications channels connected
      to the answering service, processes all requests to login/logout/
      new_proc from interactive users, and performs other special actions
      for communications channels.  It is an event-call driven procedure
      for the IPC event channels associated with answering service channels
      and interactive user processes. */

/* PLEASE DO NOT ADD ANY RETURN STATEMENTS TO (THE EXTERNAL PROCEDURE PORTION
   OF) THIS PROGRAM.

   There should be only one return statement, at the label
   "return_immediately", which is located at the end of the process creation
   code, in the login section.

   A goto that label should be used instead of a return statement, so that all
   "logical returns" will be noted in the cross reference section of the
   listing, as references to that label.

   Note, however, that an immediate return is usually the wrong thing to do,
   as there is some cleaning up that almost always needs to be done before a
   return. The labels "exit" and "exit1" should be used in most cases; exit
   if both answer table unlocking and termination of metering is needed, and
   exit1 if just the latter is needed.

   If in doubt about the proper way to return, read the code for more details.

   *					T. Casey, 5/19/81

*/

/* Modification history:
   Originally coded by J. F. Ossanna Jan 1969
   Recoded by Michael J. Spier and Robert C. Daley February 1969
   Revised by Michael D. Schroeder, July
   Re-revised, converted to PL/1 and adapted to current System/User Control
   by Michael J. Spier, 25.12.1969, 'twixt X-mas and New-Year
   Modified for inactive bump & fixes THVV 9/70
   Modified for new ttydim, removing many waits, 12/70 THVV
   Modified for efficiency, ucs handler, login args THVV
   Modified for garbage for consoles without poff, THVV
   Modified for help function THVV 11/71
   Modified for dynamic changing of password, J.Phillipps 8/72
   Modified 740913 by PG for generated passwords
   Modified 750226 by PG for Multics Communication System (MCS)
   Modified 750328 by PG to use printer_on and printer_off order calls.
   Modified 750417 by PG for new_proc -authorization
   Modified 750502 by PG to fix bug which left logged-out users in whotab
   Modified 750715 by PG & THVV for MCS Phase II
   Modified 751110 by PG for bug fixes & ttydim/network dim changes
   Modified April 1976 by T. Casey to detect fatal process error loops and
   process initialization failures, and to ask for new password twice when
   -cpw is given, and by P. Green to fix misc. bugs.
   Modified 760601 by PG to fix pw mask handling and add resetreads.
   Modified 760720 by D. Wells to fix problem with dialing (to match
   ftp_dialup_) and, incidentally, to shorten blank padded messages
   Modified 760819 by Roy Planalp to use error msg passed up from lg_ctl_ and to fix detach bug.
   Modified Aug-Sept 1976 by T. Casey, M. Grady, and D. Wells, for as9.0 (v2CDT & FNP loading)
   Modified Feb., 1977, by D. M. Wells, to get more info about terminal into CDT
   Modified June 1977 by Robert Coren to use ttt_info_ for terminal information
   Modified September 1977 by T. Casey to fix hung process bugs.
   Modified October 1977 by T. Casey to send term signal to process being bumped, and wait for it to destroy itself.
   Modified January 1978 by T. Casey and R. Coren to fix bugs in previous two modifications.
   Modified May 1978 by T. Casey to use parameters in installation_parms in the fatal process error loop detector,
   .		and to try to destroy processes whose stopstop wakeups were apparently lost.
   Modified August 1978 by T. Casey to call astty_$get_chars to read answerback.
   Modified Fall 1978 by Larry Johnson for ring-0 demultiplexing.
   Modified November 1978 by T. Casey for MR7.0 new installation_parms.
   Modified April 1979 by T. Casey for MR7.0a to log lost initial wakeups, and fix bug in handling responses to trm_ signals.
   Modified July 1979 by T. Casey for MR8.0 to implement process preservation across hangups.
   Modified August 1979 by Larry Johnson for new pre-access commands echo, modes, and terminal_type.
   Modified November 1979 by T. Casey for MR8.0 to fix bugs in process preservation.
   Modified February 27, 1980 by T. Casey to fix a bug that was leaving the answer table locked.
   Modified March 1980 by Tom Casey to add metering.
   Modified December 1980 by E. N. Kittlitz for bugfixes, activity_unbump.
   Modified March 1981 by Robert Coren to add WAIT_FIN_TANDD_ATTACH and WAIT_DISCARD_WAKEUPS wait types.
   Modified April 1981 by Robert Coren to issue copy_meters order when assigning channel.
   Modified April 1981 by E. N. Kittlitz for various bugfixes.
   Modified May 1981 by T. Casey to fix bugs for MR9.0.
   Modified July 1981 by T. Casey for MR9.0 to wait for logout message to print before hanging up.
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified December 1981, E. N. Kittlitz.  don't hangup on lg_ctl_ error, destroy connect request or special session.
   Modified January 1982, E. N. Kittlitz.   bugfixes, login_parse_ changes, -immediate, etc.
   Modified January 1982, E. N. Kittlitz.  eliminate edited and red mode fiddling.
   Modified April 1982, E. N. Kittlitz. 'quit', etc. bugfixes
   Modified May 1982, E. N. Kittlitz. New AS initialization.
   Modified July 1982, E. N. Kittlitz. Support MCS channel (un)masking.
   Modified February 1983, E. N. Kittlitz. Password prompt does printer-off before typing NL.
   Modified May 1983, E. N. Kittlitz. set_required_access_class support.
   Modified August 1983, E. N. Kittlitz (courtesy S. Harris) to not use whotab (ute.whotabx) if it's 0.
   Modified 83-10-17, E. N. Kittlitz, handle fpe during new_proc connect.
   Modified December 1983, C. Marker.  Added terminal_id pre-access command.
   Modified 84-04-03 BIM to finish channel AIM implementation.
   Modified 84-10-03 by E. Swenson to incorporate Jim Falksen's changes
   for date_time_$format.
   Modified 84-10-28 by E. Swenson to prevent "Program error: null atep.."
   for login lines released by dial_ctl_ which have hung up.
   Modified 84-11-16 by E. Swenson for IPC event channel validation.
   Modified 85-01-15 by E. Swenson for new AS auditing.
   Modified 85-02-14 by E. Swenson fix multiple detach attempts.
   Modified 85-03-04 by E. Swenson for password length restrictions.
   Modified 85-03-26 by E. Swenson to disable realtime alarm upon logout
   and make the audit message upon hangup print out something nice.
   Modified 85-05-14 by E. Swenson to allow MC to give back terminals
   to answering service.
*/

/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  2) change(86-07-29,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to initialize tty_access_class structure and recompiled for
     change in the tty_access_class include file.
     (Actual change date was 85-07-29)
  3) change(86-08-03,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to move "Your authorization is..." message into this program,
     from act_ctl_, so that it is printed upon process reconnection as well as
     upon process creation.
     (Actual change date was 85-08-03)
  4) change(86-09-21,Beattie), approve(86-09-22,MCR7542),
     audit(86-10-31,Brunelle), install(86-11-12,MR12.0-1211):
     Remove references to the 963 and 029 preaccess commands and
     remove support for ARDS, 202_ETX, 2741 and 1050 in system
     interfaces.
  5) change(87-03-03,Brunelle), approve(87-07-14,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Added code to handle inacrcvd (inactivity msg received and processed)
     signal (signal type 12).  This reschedules the bump timer scheduled for
     the user to installation_parms.warning_time from the receipt of the
     signal by calling asu_$reschedule_bump_timer.
  6) change(87-03-12,Swenson), approve(87-07-14,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Moved release of devices (RCP devices, logical volumes, dialed
         terminals) into dpg_.
      B) Moved resetting of process termination handler to properly
         handle connect loop new_proc/destroy requests when process was
         previously connected to an MNA terminal.
  7) change(87-03-26,GDixon), approve(87-07-14,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Corrected unset variable problem in the connect loop's return to
         login code.
      B) Allow special-session login on dial-up lines during shutdown
         (ie, "word shutdown").
      C) Replace use of ute.logged_in flag with check for ute.active >=
         NOW_LOGGED_IN.  lg_ctl_ sets this.
      D) Upgraded for change to answer_table.incl.pl1 and
         user_table_entry.incl.pl1.
  8) change(87-05-11,GDixon), approve(87-07-14,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use user_table_mgr_$free to free UTE rather than attempting it in
         dialup_.pl1.
      B) Use constants in dialup_values.incl.pl1 to set ute.tag.
  9) change(87-05-15,GDixon), approve(87-07-14,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Set ute.line_type from cdte.cur_line_type.
      B) Use constants to set/test ute.preempted.
 10) change(87-05-18,Brunelle), approve(87-07-14,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Added code to check for inactivity for MCS user.
 11) change(87-05-20,GDixon), approve(87-07-14,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Set ute.terminal_type and ute.network_type whenever UTE is connected
         with a CDTE.
 12) change(87-07-14,Parisek), approve(87-07-14,MCR7644),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Added code to handle the user "disconnect" command properly.
 13) change(87-07-15,GDixon), approve(87-07-15,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Audit process terminations for fatal errors via calls to
         as_access_audit_$process.
 14) change(87-08-18,GDixon), approve(87-08-18,MCR7741),
     audit(87-08-19,Brunelle), install(87-08-20,MR12.1-1092):
      A) Provide operator message documentation for error reported when call
         to hcs_$wakeup fails upon reconnecting to an existing process.
      B) Correct error message reported for "connect N" when fewer than N
         disconnected processes exist. (phx14471)
 15) change(87-09-18,Parisek), approve(87-09-18,MCR7741),
     audit(87-09-18,Brunelle), install(87-09-21,MR12.1-1111):
     Send the proper term signal string to as_access_audit_$process for a
     "term" signal.
 16) change(87-11-03,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-03,Lippard), install(88-08-29,MR12.2-1093):
      A) SILENTLY ignore alarm___ signal for channel no longer dialed to a
         process. (phx19261, Answering_Service 479)
      B) Avoid referencing through unset utep when dialup_$re_introduce
         detects a channel error and tries to unlock the anstbl.
         (phx19383, Answering_Service 490)
 17) change(90-09-25,Schroth), approve(90-09-25,MCR8206), audit(90-10-05,Vu),
     install(90-10-14,MR12.4-1040):
     Honour the trusted_path_login flag if a user process does not signal
     the AS before calling hcs_$stop_process.
                                                   END HISTORY COMMENTS */

/* PARAMETERS */

dcl  msg_ptr ptr;					/* argument to event-call procedure */

/* BUILTINS */

dcl  (addr, addrel, baseno, bit, clock, divide, fixed, float, hbound,
     index, lbound, length, max, mod, null, rtrim, size, string,
     substr, translate, unspec) builtin;

/* ENTRIES */

dcl  act_ctl_$activity_unbump entry (ptr, fixed bin (35));
dcl  act_ctl_$close_account entry (ptr);
dcl  act_ctl_$cp entry (ptr);
dcl  act_ctl_$dp entry (ptr);				/* charge user */
dcl  act_ctl_$open_account entry (ptr);
dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
dcl  as_access_audit_$process entry (ptr, fixed bin (17), char (*));
dcl  as_access_audit_$process_connect_denied entry (ptr, ptr, char (*));
dcl  as_dump_ entry (char (*) aligned);			/* take a dump on error */
dcl  as_meter_$enter entry (fixed bin);
dcl  as_meter_$exit_values entry (fixed bin, fixed bin, fixed bin (71), fixed bin (71));
dcl  astty_$tty_abort entry (ptr, fixed bin, fixed bin (35)); /* astty_ is used for all terminal i/o */
dcl  astty_$tty_changemode entry (ptr, char (*), fixed bin (35));
dcl  astty_$tty_event entry (ptr, fixed bin (35));	/* cause device signals to come to caller */
dcl  astty_$tty_force entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  astty_$tty_get_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  astty_$tty_getmode entry (ptr, char (*), fixed bin (35));
dcl  astty_$tty_new_proc entry (ptr, bit (36) aligned, fixed bin (35)); /* force "uproc" to processid */
dcl  astty_$tty_order entry (ptr, char (*), ptr, fixed bin (35));
dcl  astty_$tty_read entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  astty_$tty_state entry (ptr, fixed bin (35));
dcl  asu_$asu_listen entry (ptr, fixed bin (35));		/* program makes event chan & orders listen */
dcl  asu_$asu_remove entry (ptr);			/* completely removes tty chn from system */
dcl  asu_$attach_ate entry (ptr, fixed bin (35));
dcl  asu_$check_for_stopped_process entry (ptr, char (*)) returns (bit (1) aligned);
dcl  asu_$find_process entry (bit (36) aligned, fixed bin, ptr);
dcl  asu_$release_ate entry (ptr, fixed bin (35));
dcl  asu_$release_suspended_process entry (ptr);
dcl  asu_$reschedule_bump_timer entry (ptr, fixed bin);
dcl  asu_$reset_access_class entry (pointer);
dcl  asu_$send_term_signal entry (ptr, fixed bin) returns (bit (1) aligned);
dcl  asu_$start_process entry (ptr);			/* used to start a process running */
dcl  asu_$suspend_process entry (ptr);
dcl  asu_$write_chn_message entry (ptr, fixed bin (35), char (8) aligned, fixed bin (35));
dcl  asu_$write_message entry (ptr, fixed bin (35), char (8) aligned, fixed bin (35));
dcl  check_password_ entry (char (*), char (*), fixed bin (35));
dcl  condition_ entry (char (*), entry);
dcl  connect_immediate bit (1) aligned init (""b);
dcl  convert_access_class_$to_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_authorization_$to_string_range entry ((2) bit (72) aligned, character (*), fixed binary (35));
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cpg_ entry (ptr, fixed bin (35));			/* utility to create process */
dcl  cpg_$set_pit_tty_info entry (ptr, fixed bin (35));	/* to tell existing process about its new tty channel */
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) varying);
dcl  device_acct_$off entry (fixed bin, char (*) aligned, ptr);
dcl  device_acct_$on entry (fixed bin, char (*) aligned, ptr);
dcl  dial_ctl_ entry (ptr, char (*), char (*), fixed bin (35));
dcl  dial_ctl_$continue_tandd_attach entry (ptr);
dcl  dial_ctl_$dial_term entry (ptr);
dcl  dial_ctl_$finish_dial_out entry (ptr);
dcl  dial_ctl_$finish_priv_attach entry (ptr);
dcl  dial_ctl_$finish_tandd_attach entry (ptr);
dcl  display_access_class_ entry (bit (72) aligned) returns (char (32) aligned);
dcl  dpg_ entry (ptr, char (*));			/* utility to destroy process */
dcl  dpg_$finish entry (ptr);				/* second half of process destruction */
dcl  generate_word_ entry (char (*), char (*), fixed bin, fixed bin);
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$wakeup entry (bit (*) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  ioa_$rs entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$unmask_ev_calls entry (fixed bin (35));
dcl  lg_ctl_$login entry (ptr, char (8), char (*) varying, fixed bin (35));
dcl  lg_ctl_$logout entry (ptr);
dcl  lg_ctl_$logout_channel entry (ptr, char (*));
dcl  lg_ctl_$logout_no_process entry (ptr, char (*));
dcl  lg_ctl_$validate entry (ptr, char (8), char (*) varying, fixed bin (35));
dcl  login_parse_ entry (ptr, fixed bin, char (*), fixed bin, fixed bin, fixed bin (35));
dcl  login_parse_$password entry (ptr, fixed bin, char (*), fixed bin, fixed bin, fixed bin (35));
dcl  match_star_name_ entry (char (*) aligned, char (*) aligned, fixed bin (35));
dcl  parse_login_line_ entry (ptr, fixed bin, ptr, char (*), char (*) aligned, fixed bin (35));
dcl  parse_login_line_$dial_line entry (ptr, fixed bin, ptr, char (*) aligned, fixed bin (35));
dcl  parse_login_line_$slave_line entry (ptr, fixed bin, ptr, char (*) aligned, fixed bin (35));
dcl  scramble_ entry (char (8)) returns (char (8));
dcl  send_mail_$access_class entry (char (*), char (*), ptr, bit (72) aligned, fixed bin (35));
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);		/* error reporting program */
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
dcl  ttt_info_$decode_answerback entry (char (*), fixed bin, char (*), char (*) aligned, fixed bin (35));
dcl  ttt_info_$default_term_type entry (fixed bin, fixed bin, char (*), fixed bin (35));
dcl  ttt_info_$dialup_flags entry (char (*), bit (1), bit (1), fixed bin (35));
dcl  ttt_info_$initial_string entry (char (*), char (*) varying, fixed bin (35));
dcl  ttt_info_$modes entry (char (*), char (*), fixed bin (35));
dcl  ttt_info_$preaccess_type entry (char (*), char (*), fixed bin (35));
dcl  user_table_mgr_$free entry (ptr);

/* EXTERNAL */

dcl  as_error_table_$aclass_banner_msg fixed bin (35) external;
dcl  as_error_table_$activity_unbump fixed bin (35) ext;
dcl  as_error_table_$ask_for_help fixed bin (35) ext;
dcl  as_error_table_$automatic_logout fixed bin (35) ext;
dcl  as_error_table_$bad_answerback fixed bin (35) external;
dcl  as_error_table_$bad_login_word_msg fixed bin (35) ext;
dcl  as_error_table_$bad_password_format fixed bin (35) ext;
dcl  as_error_table_$bad_terminal_id fixed bin (35) ext static;
dcl  as_error_table_$bump_cancelled fixed bin (35) ext;
dcl  as_error_table_$coming_up fixed bin (35) ext;
dcl  as_error_table_$detach fixed bin (35) ext;
dcl  as_error_table_$dialup_error fixed bin (35) ext;
dcl  as_error_table_$disc_hd_msg fixed bin (35) ext;
dcl  as_error_table_$ds_user_ignored fixed bin (35) ext static;
dcl  as_error_table_$ds_user_required fixed bin (35) ext static;
dcl  as_error_table_$fpe_caused_logout fixed bin (35) ext;
dcl  as_error_table_$generated_pw_err fixed bin (35) ext;
dcl  as_error_table_$generated_pw_msg fixed bin (35) external;
dcl  as_error_table_$give_connect_request fixed bin (35) ext;
dcl  as_error_table_$give_connect_request_no_disc fixed bin (35) ext;
dcl  as_error_table_$give_instructions fixed bin (35) ext;
dcl  as_error_table_$greeting_msg fixed bin (35) ext;
dcl  as_error_table_$hangup_msg fixed bin (35) ext;
dcl  as_error_table_$help_gpw_verify fixed bin (35) ext;
dcl  as_error_table_$help_new_pw fixed bin (35) ext;
dcl  as_error_table_$help_npw_verify fixed bin (35) ext;
dcl  as_error_table_$help_password fixed bin (35) ext;
dcl  as_error_table_$illegal_new_proc fixed bin (35) external static;
dcl  as_error_table_$illegal_signal fixed bin (35) ext;
dcl  as_error_table_$init_err fixed bin (35) ext;
dcl  as_error_table_$init_term_msg fixed bin (35) ext;
dcl  as_error_table_$list_disconnected_msg fixed bin (35) ext;
dcl  as_error_table_$login_args fixed bin (35) ext;
dcl  as_error_table_$login_auth_msg fixed bin (35) external static;
dcl  as_error_table_$logout1_msg fixed bin (35) ext;
dcl  as_error_table_$logout_disconnected_msg fixed bin (35) ext;
dcl  as_error_table_$logout_msg fixed bin (35) ext;
dcl  as_error_table_$must_give_proc_no fixed bin (35) ext;
dcl  as_error_table_$new_password_indistinct fixed bin (35) ext;
dcl  as_error_table_$new_pw_err fixed bin (35) ext;
dcl  as_error_table_$no_connect_aclass fixed bin (35) ext;
dcl  as_error_table_$no_disc_hd fixed bin (35) ext;
dcl  as_error_table_$no_disconnected_procs fixed bin (35) ext;
dcl  as_error_table_$no_init_proc fixed bin (35) ext;
dcl  as_error_table_$no_io_attach fixed bin (35) ext;
dcl  as_error_table_$no_logout_hold fixed bin (35) ext static;
dcl  as_error_table_$no_perm_disc fixed bin (35) ext static;
dcl  as_error_table_$no_signal fixed bin (35) ext;
dcl  as_error_table_$no_such_process_msg fixed bin (35) ext;
dcl  as_error_table_$now_logged_in fixed bin (35) ext;
dcl  as_error_table_$npw_again_msg fixed bin (35) ext;
dcl  as_error_table_$npw_msg fixed bin (35) ext;
dcl  as_error_table_$only_after_login_msg fixed bin (35) ext;
dcl  as_error_table_$proc_term_loop_msg fixed bin (35) ext;
dcl  as_error_table_$proc_term_msg fixed bin (35) ext;
dcl  as_error_table_$process_create_fail fixed bin (35) ext;
dcl  as_error_table_$pw_format_warning fixed bin (35) ext;
dcl  as_error_table_$pw_msg fixed bin (35) ext;
dcl  as_error_table_$rq_invalid_now_msg fixed bin (35) ext;
dcl  as_error_table_$shutdown fixed bin (35) ext;
dcl  as_error_table_$special_session fixed bin (35) ext;
dcl  as_error_table_$sys_full fixed bin (35) ext;
dcl  as_error_table_$term_by_operator fixed bin (35) external static;
dcl  as_error_table_$try_again fixed bin (35) ext;
dcl  as_error_table_$tty_no_room fixed bin (35) ext;
dcl  as_error_table_$unknown_arg_msg fixed bin (35) ext;
dcl  as_error_table_$unknown_request_msg fixed bin (35) ext;
dcl  as_error_table_$user_typed_quit fixed bin (35) ext;
dcl  error_table_$action_not_performed fixed bin (35) external static;
dcl  error_table_$badstar fixed bin (35) external static;
dcl  error_table_$messages_deferred fixed bin (35) ext static;
dcl  error_table_$messages_off fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$smallarg fixed bin (35) external static;
dcl  error_table_$undefined_order_request fixed bin (35) ext static;

/* CONSTANT */

dcl  ME char (7) int static init ("dialup_") options (constant);
dcl  NL char (1) aligned int static init ("
") options (constant);
dcl  RANDOM char (32) aligned int static options (constant) init ("etaiosqwertyuioplkjhgfdsazxcvbnm");
dcl  STOPstop char (8) aligned int static init ("STOPstop") options (constant);
dcl  STOPstop_msg fixed bin (71) based (addr (STOPstop));
dcl  USEC_PER_MINUTE fixed bin (35) int static options (constant) init (60000000);
dcl  termstop char (8) aligned int static init ("termstop") options (constant);
dcl  termstop_msg fixed bin (71) based (addr (termstop));
dcl  unlock_string char (8) int static options (constant) init ("unlock"); /* msg sent by unlock procedure */

/* STATIC */

dcl  bad_login_word_fmt char (100) aligned varying int static; /* .. */
dcl  dum_msg fixed binary (71) int static;		/* dummy ipc message */
dcl  garbg char (97) aligned int static;		/* password-hiding lines */
dcl  garbg_lth fixed bin int static;			/* length of message */
dcl  greeting_fmt char (100) aligned varying int static;	/* Message format frm as_error_table_ */
dcl  hangup_msg char (8) aligned int static;		/* we type it when hanging channel */
dcl  hangup_msg_lth fixed bin int static init (8);	/* length of message */
dcl  (init_term_fmt, proc_term_fmt, proc_term_loop_fmt) char (100) aligned varying int static;
dcl  (logout_fmt, logout_fmt1) char (100) aligned varying int static; /* .. */
dcl  loudsw bit (1) aligned init ("0"b) int static;	/* 1 if super-loud */
dcl  npw_again_msg char (28) aligned int static;		/* "New Password Again:" */
dcl  npw_again_msg_lth fixed bin int static;		/* length, set by dialup_init */
dcl  npw_msg char (20) aligned int static;		/* "new password" */
dcl  npw_msg_lth fixed bin int static;			/* length of message */
dcl  pw_msg char (16) aligned int static;		/* "password" */
dcl  pw_msg_lth fixed bin int static;			/* length of message */
dcl  static_fault_sw bit (1) aligned int static init (""b);
dcl  static_label label int static;			/* where to go on error */
dcl  wcr char (1) aligned int static;			/* carriage return */

/* AUTOMATIC */

dcl  added_info char (256) automatic;			/* additional info for log messages */
dcl  buff char (500) aligned;				/* i-o buffer for writes */
dcl  (code, ignore_code) fixed bin (35);		/* std status code */
dcl  date_time char (64) varying;			/* character date and time */
dcl  (dial_qual, dial_arg1) char (32);			/* for dial command */
dcl  error_mess char (100) aligned;			/* ... for convert_status_code */
dcl  error_message char (64);
dcl  format char (100) aligned;			/* ... for message formats */
dcl  funct char (8);				/* used at "hand (8)" - event message */
dcl  gpw_length fixed bin (17);			/* length of generated password */
dcl  (have_ate, have_cdte) bit (1) aligned init (""b);	/* "1"b if respective ptrs ^= null */
dcl  helphelp bit (1) aligned;			/* 1 if user has many fatal process errors and might need help */
dcl  (i, j, k, lgwd, userx) fixed bin;			/* temps */
dcl  jj fixed bin;					/* temp for password parse */
dcl  just_dialed_up bit (1);				/* Distinguaish between dialup and logout-hold */
dcl  logout_brief bit (1) aligned init (""b);
dcl  logout_hold bit (1) aligned init (""b);
dcl  modes_string char (512);				/* to allow room for "force,init," */
dcl  nc fixed bin;					/* char count for read */
dcl  new_modes char (100);				/* New mode string for terminal. */
dcl  new_pf fixed bin;
dcl  (old_cpu, new_cpu) fixed bin (71);
dcl  old_type char (32);				/* terminal type before calling parse_login_line_ */
dcl  (p, q, p1) ptr;				/* misc pointers */
dcl  password_pronunciation char (16);			/* 8 letters plus 8 hyphens */
dcl  (pdtp, pdtep) ptr init (null);
dcl  reason char (168) varying;			/* returned from lg_ctl_ */
dcl  say_hello bit (1);				/* TRUE at login unless logout -hold -brief */
dcl  shxx char (8) aligned;				/* error id */
dcl  simulated_wakeup_sw bit (1);			/* indicates simulated wakeup entry called */
dcl  (t1, t2) float bin;				/* temps for units message */
dcl  tab_string char (512) varying;
dcl  tanswb char (4);
dcl  tcode fixed bin (35);				/* errcode */
dcl  temp_atep ptr;					/* temporary answer table entry ptr */
dcl  temp_password char (8);				/* for checking change */
dcl  time fixed bin (71);
dcl  (tname, tsignal_type) char (64) varying;		/* for printing in trace and error messages */
dcl  tra_vec fixed bin;				/* copy of either cdte.tra_vec or ate.destroy_flag */
dcl  (tstate, ttv, tinuse) fixed bin;			/* copied from either cdte or ate */
dcl  type_to_set char (32);
dcl  ubits bit (72) aligned;				/* trick value for garbage generator */
dcl  user_login_word char (16);
dcl  user_password char (8);				/* password typed by user. scrambled. */

dcl  (wakeup_for_channel,				/* wakeup over a cdte event channel */
     wakeup_for_process,				/* wakeup over an ate event channel */
     wakeup_from_as,				/* wakeup came from answering service */
     wakeup_from_ring_zero,				/* wakeup came from ring zero */
     wakeup_from_user				/* wakeup came from user process */
     ) bit (1) aligned init (""b);			/* switches to keep track of where wakeup came from */

/* AUTOMATIC STRUCTURES */

dcl  1 set_type_info like set_term_type_info;
dcl  1 term_info like terminal_info;
dcl  1 write_status_info aligned,
       2 evchn fixed bin (71),
       2 output_pending bit (1);


/* DECLARATION OF BASED STRUCTURES */

dcl  1 based_tcode based (addr (tcode)) aligned,		/* This is used to make sure that */
       2 tcode_left_half bit (18) unal,			/* .. nobody is pulling a fast one */
       2 xxx bit (18) unal;				/* .. because convert_status_code tends to blow up */

dcl  1 bc based (addr (funct)) aligned,			/* overlay for terminate_proc signal */
       2 signal_type1 char (4),			/* "term" usually */
       2 code fixed bin;				/* system error code */

dcl  1 ev_msg based (msg_ptr) aligned,			/* interprocess event message */
       2 ev_channel fixed bin (71),			/* channel id */
       2 ev_message fixed bin (71),			/* what user wants to tell me */
       2 fromproc bit (36),				/* user's process id */
       2 origin,
         3 dev_signal bit (18) unal,			/* twx if hardcore */
         3 sender_ring bit (18) unal,			/* execution ring at call to singal */
       2 data_ptr ptr;				/* ptr to channel definition table entry (see asu_) */

dcl  1 new_proc_auth based (p1) aligned,		/* structure from new_proc -auth */
       2 np_signal char (2) unaligned,			/* "np" */
       2 authorization bit (54) unaligned;		/* the new authorization */

dcl  signal_type char (8) aligned based (p1);		/* overlay when user signal is 8 chars */

%page;
/* dialup_ is the procedure associated with the TTY event
   call channels and is called by the Wait Coordinator whenever an interrupt is
   signalled by one of the devices to which the answering-service is currently listening.
   dialup_ never calls the wait_coordinator  (directly nor indirectly), rather,
   it sets conditional-go to variable cdte.tra_vec to the label desired and returns to
   the wait coordinator. Upon re-invocation it transfers to that point.	 */

	simulated_wakeup_sw = "0"b;			/* called thru normal entry */
	go to dialup_begin;

simulated_wakeup: entry (msg_ptr);			/* entry used by multiplexer_mgr_ */

	simulated_wakeup_sw = "1"b;

dialup_begin:
	if msg_ptr = null then go to evil3;		/* Network programs could do this by mistake */
	if as_data_$ansp = null then go to evil2;	/* called before initialization */
	ansp = as_data_$ansp;

/* Initialize */

	p1 = addr (ev_msg.ev_message);		/* get ptr to 72-bit data item */
	static_label = exit;			/* setup non-local go */
	tcode = 0;				/* Clear temp code. */
	just_dialed_up = "0"b;			/* .. */
	call condition_ ("any_other", ucs);		/* Set up handler for any faults. */
						/* if any trouble */
	anstbl.current_time = clock ();		/* Read clock. */

	call as_meter_$enter (DIALUP_METER);

/* See where the wakeup came from, and over which kind of channel (ate or cdte) */

	if baseno (ev_msg.data_ptr) = baseno (scdtp) then do; /* cdte */
	     cdtep = ev_msg.data_ptr;			/* copy pointer to cdte */
	     wakeup_for_channel = "1"b;		/* remember which kind */
	     utep = cdte.process;			/* will be null if not valid */
	     tra_vec = cdte.tra_vec;			/* copy the tra_vec we want to use */
	     if cdte.in_use < NOW_DIALED		/* it should be, that is */
		& utep ^= null then			/* trap bugs */
		if tra_vec ^= WAIT_TANDD_HANGUP &	/* is it OK to have non-null atep? */
		     tra_vec ^= WAIT_FIN_TANDD_ATTACH &
		     tra_vec ^= WAIT_FIN_PRIV_ATTACH &
		     tra_vec ^= WAIT_DISCARD_WAKEUPS then do; /* out of luck */
		     call sys_log_ (SL_LOG_SILENT, "^a: non-null atep (^p) for cdte (^p,^a), tv=^d,inuse=^d",
			ME, utep, cdtep, cdte.name, cdte.tra_vec, cdte.in_use);
		     utep = null;
		     cdte.process = null;
		end;
	end;					/* end wakeup over channel */

	else if baseno (ev_msg.data_ptr) = baseno (ansp) then do; /* ate */
	     utep = ev_msg.data_ptr;			/* copy ptr to ate */
	     wakeup_for_process = "1"b;		/* remember which kind */
	     cdtep = ute.channel;			/* unpack ptr to cdte */
	     if cdtep ^= null then
		if cdte.process ^= utep then do;	/* trap bugs */
		     call sys_log_ (SL_LOG_SILENT, "^a: re-used cdte (^p,^a) by ate ^p, destroy_flag=^d",
			ME, cdtep, cdte.name, utep, ute.destroy_flag);
		     cdtep = null;
		     if ^ute.disconnected then do;
			call sys_log_ (SL_LOG_SILENT, "^a: turning on disconnected flag for ate ^p", ME, utep);
			ute.disconnected = "1"b;
			if ute.whotabx > 0 then
			     whotab.e (ute.whotabx).disconnected = "1"b;
		     end;
		end;				/* end cdte.process not equal atep */

	     if ute.disconnected & cdtep ^= null then do;
		call sys_log_ (SL_LOG_SILENT, "^a: turning off disconnected flag for ate ^p, cdte ^p,^a",
		     ME, utep, cdtep, cdte.name);
		ute.disconnected = ""b;
		if ute.whotabx > 0 then
		     whotab.e (ute.whotabx).disconnected = ""b;
	     end;

	     tra_vec = ute.destroy_flag;		/* copy the tra vec that we want to use */
	end;					/* end wakeup over ate channel */

	else goto evil1;				/* data pointer points to neither cdt nor answer table */

	if cdtep ^= null then have_cdte = "1"b;		/* checking switches is cheaper than testing ptrs for null */
	if utep ^= null then have_ate = "1"b;

	if loudsw then call trace;			/* now we have enough info to print trace message if wanted */

/* If wakeups on a channel are arriving at an excessive rate, hang up.
   This is to prevent Initializer process overload or tty buffer space exhaustion.
   An excessive rate is defined to be more than COUNT wakeups within INTERVAL,
   where COUNT and INTERVAL are installation parameters with long, untypeable names.
   Whenever we get through an interval with fewer than COUNT wakeups,
   we reset the counter and start a new interval. Thus, in the most extreme
   case, we could get 2 * COUNT -1 wakeups within INTERVAL + DELTA before we decide to hang up. */

	if wakeup_for_channel then
	     if cdte.recent_wakeup_time + installation_parms.chn_wakeup_error_loop_seconds * 1000000
		< anstbl.current_time then do;
		cdte.recent_wakeup_count = 1;
		cdte.recent_wakeup_time = anstbl.current_time;
	     end;
	     else do;
		cdte.recent_wakeup_count = cdte.recent_wakeup_count + 1;
		if cdte.recent_wakeup_count > installation_parms.chn_wakeup_error_loop_count then do;
		     cdte.recent_wakeup_time = 0;	/* reset the wakeup loop counters */
		     cdte.recent_wakeup_count = 0;	/* we'll start counting again at the next dialup */
		     call astty_$tty_abort (cdtep, 3, code); /* flush all input and output */
		     go to listen_again;		/* go hang up; we got too many wakeups too quickly */
		end;
	     end;

/* We know what kind of wakeup it is. Now see where it's from. */

	if ev_msg.origin.sender_ring = ""b then		/* from ring zero? */
	     wakeup_from_ring_zero = "1"b;

	else if ev_msg.fromproc = as_procid then	/* or from answering service */
	     wakeup_from_as = "1"b;

	else do;					/* either legal wakeup from user, or illegal wakeup
						   from someone playing games or experimenting */
	     if have_ate then			/* if we have an ate */
		if ute.active = NOW_HAS_PROCESS	/* with a live process */
		     & ute.proc_id = ev_msg.fromproc then /* and the wakeup is from that process */
		     wakeup_from_user = "1"b;		/* then it is legal */

	     if ^wakeup_from_user then goto evil;	/* illegal, so log it and exit */
	end;

/* Now, decide how to handle the wakeup. That's a function of all the above, plus the contents of the event message. */

	if wakeup_from_ring_zero then goto fan_out;	/* trust all wakeups from ring zero */

/**** Here, we special case some of the wakeups that the answering service
      sends to itself. */

	if wakeup_from_as then do;			/* I can signal myself. */

/**** The following code checks for a case where a dial server has released
      a channel whose normal service type is "login", and has attempted to
      notify us to print the banner message and await a login on the channel.
      However, between sending the "device" wakeup to us, the channel has
      hung up and we've started listening for a dialup on the channel.
      Although this may seem rather obscure, it has happened enough times
      (and the ensuing "Program error: null utep..." error message is
      annoying) that we check for the condition here, and ignore the wakeup. */

	     if signal_type = "device" & wakeup_for_channel then do;

		if cdte.in_use < NOW_DIALED &		/* is it hung up? */
		     cdte.tra_vec ^= WAIT_GREETING_MSG then
		     goto exit1;
	     end;

/* Here, we catch alarm___ wakeups for tty channels (but not for processes).
   In some cases, we don't just goto the handler specified by tra_vec.
   This is tricky, because any time a handler is changed to use an alarm
   timer, this code must be made aware of it. */

	     else if signal_type = "alarm___" & wakeup_for_channel then do; /* See if timeout. */

/* If the channel is not dialed up (or rather, it was not dialed up at the end of the last wakeup), then ignore the alarm. */

		if cdte.in_use < NOW_DIALED then go to fals0; /* if user is not home, ignore silently */

/* If there is a logged in user on this channel, assume it is a bump.
   NOTE: this might be a mistake: we set an alarm on the process, not the
   channel, for bumps. But this statement is probably harmless, so we leave
   it as it has been for years. */

		if cdte.in_use > NOW_DIALED then go to hand (8); /* if user is logged in, probably bump */

/* Here, we have to special case the alarm timer set when waiting for output to finish before hanging up a line. */

		if tra_vec = WAIT_BEFORE_HANGUP then
		     goto hand (WAIT_BEFORE_HANGUP);

/* Since in_use is equal to NOW_DIALED, assume the user is in the process of logging in, and the 3 minute timer
   went off. Before hanging up on him, do a read to see if he just typed something. If he did, give him a break, and
   go process it instead of hanging up. (Note that we no longer have a timer running.) */

		call astty_$tty_read (cdtep, addr (buff), nc, code); /* Dialed up, no process. */
		if code = 0 then			/* If ev call backlog, mayhave finished line */
		     if nc > 0 then do;		/* .. any chars there? */
			j = cdte.tra_vec;		/* verify the computed goto */
			if j < lbound (hand, 1) then go to eek;
			if j > hbound (hand, 1) then go to eek;
			go to timeout (j);		/* pick up where we left off */
						/* set up new timer? */
		     end;
		go to listen_again;			/* User didn't login in 3 minutes */
	     end;

/* It was not an alarm for a channel. It might be an alarm for a process,
   or some other kind of wakeup for either a process or a channel. If tra_vec
   is greater than WAIT_LOGOUT_SIG, we are in the middle of a login,
   waiting for either a login command or a password. In that situation,
   we ignore a termstop (for unknown historical reasons), and we assume
   any other wakeup is an operator bump command, so we change the tra_vec
   to go to the process destructon code.  We do no do this, however, if
   the wakeup is a "device" wakeup for a channel.  These special wakeups
   are sent by the answering service to get dialup_ to notice a channel
   and act on in. */

	     if ^(signal_type = "device" & wakeup_for_channel) then
		if tra_vec < WAIT_LOGOUT_SIG then
		     if signal_type = "termstop" then
			goto fals0;		/* Ignore if extra */
		     else tra_vec = WAIT_LOGOUT_SIG;
	end;					/* end wakeup from answering service */

/* It appears that it is ok to fall thru to fan_out, now */

fan_out:						/* go where tra_vec says to go */

/* Check validity of wakeup/tra_vec combination, before going anywhere */

/**** It is always ok to receive an operator "detach" command.  */

	if wakeup_from_as & signal_type = "detach" &
	     tra_vec = WAIT_LOGOUT_SIG then ;

	else if tra_vec = WAIT_LOGOUT_SIG		/* if tra_vec says to expect a process termination signal */
	     | tra_vec = WAIT_LOGOUT
	     | tra_vec = WAIT_LOGOUT_HOLD
	     | tra_vec = WAIT_NEW_PROC then do;		/* then there must be a process */
	     if ^have_ate then do;			/* if there's no ate, there can't be a process */
		call sys_log_ (SL_LOG_BEEP, "^a: Program error: null atep with per-process tra_vec value", ME);
		goto fals;			/* fals prints all the relevant variables */
	     end;
	end;					/* end tra_vec says to expect process termination signal */

	else					/* but if tra_vec is anything else, wakeup must be for cdte */
	     if wakeup_for_process then do;		/* if wakeup isn't for a channel, complain and exit */
	     if tra_vec = WAIT_DETACH
		| tra_vec = WAIT_REMOVE
		| tra_vec = WAIT_DELETE_CHANNEL then do;/* these can be for a process or a channel */
		if ^have_cdte then do;		/* but we must have a channel */
		     call sys_log_ (SL_LOG_BEEP, "^a: Program error: null cdtep with per-channel tra_vec value", ME);
		     goto fals;			/* fals prints all the relevant variables */
		end;
	     end;
	     else do;				/* rest of tra_vec values are restricted to per-channel wakeups */
		call sys_log_ (SL_LOG_BEEP, "^a: Program error: per-process wakeup with per-channel-only tra_vec value", ME);
		goto fals;
	     end;
	end;

	if wakeup_for_process then			/* trap bug */
	     if ute.active = NOW_FREE then		/* spurious wakeup for free ate */
		goto fals0;			/* go log and ignore it */

	if tra_vec < lbound (hand, 1)			/* Subscript range check. */
	     | tra_vec > hbound (hand, 1) then do;	/* if this fails, cdt or anstbl is garbaged. */
eek:	     if simulated_wakeup_sw then
		if tra_vec = 0 then goto exit1;	/* multiplexer_mgr_ called too soon */
	     call sys_log_ (SL_LOG_BEEP, "^a: ^[CDT^;answer table^] damaged at ^[^p^s^;^s^p^], tra_vec=^d",
		ME, wakeup_for_channel, wakeup_for_channel, cdtep, utep, tra_vec);

	     goto exit1;				/* clean up metering and exit */
	end;

	go to hand (tra_vec);			/* this is fast in v2pl1 */

/* Come here when a terminal channel dials up. */

hand (1): cdte.n_dialups = cdte.n_dialups + 1;		/* count number of times TTY has been dialed up */
	cdte.dialup_time = anstbl.current_time;		/* Note time of dialup. */

	call astty_$tty_state (cdtep, code);		/* make sure tty now dialed up. */
	if code ^= 0 then go to chn_error;		/* go get rid of channel if any error */

	if cdte.state < TTY_DIALED then go to listen_again; /* Transient wakeup. Phone is hung now, give up. */

	cdte.in_use = NOW_DIALED;			/* record that channel is dialed up */

	call update_term_info;

	call initialize_current_access_class;		/* is it single class? can we read an access class from hcs_? */

	cdte.tty_id_code = "none";			/* but for other channels, we read answerback below */

	if cdte.initial_terminal_type ^= ""		/* if type specified in CMF */
	then type_to_set = cdte.initial_terminal_type;
	else do;					/* else figure it out from line-type/baud-rate */
	     call ttt_info_$default_term_type (term_info.line_type, term_info.baud_rate, type_to_set, code);
	     if code ^= 0 then go to ttt_error;

	     if type_to_set = ""
	     then do;
		call sys_log_$error_log (SL_LOG_BEEP, 0, ME,
		     "Unable to determine initial terminal type for channel ^a",
		     cdte.name);
		go to ttt_error;
	     end;
	end;

	call change_type (type_to_set, "0"b, "0"b, code); /* whatever it's supposed to be, set it */
	if code ^= 0 then go to chn_error;

	call astty_$tty_abort (cdtep, 1, code);		/* flush any trash */
	if code ^= 0 then go to chn_error;

	if ^cdte.flags.dont_read_answerback		/* they might have said not to try */
	then do;
	     call astty_$tty_order (cdtep, "wru", null, code); /* Initiate answerback read and send us a wakeup */
						/* whether answerback exists or not */
	     if code ^= 0 then go to chn_error;		/* Now that MCS is in, expect no error */

	     cdte.tra_vec = WAIT_ANSWERBACK;		/* and wait for it */
	     go to exit1;				/* Wait for tty dim Wakeup */

hand (2):						/* WAIT_ANSWERBACK - Got answerback wakeup */
	     call astty_$tty_get_chars (cdtep, addr (buff), nc, code); /* read it & see if it's there */
						/* use get_chars 'cause some answerbacks don't end in a newline */
	     if code ^= 0 then go to chn_error;
	     if nc > 0 then do;			/* if there is an answerback, process it */
timeout (2):					/* come here if we timeout & find answerback there */
		call ttt_info_$decode_answerback (substr (buff, 1, nc), (cdte.cur_line_type), type_to_set,
		     cdte.tty_id_code, code);
		if code ^= 0 then do;
		     type_to_set = "";
		     cdte.tty_id_code = ""; ;
		end;

		if cdte.tty_id_code = ""
		then cdte.tty_id_code = "none";
		if type_to_set ^= "" &
		     type_to_set ^= cdte.current_terminal_type /* answerback says different terminal type */
		then do;
		     call change_type (type_to_set, "0"b, "0"b, code);
		     if code ^= 0 then go to chn_user_error;
		end;

		call astty_$tty_abort (cdtep, 1, code); /* flush junk from multi-line answerbacks */
		if code ^= 0 then go to chn_error;
	     end;
	end;

	call set_tabs_and_modes (code);		/* Get terminal normalized. */
	if code ^= 0 then go to chn_user_error;

/* Here is the login sequence. First, tell him it's Multics, etc. */

	say_hello = "1"b;				/* Always be polite to strangers. */
	just_dialed_up = "1"b;			/* .. */

/* Come here after a logout -hold or after a dialed terminal's master process terminates */

login:
	cdte.count = 1;				/* we count login tries and hang up if there are too many */
	call turn_printer_on (code);			/* Make sure user can see this */
	if code ^= 0 then go to chn_error;

	call astty_$tty_force (cdtep, addr (NL), length (NL), code);
	if code ^= 0 then go to chn_error;		/* send NL */

	if cdte.flags.ck_answerback then do;		/* If we should check answerback */
	     call match_star_name_ (cdte.tty_id_code, cdte.answerback, code);
	     if code ^= 0
	     then if code ^= error_table_$badstar	/* ignore problems with starname */
		then do;
		     call sys_log_ (SL_LOG_BEEP, "^a: wrong answerback on ^a (^a); expected ""^a"", got ""^a"".",
			ME, cdte.name, cdte.comment, cdte.answerback, cdte.tty_id_code);
						/* now tell user */
		     call asu_$write_chn_message (cdtep, as_error_table_$bad_answerback, shxx, code);
		     if code ^= 0 then go to chn_error; /* handle random errors */
		     go to listen_again;		/* hangup the terminal */
		end;
	end;

	if say_hello then call hello (0);		/* Greeting message. */
	if code ^= 0 then go to chn_error;		/* too bad */

	if cdte.flags.hardwired
	then time = 1e20b;				/* don't bug hardwired channels */
	else time = installation_parms.login_time;	/* ask for wakeup if user asleep */
	call timer_manager_$alarm_wakeup (time, "11"b, cdte.event);

	if just_dialed_up then			/* Is this time for initial command? */
	     if cdte.flags.execute_initial_command then do; /* .. is there one? */
		buff = cdte.initial_command;		/* Yes. Do it. */
		nc = length (cdte.initial_command);
		go to timeout (3);			/* Skip the first read call. */
	     end;
%page;

/* Come here after saying "Login incorrect. Please try again or type help for instructions." */

read_login_line:
	cdte.tra_vec = WAIT_LOGIN_LINE;		/* Set up transfer vector. */

hand (3): call astty_$tty_read (cdtep, addr (buff), nc, code); /* read the login line */
	if code ^= 0 then go to chn_error;
	if nc <= 0 then go to exit1;			/* is line in yet? */

/* At this point we have a login line. Parse it. */

timeout (3):					/* come here if line read during timeout */
	call login_parse_ (addr (buff), nc, user_login_word, k, jj, tcode); /* Get login-word from line. */
	if tcode = error_table_$noarg then go to read_login_line; /* nothing but white space */
	if tcode ^= 0 then go to try_again_code;

	do lgwd = lbound (as_data_login_words.words, 1) to
	     hbound (as_data_login_words.words, 1)
	     while (user_login_word ^= as_data_login_words.words (lgwd));
	end;

	if anstbl.session ^= "normal  " then		/* Check for Special Session */
	     if lgwd <= 6 then			/* (normal login) */
		go to reject_login_word;		/* ... not allowed during Special Session */
	     else if lgwd <= hbound (as_data_login_words.words, 1) then ; /* (preaccess command) */
	     else if user_login_word = anstbl.login_word	/* (special session login) */
		& (anstbl.session ^= "shutdown"	/* and not shutdown */
		| anstbl.login_word ^= "shutdown") then /* or shutting down but emergency logins are allowed */
		lgwd = 1;				/* convert to "login" */
	     else go to reject_login_word;		/* Don't let user try to guess magic word */
	else if lgwd > hbound (as_data_login_words.words, 1) then /* Normal Session. Unknown word */
	     go to bad_login_word;			/* Tell user. Give 'em another chance */

/* Note that anonymous users cannot login during special session. */

	if lgwd <= 6 then do;			/* Command is of login type. Parse args. */
	     call grab_ute;				/* get a user_table_entry */
	     call ipc_$decl_ev_call_chn (ute.event, dialup_, utep, INT_LOGIN_PRIO, code);
	     if code ^= 0 then do;
		call sys_log_$error_log (SL_LOG_BEEP, code, ME,
		     "Unable to declare handler for ev chn ^24.3b for ate ^p for ^a",
		     ute.event, utep, cdte.name);
		call asu_$write_chn_message (cdtep, as_error_table_$dialup_error, shxx, code);
		if code ^= 0 then goto chn_error;
		goto listen_again;
	     end;
	     ute.login_code = substr (user_login_word, 1, 8);
	     if nc <= jj then do;			/* Is line currently empty? */
read_login_args:	cdte.tra_vec = WAIT_LOGIN_ARGS;	/* Set up wait point */
		ute.count = lgwd;			/* Remember what we're up to. */
		call asu_$write_chn_message (cdtep, as_error_table_$login_args, shxx, code);
		if code ^= 0 then go to chn_error;

hand (4):		call astty_$tty_read (cdtep, addr (buff), nc, code); /* Read rest of login command */
		if code ^= 0 then go to chn_error;
		if nc <= 0 then go to exit1;		/* Wait for him to type */
timeout (4):	jj = 1;				/* Now parse the rest of the line. */
		lgwd = ute.count;			/* .. and then execute the command. */
	     end;
	     old_type = cdte.current_terminal_type;	/* save this in case parse_login_line_ changes it */
	     ute.tty_id_code = cdte.tty_id_code;	/* as_who will want this */
	     ute.line_type = cdte.cur_line_type;
	     ute.network_connection_type = MCS_NETWORK_TYPE;

	     call parse_login_line_ (addr (substr (buff, jj, 1)), nc - jj + 1, utep, new_modes, error_mess, code);
	     if code = error_table_$noarg then go to read_login_args; /* If user gave no args, ask for them. */
	     if code ^= 0 then do;			/* If any error, fuss. */
		cdte.current_terminal_type = old_type;	/* because we won't do any changing this time */
bad_login_slave_dial_request:
		call ioa_$rs (convert_message (code), buff, i, error_mess); /* Object to bad argument. */
		call astty_$tty_force (cdtep, addr (buff), i, code);
		if code ^= 0 then go to chn_error;
		go to try_again;
	     end;

	     if ute.ur_at.brief then			/* if user SPECIFIED -lg or -bf */
		logout_brief = ute.at.brief;
	     connect_immediate = cdte.immediate_arg;

	     if cdte.current_terminal_type ^= old_type	/* user changed his terminal type */
	     then do;
		call change_type (cdte.current_terminal_type, "1"b, "0"b, code);
		if code ^= 0 then go to chn_user_error;
	     end;
	     else if ute.uflags.send_initial_string	/* he said -ttp but specified same type */
	     then do;
		call set_tabs_and_modes_gently (code);
		if code ^= 0 then go to chn_user_error;
	     end;
	     ute.terminal_type = cdte.current_terminal_type;

	     if new_modes ^= "" then do;		/* Did user specify "-modes" ? */
		call astty_$tty_changemode (cdtep, (new_modes), code);
		if code = -1 then go to chn_error;	/* Check if user hung up. */
		if code ^= 0 then do;		/* If can't make modes, dump login attempt. */
		     j = lgwd + mod (lgwd, 2);	/* get long name of login command */
		     call ioa_$rs ("^a: ^a ^a", buff, i, as_data_login_words.words (j), convert_message (code), new_modes);
		     call astty_$tty_force (cdtep, addr (buff), i, code);
		     if code ^= 0 then go to chn_error;
		     go to try_again;
		end;
	     end;
	     call astty_$tty_order (cdtep, "store_id", addr (cdte.tty_id_code), ignore_code); /* Store the terminal_id */
	end;

	go to login_handler (lgwd);			/* Dispatch on login command. */
%page;

bad_login_word:
	call ioa_$rs (bad_login_word_fmt, buff, i, user_login_word); /* Not legal login word. Complain. */
	call astty_$tty_force (cdtep, addr (buff), i, code); /* .. */
	if code ^= 0 then go to chn_error;
	call astty_$tty_abort (cdtep, 1, code);		/* flush type-ahead */
	if code ^= 0 then go to chn_error;
	go to try_again;

user_typed_quit:
	call asu_$write_chn_message (cdtep, as_error_table_$user_typed_quit, shxx, code);
	if code ^= 0 then go to chn_error;
	go to try_again;

try_again_code:
	call print_ascii_msg (code, "");

try_again:					/* transfer point for repeat login attempts */
	call free_ute;				/* If a ute was allocated, free it */
	cdte.count = cdte.count + 1;			/* Count errors. */
	if cdte.count > installation_parms.login_tries then go to listen_again;
						/* Has user tried us too many times? */
	call asu_$write_chn_message (cdtep, as_error_table_$try_again, shxx, code);
	if code ^= 0 then go to chn_error;
	go to read_login_line;			/* Read another line. */

reject_login_word:
	if anstbl.session = "shutdown" then		/* Is the system coming down? */
	     tcode = as_error_table_$shutdown;		/* Yes, tell user */
	else if anstbl.session = "init    " then	/* Not up yet. */
	     tcode = as_error_table_$coming_up;		/* Tell him we will be up shortly. */
	else tcode = as_error_table_$special_session;	/* Go way kid you bother me */
	call asu_$write_chn_message (cdtep, tcode, shxx, code); /* .. */
	if code ^= 0 then go to chn_error;
	if tcode = as_error_table_$special_session then go to try_again; /* Be a little loose */
	else go to listen_again;			/* Hang up on the fella. */
%page;

login_handler (5):					/* "ep" */
login_handler (6):					/* "enterp" */
	if cdte.disconnected_proc_command ^= 0 then do;	/* -connect specified */
no_anon_connect_loop:
	     call asu_$write_chn_message (cdtep, as_error_table_$no_disconnected_procs, shxx, code);
	     if code ^= 0 then go to chn_error;
	     go to try_again;
	end;

	ute.anonymous = 1;				/* Set anonymous-login flag. */
	ute.login_flags.cpw = "0"b;			/* Can't change password. */
	ute.login_flags.generate_pw = "0"b;		/* ... */

login_handler (1):					/* "l" */
login_handler (2):					/* "login" */
read_password:					/* for "slave" and "dial" */
	if ute.mask_ctl = DERIVE_MASK			/* user didn't say -pf or -npf */
	then if cdte.dialup_flags.cpo			/* this terminal type's printer depends on id */
	     then if substr (cdte.tty_id_code, 1, 1) < "A"
		then ute.mask_ctl = DONT_MASK;
		else ute.mask_ctl = DO_MASK;

	if ute.mask_ctl = DONT_MASK			/* either as result above or it already was */
	then do;
	     call astty_$tty_order (cdtep, "accept_printer_off", null, code);
	     if code ^= 0 then go to chn_error;
	end;

	else if ute.mask_ctl = DO_MASK		/* this terminal really doesn't have printer_off */
	then do;
	     call astty_$tty_order (cdtep, "refuse_printer_off", null, code);
	     if code ^= 0 then go to chn_error;
	end;

	user_password = "";				/* Preset password to blanks */
	call astty_$tty_force (cdtep, addr (pw_msg), pw_msg_lth, code); /* Ask for password. */
	if code ^= 0 then go to chn_error;

	call type_black;				/* Hide password */

	if ute.login_flags.cpw then do;		/* If changing password, need special stuff. */
	     cdte.tra_vec = WAIT_OLD_PASSWORD;		/* Set transfer vector so we come back here. */
hand (5):	     call astty_$tty_read (cdtep, addr (buff), nc, code); /* read password */
	     if code ^= 0 then go to chn_error;
	     if nc <= 0 then go to exit1;		/* Was anything typed? */
timeout (5):					/* come here if line read during timeout */
	     call login_parse_$password (addr (buff), nc, user_password, k, jj, tcode); /* Get password from line. */
	     if tcode = error_table_$noarg then go to hand (5); /* Ignore all blank line. */
	     call turn_printer_on (code);
	     if code ^= 0 then go to chn_error;
	     if tcode ^= 0 | k > length (user_password) then do; /* just a slap on the wrist */
		call asu_$write_chn_message (cdtep, as_error_table_$pw_format_warning, shxx, code);
		if code ^= 0 then go to chn_error;
	     end;
	     if user_password = "HELP" | user_password = "help" | user_password = "?" then do;
		call asu_$write_chn_message (cdtep, as_error_table_$help_password, shxx, code);
		if code ^= 0 then go to chn_error;
		go to login_handler (2);
	     end;
	     if user_password = "quit" | user_password = "QUIT" then go to user_typed_quit;
	     ute.old_password = scramble_ (user_password);/* Stow in anstbl, all mashed up. */
	     user_password = "";			/* Keep secure */
	     buff = "";				/* .. */

	     if ute.login_flags.generate_pw		/* does user want us to give pw? */
	     then do;				/* get one that is 6 chars long */

/**** Determine the length of the password to generate.  We use the value
      of ip.password_gpw_length, unless ip.password_min_length is greater
      than this, in which case we use the latter */

		gpw_length = max (installation_parms.password_gpw_length,
		     installation_parms.password_min_length);
		if gpw_length < 1 then
		     gpw_length = 1;		/* don't allow absurd values */

		do k = 1 to 5;			/* allow up to 5 tries to generate a different pw */

		     call generate_word_ (user_password, password_pronunciation, gpw_length, gpw_length);
		     ute.generated_pw = scramble_ (user_password); /* save it for later */
		     if ute.generated_pw ^= ute.old_password then go to have_different_pw;
		end;
new_pw_same_as_old:
		call asu_$write_chn_message (cdtep, as_error_table_$new_password_indistinct, shxx, code);
		if code ^= 0 then go to chn_error;
		go to try_again;
have_different_pw:
		call ioa_$rs (convert_message (as_error_table_$generated_pw_msg),
		     buff, i, user_password, password_pronunciation);

		user_password = "";			/* To the best of my recollection, Senator ... */
		password_pronunciation = "";		/* at that point in time ... */
		call astty_$tty_force (cdtep, addr (buff), i, code); /* show user the generated password */
		buff = "";			/* I don't remember a thing. */
		if code ^= 0 then go to chn_error;	/* (clear buff before checking code!) */
	     end;					/* end -gpw do group */

/* For either -gpw or -cpw, we say: "New Password:" at this point. */

prompt_npw:    call astty_$tty_force (cdtep, addr (npw_msg), npw_msg_lth, code);
	     if code ^= 0 then goto chn_error;

	     if ^ute.login_flags.generate_pw then do;	/* User said -cpw; wait for him to type it,
						   and then ask him to repeat it */
		call type_black;			/* turn off printer or type mask, to hide new password */
		cdte.tra_vec = WAIT_NEW_PASSWORD;	/* remember where to resume after user types it */

hand (7):		call astty_$tty_read (cdtep, addr (buff), nc, code);
		if code ^= 0 then goto chn_error;
		if nc <= 0 then goto exit1;		/* if user has not typed it yet, go 'way 'til he does */

timeout (7):
		call login_parse_$password (addr (buff), nc, temp_password, k, jj, tcode);
		if tcode = error_table_$noarg then goto hand (7); /* if blank line, read again */
		call turn_printer_on (code);
		if code ^= 0 then goto chn_error;
		if tcode ^= 0 | k > length (temp_password) then do;
bad_password_format:     call asu_$write_chn_message (cdtep, as_error_table_$bad_password_format, shxx, code);
		     if code ^= 0 then go to chn_error;
		     go to try_again;
		end;
		if temp_password = "help" | temp_password = "HELP" | temp_password = "?" then do;
		     call asu_$write_chn_message (cdtep, as_error_table_$help_new_pw, shxx, code);
		     if code ^= 0 then go to chn_error;
		     go to prompt_npw;
		end;
		if temp_password = "quit" | temp_password = "QUIT" then go to user_typed_quit; /* giving up? */

		buff = "";			/* be sure unscrambled password is blanked out */

/**** Call check_password_ to ensure the password is valid at this
      site. */

		call check_password_ (temp_password, error_message, code);
		if code ^= 0 then
		     do;
		     call ioa_$rs ("login: Invalid password. ^a.",
			buff, i, error_message);
		     call astty_$tty_force (cdtep, addr (buff), i, code);
		     if code ^= 0 then
			goto chn_error;
		     goto prompt_npw;
		end;

		temp_password = scramble_ (temp_password); /* working with scrambled versions is more secure */
		if temp_password = ute.old_password then
		     goto new_pw_same_as_old;		/* if you say -cpw, you should change it! */

prompt_npw_vfy:	call astty_$tty_force (cdtep, addr (npw_again_msg), npw_again_msg_lth, code);
						/* ask for repeat of new password */
		if code ^= 0 then goto chn_error;

		ute.generated_pw = temp_password;	/* save new pw in anstbl entry while waiting for repeat */
	     end;					/* end of -cpw do group */

	     call type_black;			/* turn off printer or type mask, to hide new password */

	end;					/* end of -gpw or -cpw do group */

	cdte.tra_vec = WAIT_PASSWORD;			/* Set transfer vector to come back here. */

/* At this point, we are waiting for one of three things:
   1) user to repeat new password, if -cpw;
   2) user to type generated password for the first time, if -gpw;
   3) user to type current password, if neither -cpw or -gpw.
*/

hand (6): call astty_$tty_read (cdtep, addr (buff), nc, code); /* read the password */
	if code ^= 0 then go to chn_error;
	if nc <= 0 then go to exit1;			/* wait for him */
timeout (6):					/* come here if line read during timeout */
	call login_parse_$password (addr (buff), nc, user_password, k, jj, tcode); /* extract password */
	if tcode = error_table_$noarg then go to hand (6);/* Ignore all blank line. */
	call turn_printer_on (code);
	if code ^= 0 then go to chn_error;
	if tcode ^= 0 | k > length (user_password) then	/* something naughty */
	     if ^ute.login_flags.cpw then do;		/* this is real password */
						/* so just make it a warning */
		call asu_$write_chn_message (cdtep, as_error_table_$pw_format_warning, shxx, code);
		if code ^= 0 then go to chn_error;
	     end;					/* if -cpw, it has to match, anyhow! */
	if user_password = "quit" | user_password = "QUIT" then go to user_typed_quit; /* he wants to give up */
	if user_password = "help" | user_password = "HELP" | user_password = "?" then do;
	     if ute.login_flags.cpw then
		if ute.login_flags.generate_pw then tcode = as_error_table_$help_gpw_verify;
		else tcode = as_error_table_$help_npw_verify;
	     else tcode = as_error_table_$help_password;
	     call asu_$write_chn_message (cdtep, tcode, shxx, code);
	     if code ^= 0 then go to chn_error;
	     if ute.login_flags.cpw then
		if ute.login_flags.generate_pw then go to prompt_npw;
		else go to prompt_npw_vfy;
	     else go to login_handler (2);
	end;

	user_password = scramble_ (user_password);	/* No peeking. */
	buff = "";				/* blank out unscrambled version */

	if ute.login_flags.cpw then do;		/* if this is repeat of new password, compare to first one */
	     if user_password ^= ute.generated_pw then do;/* note that they are both scrambled */
		if ute.login_flags.generate_pw then	/* get the right error message */
		     ignore_code = as_error_table_$generated_pw_err;
		else ignore_code = as_error_table_$new_pw_err;
		call asu_$write_chn_message (cdtep, ignore_code, shxx, code);
		if code ^= 0 then goto chn_error;
		goto try_again;			/* Please try again or type help for instructions */
	     end;
	end;

	go to trylog;

login_handler (3):					/* "e" - no password needed. */
login_handler (4):					/* "enter" */
	if cdte.disconnected_proc_command ^= 0 then	/* -connected specified */
	     go to no_anon_connect_loop;
	ute.anonymous = 1;				/* No password needed */

trylog:	static_label = abort;			/* in case error */
	call lock;				/* interlock answer table to prevent updates */

/* The answer table lock prevents up_sysctl_ from installing a system table.
   We don't want the SAT or a PDT installed out from under us while we are logging
   someone in, so we lock it before calling lg_ctl_ (which looks in the tables
   to see if the user can log in), and we leave it locked (if we are going to
   create a process) until act_ctl_ has recorded the login in the PDT entry. */

	cdte.n_disconnected_procs = 0;		/* make sure there's no leftover garbage in these */
	cdte.disconnected_ate_index = 0;

/**** lg_ctl_ checks passwords, aim, attributes, and channel aim and acs's.
      If there is a disconnected process, though, it returns control
      prematurely. However, ute.process_authorization is always set
      to the default auth or the -auth value, and is validated against
      SAT/PDT/PNT values. (if one or more check_acs fields are disabled,
      though, it will not do this).  If cdte.current_access_class_valid
      was "0"b when lg_ctl_ was called, then it will be set to "1"b if
      a user name/password was processed. */

	ute.tag = TAG_INTERACTIVE;			/* set this before calling lg_ctl_ */

	if string (ute.login_flags.special_pw) then
	     call lg_ctl_$validate (utep, user_password, reason, code); /* check pw, etc. */
	else call lg_ctl_$login (utep, user_password, reason, code); /* get permission to log in */
	ute.old_password, ute.generated_pw = "";	/* for added security */

/* Check for success or failure of the login */

	if ute.login_result ^= 0 then do;		/* did he fail? */
	     call unlock;				/* Allow logins */
	     if reason ^= ""			/* if lg_ctl_ had something to say */
	     then do;
		substr (buff, 1, length (reason)) = reason;
		call astty_$tty_force (cdtep, addr (buff), length (reason), code);
		if code ^= 0 then go to chn_error;
	     end;
	     if ute.active >= NOW_LOGGED_IN then	/* if we told him he was logged in */
		call print_logged_out;		/* tell him that he isn't, anymore */
	     if ute.login_result = 1 then go to listen_again; /* don't allow another attempt */
	     else go to try_again;			/* get another chance to login */
	end;

/* See if this is dial or slave with a -user control argument */

	if string (ute.login_flags.special_pw) ^= ""b then do;
	     call unlock;				/* no use of PDT/SAT follows here */
	     if ute.login_flags.dial_pw then go to dial_command_join;
	     else if ute.login_flags.slave_pw then go to slave_command_join;
	end;

/* See if lg_ctl_ found a disconnected process */

	if cdte.n_disconnected_procs > 0		/* if user has disconnected processes */
	     & cdte.disconnected_proc_command ^= 2 then do; /* and didn't ask for another one */
	     call unlock;				/* we aren't going to create a proc, so unlock anstbl */
	     if cdte.disconnected_proc_number > cdte.n_disconnected_procs then
		goto no_such_process;		/* user asked for process N but doesn't have that many */

	     if cdte.disconnected_proc_command = 0 then	/* disconnected procs, but no relevant login control args */
		if ute.at.brief then go to read_connect_request_brief; /* right into the request loop */
		else goto give_instructions;		/* supply more information */

	     if cdte.disconnected_proc_command = 1 then	/* -list */
		goto list_request;

	     if cdte.disconnected_proc_number = 0	/* if user didn't specify a process number */
		& cdte.disconnected_proc_command > 2 then do; /* but gave an arg that goes with a process */
		if cdte.n_disconnected_procs > 1 then	/* if he has more than one, we don't know which one he wants */
		     goto must_give_proc_no;
		cdte.disconnected_proc_number = 1;	/* default to process number 1 if that's the only one there is */
	     end;

	     logout_hold = ^cdte.no_hold_arg;		/* set up automatic variable */

/* command not 0, 1, or 2, so must be 3, 4, or 5 (connect, new_proc, or destroy) */

execute_connect_request:

	     do j = 1 to cdte.disconnected_proc_number;	/* search list for user-specified proc */
		call get_next_disc_ate_jkp;		/* get next disconnected ate;
						   global variables j, k, and p are implied arguments */
	     end;

/**** NOTE:
      p -> disconnected process ute.
      j = process number
      k = the index of the ute in the answer table.

      Now we check that user has enough AIM authorization to
      " do anything to this process. We require EQUAL auth for
      any of connect, new_proc, and destroy, to avoid
      write-down or destruction of information. */

	     if ^cdte.current_access_class_valid
	     then do;				/* This should never happen, since the login command always required Identification and Authentication */
		call sys_log_ (SL_LOG, "^a: program error. cdte.current_access_class_valid = ""0""b at disconnected process manipulation for ^a.^a channel ^a.", ME, ute.person, ute.project, cdte.name);
		call print_ascii_msg (as_error_table_$dialup_error,
		     "");
		go to read_connect_request;
	     end;

	     if ^aim_check_$equal (ute.process_authorization, /* contains -auth which was forced to be reasonable W.R.T. channel AIM. */
		p -> ute.process_authorization)
	     then do;
		call ioa_$rsnnl ("User authorization = ^a, Process authorization = ^a",
		     added_info, (0),
		     display_access_class_ (ute.process_authorization),
		     display_access_class_ (p -> ute.process_authorization));
		call as_access_audit_$process_connect_denied (utep, p, added_info);
		call convert_status_code_ (as_error_table_$no_connect_aclass, shxx, format);
		call ioa_$rs (rtrim (format), buff, i, (cdte.n_disconnected_procs > 1), cdte.disconnected_proc_number);
		call print_buff;
		go to read_connect_request;
	     end;

	     temp_atep = utep;			/* remember temporary atep */
	     utep = p;				/* get ptr to disconnected process ate */
	     call timer_manager_$reset_alarm_wakeup (cdte.event);
	     ute.lock_value = ute.lock_value + temp_atep -> ute.lock_value;
	     ute.outer_module = temp_atep -> ute.outer_module; /* lg_ctl_ will have determined
						   the correct outer module for this connection */
	     ute.at.brief = temp_atep -> ute.at.brief;

	     call asu_$release_ate (cdtep, code);	/* give back the ate that we were using */
	     cdte.process = utep;			/* connect cdte to existing ate */
	     ute.channel = cdtep;			/* in both directions */
	     ute.tty_name = cdte.name;		/* copy new channel name into existing ate */
	     ute.tty_id_code = cdte.tty_id_code;	/* also copy answerback */
	     ute.terminal_type = cdte.current_terminal_type;
	     ute.line_type = cdte.cur_line_type;
	     ute.network_connection_type = MCS_NETWORK_TYPE;

	     if cdte.charge_type > 0 then		/* if we normally charge for this channel */
		call device_acct_$on ((cdte.charge_type), cdte.name, utep); /* then start doing so */
	     cdte.n_logins = cdte.n_logins + 1;		/* count number of successful logins on channel */

	     call as_access_audit_$process (utep, AS_AUDIT_PROCESS_CONNECT,
		"");				/* Audit the process connection */

/* Tell the user what we're about to do.
   This message could not be put into as_error_table_ because the conditionals contain semicolons,
   and the error_table_compiler doesn't allow semicolons imbedded in messages. */

	     if ^ute.at.brief then do;		/* unless user thinks he knows it all */
		call ioa_$rs
		     ("Your disconnected process ^[#^d ^;^s^]will be ^[destroyed^s^;connected to this terminal^[ after new_proc^]^].",
		     buff, i,
						/* Your disconnected process */
		     (cdte.n_disconnected_procs > 1), cdte.disconnected_proc_number, /* #N */
						/* will be */
		     (cdte.disconnected_proc_command = 5), /* destroyed */
						/* connected to this terminal */
		     (cdte.disconnected_proc_command = 4)); /* after new_proc */
		call print_buff;
	     end;
	     i = 0;				/* don't print twice */

/**** Reset the process termination handler to be us, dialup_, in case
      this is a reconnection from a previous MNA connection, in which case
      uc_proc_term_handler_ is still associated with the channel as the
      process termination handler */

	     call ipc_$decl_ev_call_chn (ute.event, dialup_, utep, INT_LOGIN_PRIO, code);
	     if code ^= 0 then do;
		call sys_log_$error_log (SL_LOG_BEEP, code, ME,
		     "Unable to declare handler for ev chn ^24.3b for UTE ^p for ^a",
		     ute.event, utep, cdte.name);
		call asu_$write_chn_message (cdtep, as_error_table_$dialup_error, shxx, code);
		if code ^= 0 then goto chn_error;
		goto listen_again;
	     end;

	     if cdte.disconnected_proc_command = 3 then goto connect_tty; /* -connect */

	     else do;				/* -new_proc or -destroy */
		cdte.in_use = NOW_HAS_PROCESS;	/* get ready to jump into the middle of */
		cdte.tra_vec = WAIT_LOGOUT_SIG;	/* the process destruction code */
		static_label = abort;
		tcode = 0;
		error_mess = "";
		helphelp = ""b;
		ute.pdtep -> user.n_disconnected =	/* decrement count of user's disconnected processes */
		     max (0, ute.pdtep -> user.n_disconnected - 1);
		ute.disconnected = ""b;
		if ute.whotabx > 0 then do;
		     whotab.e (ute.whotabx).disconnected = ""b;
		     whotab.e (ute.whotabx).idcode = cdte.tty_id_code;
		end;
		call unlock;

		if cdte.disconnected_proc_command = 4 then do; /* -new_proc */
		     ute.logout_type = "new_";	/* set for audit messages */
		     j = 2;			/* table position of new_proc wakeup */
		end;
		else do;				/* -destroy */
		     ute.logout_type = "dest";	/* set for audit messages */
		     if cdte.n_disconnected_procs = 1 & /* if only one disconnected proc, regular logout */
			^logout_hold then		/* user said -no_hold */
			j = 4;			/* table position of logout wakeup */
		     else				/* if more than one, logout -hold */
			j = 3;			/* table position of logout -hold wakeup */
		end;

		if ^connect_immediate then		/* user didn't say -immediate */
		     if asu_$send_term_signal (utep, j) then /* see if we want to send trm_ to the process */
			goto exit1;		/* if we did, we'll get a wakeup when it destroys itself */

		goto logout_handler (j);		/* if -immediate or no trm_ sent, go shoot it down immediately */
	     end;

	end;					/* end disconnected procs > 0 & command ^= create */

	if cdte.n_disconnected_procs = 0		/* if user has no disconnected processes */
	     & cdte.disconnected_proc_command ^= 0	/* but gave an argument pertaining to disconnected processes */
	     & cdte.disconnected_proc_command ^= 2	/* and it wasn't -create */
	then do;					/* then go complain */
	     call unlock;				/* but make sure not to leave anstbl locked */
	     go to read_connect_request;		/* don't tell him twice he has no processes */
	end;

/* If we get here, the user wanted a process created, either -create or no args and no disconnected processes */


/* Check for persistent bug */

	if ^ute.uflags.proc_create_ok then do;		/* if lg_ctl_ did not fill in the process creation variables */
	     call sys_log_ (SL_LOG, "^a: program error: attempt to create process for ^a.^a ^a,
with ate ^p not filled in; n_disc=^d,disc_com=^d,disc_ate_ix=^d",
		ME, ute.person, ute.project, cdte.name, utep, cdte.n_disconnected_procs,
		cdte.disconnected_proc_command, cdte.disconnected_ate_index);
	     tcode = as_error_table_$dialup_error;
	     call asu_$write_chn_message (cdtep, tcode, shxx, code);
	     if code ^= 0 then goto chn_error;
	     logout_hold = "1"b;			/* don't hang up */
	     call unlock;				/* make sure not to leave anstbl locked */
	     goto log_disconnected_user_out;		/* if we printed logged in, print logged out */
	end;

/* User is authorized to log in. */

	call timer_manager_$reset_alarm_wakeup (cdte.event);
						/* Turn off egg timer on logins */
	ute.n_processes = 0;			/* set to 'initial process creation' */

	call act_ctl_$open_account (utep);		/* open and activate user's account */
	cdte.n_logins = cdte.n_logins + 1;		/* count number of successful logins on channel */
	cdte.current_access_class (*) = ute.process_authorization; /* note the single class of the connection in the cdte */

/* Come here to create new process on login, new_proc, or fatal error termination */

create:	if cdte.charge_type > 0
	then call device_acct_$on ((cdte.charge_type), cdte.name, utep); /* Charge for fancy devices */
	call lock;				/* interlock answer table to prevent updates */
	if ute.whotabx > 0 then
	     whotab.e (ute.whotabx).suspended = "0"b;	/* KLUDGE - this should be better */
	ute.ignore_cpulimit = "1"b;			/* KLUDGE - this should be better */
	ute.suspended, ute.sus_sent = ""b;		/* KLUDGE - this should be better */
	ute.n_processes = ute.n_processes + 1;		/* count number of processes in session */
	if ute.preempted >= PREEMPT_TERM_SENT then
	     ute.preempted = PREEMPT_UNBUMP_IGNORE_ALARM; /* in case we came here after operator term command */

	call cpg_ (utep, code);			/* Call utility to create process (calls actproc) */
	if code ^= 0 then do;			/* should never happen */
	     call sys_log_$error_log (SL_LOG_BEEP, code, ME, "creating process for ^a.^a",
		ute.person, ute.project);
						/* Clean up after the aborted login (thank you, Steve Landry) */
	     ute.logout_type = "cpg";			/* act_ctl_$close_account needs a reason for the logout */
	     call act_ctl_$close_account (utep);	/* close account and print logout message for operator */
	     call lg_ctl_$logout (utep);		/* remove user from whotab and return his load units */
	     tcode = as_error_table_$process_create_fail; /* Tell user we failed. */
	     i = 0;				/* No further message. */
	     cdte.tra_vec, ute.destroy_flag = WAIT_LOGOUT_HOLD; /* and after destroying process, let user try again */
	     call unlock;				/* Unlock ate */
	     go to kill;				/* Get tty back. */
	end;

	call act_ctl_$cp (utep);			/* Record the creation of the user process. */
	ute.active = NOW_HAS_PROCESS;			/* User now has a process. */

connect_tty:
	cdte.in_use = NOW_HAS_PROCESS;		/* Indicate that there is a process. */

/* Display the message "Your authorization is ..." upon process creation
   or connection. */

	call DISPLAY_PROCESS_AUTHORIZATION ();

	call astty_$tty_new_proc (cdtep, ute.proc_id, code); /* give tty to new process before it runs */
	if code ^= 0 then go to abort;		/* kill proc if hungup */

	call astty_$tty_order (cdtep, "copy_meters", null (), code);

	if ute.disconnected then do;			/* if we're reconnecting a process */
	     call cpg_$set_pit_tty_info (utep, code);	/* tell process about it's new terminal */
	     if code ^= 0 then do;
		call sys_log_$error_log (SL_LOG_SILENT, code, ME, "setting new tty info for ^a", cdte.name);
						/* for now, keep going and see what happens */
	     end;
	     call asu_$release_suspended_process (utep);	/* tell process that it may run again */

/**** Now send the process a wakeup over the event channel setup by the
      sus_ signal handler, to kick the process into action again. */

	     call hcs_$wakeup (ute.proc_id, ute.sus_channel, (0), code);
	     if code ^= 0 then
		call sys_log_$error_log (SL_LOG_SILENT, code, ME,
		     "Trying to wakeup process after reconnection for ^a.^a.^a.", ute.person, ute.project, ute.tag);

	     ute.pdtep -> user.n_disconnected =		/* decrement count of user's disconnected processes */
		max (0, ute.pdtep -> user.n_disconnected - 1);
	     ute.disconnected = ""b;
	     if ute.whotabx > 0 then do;
		whotab.e (ute.whotabx).disconnected = ""b; /* publish it */
		whotab.e (ute.whotabx).idcode = cdte.tty_id_code;
	     end;
	end;

	else call asu_$start_process (utep);		/* we're creating a new process, so start it. */

	cdte.tra_vec = WAIT_LOGOUT_SIG;		/* Set transfer vector. */
	ute.destroy_flag = WAIT_LOGOUT_SIG;		/* .. */
exit:	static_label = exit1;			/* in case fault in unlock */
	call unlock;				/* release answer table, permit updates */

exit1:	static_label = return_immediately;
	call as_meter_$exit_values (DIALUP_METER, new_pf, new_cpu, old_cpu); /* using old_cpu to hold real_time */

	scdtp -> cdt.realtime_in_dialup = scdtp -> cdt.realtime_in_dialup + old_cpu;
	scdtp -> cdt.pf_in_dialup = scdtp -> cdt.pf_in_dialup + new_pf;
	scdtp -> cdt.cpu_in_dialup = scdtp -> cdt.cpu_in_dialup + new_cpu;
	scdtp -> cdt.entries_to_dialup = scdtp -> cdt.entries_to_dialup + 1;

return_immediately:
	return;					/* This is the main exit. */
%page;

login_handler (7):					/* "d" */
login_handler (8):					/* "dial" */
	call grab_ute;				/* set up */
	call parse_login_line_$dial_line (addr (substr (buff, jj, 1)), nc - jj + 1, utep, error_mess, code);
	if code = error_table_$noarg then go to read_login_args; /* If user gave no args, ask for them. */
	if code ^= 0 then go to bad_login_slave_dial_request;
	if ute.person = "anonymous" then ute.anonymous = 1; /* special hack */
	if cdte.flags.access_control.slave_dial
	then					/* -user needed */
	     if ute.person ^= ""
	     then go to read_password;
	     else do;
		call asu_$write_chn_message (cdtep, as_error_table_$ds_user_required, shxx, ignore_code);
		go to try_again;
	     end;
	else					/* no -user needed */
	     if ute.person ^= "" then
	     call asu_$write_chn_message (cdtep, as_error_table_$ds_user_ignored, shxx, ignore_code);

dial_command_join:					/* back here after password validated */
	dial_qual = ute.dial_qualifier;		/* copy ute values */
	dial_arg1 = ute.sender;

	call free_ute;				/* release the ute */
	call dial_ctl_ (cdtep, dial_qual, dial_arg1, code);
	if code ^= 0
	then do;
	     call asu_$write_chn_message (cdtep, code, shxx, ignore_code); /* try to write the error message */

/**** If he was authenticated, and we logged an LOGIN message, then we
      must log an LOGOUT message now. */

	     if cdte.flags.access_control.slave_dial then
		call lg_ctl_$logout_channel (cdtep, "dial failed");

	     if cdte.state < TTY_DIALED then go to listen_again; /* if user hung up during dial */
	     else go to try_again;			/* all other errors */
	end;
	call timer_manager_$reset_alarm_wakeup (cdte.event); /* Success. */
	cdte.tra_vec = WAIT_DIAL_RELEASE;		/* Set transfer vector to reclaim channel. */
	go to exit1;				/* Note that cdte.in_use is still NOW_DIALED */

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

login_handler (10):					/* "HELP" */
login_handler (9):					/* "help" */
	call print_help ("login_help");
	go to try_again;				/* Tell him he can try again. */

login_handler (11):					/* "MAP" - The Padlipsky command. */
	call ttt_info_$preaccess_type ("MAP", type_to_set, code); /* find out what type corresponds */
	if code ^= 0 then go to chn_user_error;
	if type_to_set ^= "" then do;
	     call change_type (type_to_set, "1"b, "1"b, code);
	     if code ^= 0 then go to chn_user_error;
	end;
	go to read_login_line;			/* Try again. */

login_handler (12):					/* "hello" command */
	call hello (0);				/* Repeat greeting */
	if code ^= 0 then go to chn_error;
	go to read_login_line;			/* Let him try login now. */

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

login_handler (13):					/* "slave" command */
	call grab_ute;				/* set up */
	call parse_login_line_$slave_line (addr (substr (buff, jj, 1)), nc - jj + 1, utep, error_mess, code);

	if code ^= 0 then go to bad_login_slave_dial_request;
	if ute.person = "anonymous" then ute.anonymous = 1;
	if cdte.flags.access_control.slave_dial
	then					/* -user needed */
	     if ute.person ^= ""
	     then go to read_password;
	     else do;
		call asu_$write_chn_message (cdtep, as_error_table_$ds_user_required, shxx, ignore_code);
		go to try_again;
	     end;
	else					/* no -user needed */
	     if ute.person ^= "" then
	     call asu_$write_chn_message (cdtep, as_error_table_$ds_user_ignored, shxx, ignore_code);



slave_command_join:					/* back here after password verified */
	call free_ute;
	cdte.current_service_type = SLAVE_SERVICE;	/* Set channel up to wait for Godot. */
	cdte.tra_vec = WAIT_DIAL_RELEASE;		/* Do something reasonable if it hangs up */
	cdte.process = null;			/* .. */
	call timer_manager_$reset_alarm_wakeup (cdte.event);

	call sys_log_ (SL_LOG_SILENT, "SLAVE^12t^[^a.^a^;^s^s^] ^a",
	     cdte.flags.access_control.slave_dial, cdte.user_name.person, cdte.user_name.project, cdte.name);
	go to exit1;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* Preaccess commands for setting terminal types and modes */

login_handler (14):					/* "modes" command */
	call login_parse_ (addr (substr (buff, jj, 1)), nc - jj + 1, new_modes, k, j, code);
	if code = error_table_$noarg then do;
	     call astty_$tty_getmode (cdtep, modes_string, code);
	     if code ^= 0 then modes_string = "?";
	     call ioa_$rs ("Current modes: ^a", buff, i, modes_string);
	     call print_buff;
	     go to read_login_line;
	end;
	else if code ^= 0 then go to try_again_code;

	go to login_modes_join;

login_handler (25):					/* "noecho" command */
	new_modes = "^echoplex";
	goto login_modes_join;

login_handler (15):					/* "echo" command */
	new_modes = "echoplex";

login_modes_join:
	call astty_$tty_changemode (cdtep, (new_modes), code);
	if code ^= 0 then go to chn_user_error;
	go to read_login_line;


login_handler (16):					/* "terminal_type" command */
login_handler (17):					/* "ttp" command */
	call login_parse_ (addr (substr (buff, jj, 1)), nc - jj + 1, new_modes, k, j, code);
	if code = error_table_$noarg then do;
	     call ioa_$rs ("Current terminal type is ""^a"".", buff, i, cdte.current_terminal_type);
	     call print_buff;
	     go to read_login_line;
	end;
	else if code ^= 0 then go to try_again_code;

	set_type_info.version = stti_version_1;
	set_type_info.name = substr (translate (new_modes, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"), 1, 32);
	string (set_type_info.flags) = "0"b;
	call astty_$tty_order (cdtep, "set_term_type", addr (set_type_info), code);
	if code ^= 0 then do;
	     call convert_status_code_ (code, shxx, error_mess);
	     call ioa_$rs ("^a ^a", buff, i, error_mess, set_type_info.name);
	     call print_buff;
	     go to read_login_line;
	end;
	cdte.current_terminal_type = set_type_info.name;
	call set_tabs_and_modes_gently (code);
	call ttt_info_$dialup_flags (set_type_info.name, cdte.dialup_flags.ppm, cdte.dialup_flags.cpo, code);
	go to read_login_line;

login_handler (26):					/* terminal_id  command */
login_handler (27):					/* tid command */
	call login_parse_ (addr (substr (buff, jj, 1)), nc - jj + 1, new_modes, k, j, code);
	if code = error_table_$noarg then do;
	     call ioa_$rs ("Current terminal id is ""^a"".", buff, i, cdte.tty_id_code);
	     call print_buff;
	     go to read_login_line;
	end;
	else if code ^= 0 then go to try_again_code;

	if cdte.flags.ck_answerback | nc > jj + j then do;
	     call print_ascii_msg (as_error_table_$bad_terminal_id, (user_login_word));
	     go to read_login_line;
	end;
	cdte.tty_id_code = substr (new_modes, 1, 4);
	go to read_login_line;

login_handler (28):					/* access_class command */
login_handler (29):					/* acc */
	call login_parse_ (addr (substr (buff, jj, 1)), nc - jj + 1, "", k, j, code);
	if code = 0 then do;
	     call ioa_$rs ("Usage: access_class", buff, i);
	     call print_buff;
	     go to read_login_line;
	end;
	call print_access_class;
	go to read_login_line;

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

/* The following are only valid when the user is logged in, and we are now awaiting a login command */

login_handler (20):					/* list */
login_handler (21):					/* create */
login_handler (22):					/* connect */
login_handler (23):					/* new_proc */
login_handler (24):					/* destroy */

	call print_ascii_msg (as_error_table_$only_after_login_msg, (user_login_word));
	goto try_again;

/* We come to one of the following labels to print an error message related to disconnected processes,
   and then prompt for, and read, a connect request */

no_such_process:
	call ioa_$rs (convert_message (as_error_table_$no_such_process_msg), buff, i, cdte.disconnected_proc_number);
	call print_buff;
	goto read_connect_request;

no_disconnected_procs:
	tcode = as_error_table_$no_disconnected_procs;
	goto connect_error;

must_give_proc_no:
	tcode = as_error_table_$must_give_proc_no;
	goto connect_error;

give_instructions:
	if ute.at.brief then go to read_connect_request;	/* user doesn't want instructions */
	tcode = as_error_table_$give_instructions;

connect_error:
	call asu_$write_chn_message (cdtep, tcode, shxx, code);
	if code ^= 0 then goto chn_error;
	go to read_connect_request;			/* unconditionally write request prompt */

/* read_connect_request_brief is for use if no error occurred. Then we pay attention to the user's brief bit.
   But if he made an error, the read_connect_request label is used, resulting
   in the user always getting a prompting message */

read_connect_request_brief:				/* honour brief bit */
	if ute.at.brief then do;			/* user doesn't want a prompt */
	     cdte.tra_vec = WAIT_CONNECT_REQUEST;
	     go to wait_connect_request;		/* so just wait for him */
	end;

read_connect_request:
	cdte.tra_vec = WAIT_CONNECT_REQUEST;		/* ask for and wait for connect request */
	if cdte.n_disconnected_procs > 0 then code = as_error_table_$give_connect_request;
	else code = as_error_table_$give_connect_request_no_disc;
	call asu_$write_chn_message (cdtep, (code), shxx, code);
	if code ^= 0 then goto chn_error;

/* WAIT_CONNECT_REQUEST */
hand (21):
wait_connect_request:
	call astty_$tty_read (cdtep, addr (buff), nc, code);
	if code ^= 0 then goto chn_error;
	if nc <= 0 then goto exit1;			/* if user hasn't typed anything yet,
						   we'll get a wakeup when he does */

/* We hope we have a connect request */

timeout (21):
	call login_parse_ (addr (buff), nc, user_login_word, k, jj, code); /* get first word on line */
	if code = error_table_$noarg then goto read_connect_request; /* happens if user hits just blanks and carriage return */
	if code ^= 0 then go to try_again_code;
						/* look up the word in the table */
	do lgwd = lbound (as_data_login_words.words, 1) to
	     hbound (as_data_login_words.words, 1)
	     while (user_login_word ^= as_data_login_words.words (lgwd));
	end;

	if lgwd > hbound (as_data_login_words.words, 1) then do; /* user typed an unknown word */
	     call print_ascii_msg (as_error_table_$unknown_request_msg, (user_login_word));
	     goto read_connect_request;
	end;

	if lgwd = 9 then do;			/* help */
	     call print_help ("connect_help");
	     goto read_connect_request;
	end;

/* Some time, allow the terminal mode setting requests in here */

	if lgwd < 18 | lgwd > 24 then do;		/* word recognized but invalid now */
	     call print_ascii_msg (as_error_table_$rq_invalid_now_msg, (user_login_word));
	     call asu_$write_chn_message (cdtep, as_error_table_$now_logged_in, shxx, code); /* say "You're logged in now;
						   tell us what to do about your disconnected processes" */
	     if code ^= 0 then goto chn_error;
	     if cdte.n_disconnected_procs > 0 then
		goto give_instructions;
	     else goto read_connect_request;
	end;

/* It is a legal connect request */

	goto connect_handler (lgwd - 17);		/* map 18 thru 24 into 1 thru 7 */

connect_handler (1):				/* logout */
login_handler (18):					/* logout when not really logged in */

	logout_hold, logout_brief = ""b;		/* assume not -hold */
	k = 1;					/* get the do while started */
	code = 0;
	do while (code = 0);			/* as long as there's anything more on the line */
	     call login_parse_ (addr (substr (buff, jj, 1)), nc - jj + 1, user_login_word, k, j, code); /* see if there's another word */
	     if code ^= error_table_$noarg then
		if code ^= 0 then go to try_again_code;
	     if code = 0 then do;			/* there is; see what it is */
		if user_login_word = "-hd" | user_login_word = "-hold" then logout_hold = "1"b;
		else if user_login_word = "-no_hold" | user_login_word = "-nhd" then logout_hold = "0"b;
		else if user_login_word = "-bf" | user_login_word = "-brief" then logout_brief = "1"b;
		else if user_login_word = "-long" | user_login_word = "-lg" then logout_brief = "0"b;
		else do;
		     call print_ascii_msg (as_error_table_$unknown_arg_msg, (user_login_word));
		     if cdte.tra_vec = WAIT_CONNECT_REQUEST then /* can user be in connect loop? */
			goto read_connect_request;	/* yes */
		     else goto try_again;		/* silly boy */
		end;
		jj = jj + j;			/* move cursor past this argument */
	     end;
	end;

log_disconnected_user_out:

	if logout_brief then say_hello = ""b;
	else say_hello = "1"b;

	if have_ate & ^logout_brief then		/* if there's a user and he didn't say -brief */
	     if ute.active >= NOW_LOGGED_IN then	/* and he got a login message, give him a logout message */
		call print_logged_out;

	if logout_hold then do;			/* if -hold, clean up and then go print a greeting message */
	     call free_ute;
	     just_dialed_up = "0"b;
	     goto login;
	end;

	goto listen_again;

connect_handler (2):				/* hangup command while logged in */
login_handler (19):					/* hangup command while not logged in */
	if have_ate then
	     if ute.active >= NOW_LOGGED_IN then
		call lg_ctl_$logout_no_process (utep, "hangup, no process");
	goto listen_again;				/* that was easy */

connect_handler (3):				/* list */
list_request:
	if cdte.n_disconnected_procs = 0 then goto no_disconnected_procs;
	do j = 1 to cdte.n_disconnected_procs;
	     call get_next_disc_ate_jkp;		/* get next disconnected ate;
						   global variables j, k, and p are implied arguments */
	     date_time = date_time_$format ("date_time", p -> ute.login_time, "", "");
	     call ioa_$rs (convert_message (as_error_table_$list_disconnected_msg), buff, i,
		j, date_time, p -> ute.tty_name, p -> ute.tty_id_code);
	     call print_buff;
	end;
	goto read_connect_request_brief;		/* be quiet if the user wants it */

connect_handler (4):				/* create */
	cdte.disconnected_proc_command = 2;		/* -create */
	cdte.disconnected_proc_number = 0;
	goto trylog;				/* go pretend user said login -create */

connect_handler (5):				/* connect */
	cdte.disconnected_proc_command = 3;		/* -connect */
	goto connect_common;

connect_handler (6):				/* new_proc */
	cdte.disconnected_proc_command = 4;		/* -new_proc */
	goto connect_common;

connect_handler (7):				/* destroy */
	cdte.disconnected_proc_command = 5;		/* -destroy */

connect_common:
	if cdte.n_disconnected_procs = 0 then		/* if none, say so before going any further */
	     goto no_disconnected_procs;

	cdte.disconnected_proc_number = 0;		/* illegal value; changes if user gives number */
	logout_hold = "1"b;				/* default to -hold */
	do while ("1"b);				/* handle all control args */
	     call login_parse_ (addr (substr (buff, jj, 1)), nc - jj + 1, user_login_word, k, j, code); /* see if there's another word */
	     if code = error_table_$noarg then do;	/* no more args - check what we have */
		if cdte.disconnected_proc_number = 0 then /* if user did not give process number */
		     if cdte.n_disconnected_procs = 1 then /* if user only has one */
			cdte.disconnected_proc_number = 1; /* default to 1 if no number given */
		     else go to must_give_proc_no;	/* error if more than one and user didn't say which */
		go to execute_connect_request;	/* go connect terminal to process; then do what user requested */
	     end;					/* end no more arguments */
	     else if code ^= 0 then go to try_again_code;

	     jj = jj + j;				/* advance index */
	     k = cv_dec_check_ (user_login_word, code);	/* think of it as a number */
	     if code = 0 then do;			/* it was a number */
		if cdte.disconnected_proc_number ^= 0 then do; /* but user already specified a process */
connect_arg_error:	     code = as_error_table_$unknown_arg_msg;
		     call print_ascii_msg (code, (user_login_word));
		     go to read_connect_request;	/* have the user try again */
		end;

		cdte.disconnected_proc_number = k;	/* remember it */
		if k <= 0 | k > cdte.n_disconnected_procs then
		     go to no_such_process;		/* user gave nonsense value */
	     end;					/* it was a number */
	     else if user_login_word = "-immediate" | user_login_word = "-im" then do;
		if cdte.disconnected_proc_command = 4 | /* new_proc */
		     cdte.disconnected_proc_command = 5 then /* destroy */
		     connect_immediate = "1"b;	/* user want's process destroyed immediately */
		else go to connect_arg_error;
	     end;
	     else if user_login_word = "-hold" | user_login_word = "-hd" then do;
		if cdte.disconnected_proc_command = 5 | /* destroy */
		     cdte.disconnected_proc_command = 1 /* logout */
		then logout_hold = "1"b;		/* don't hang up */
		else go to connect_arg_error;
	     end;
	     else if user_login_word = "-no_hold" | user_login_word = "-nhd" then do;
		if cdte.disconnected_proc_command = 5 | /* destroy */
		     cdte.disconnected_proc_command = 1 /* logout */
		then logout_hold = "0"b;		/* hang up */
		else go to connect_arg_error;
	     end;
	     else go to connect_arg_error;		/* invalid control arg */
	end;					/* connect control arg loop */
%page;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
   *						 *
   * Here if a logged-in user has something happen to him	 *
   * which involves destroying his process.		 *
   *						 *
   *	logout					 *
   *	logout hold				 *
   *	fatal error in process			 *
   *	out of funds				 *
   *	can't start process				 *
   *	preempted					 *
   *	system coming down				 *
   *	standby bump				 *
   *	inactive too long				 *
   *	bumped/unbumped/terminated/detached by operator    *
   *	hung up phone				 *
   *						 *
   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

/* WAIT_LOGOUT_SIG */
hand (8): funct = signal_type;			/* extract event message, tells what to do */
	static_label = abort;			/* in case error */
	tcode = 0;				/* Assume no special termination code. */
	error_mess = "";				/* clear string used to hold converted status code */
	helphelp = ""b;				/* assume user is not in fatal process error trouble */
	if wakeup_from_user then do;
	     do j = 1 to n_signals while (funct ^= signals (j)); /* check in as_data_ */
	     end;
	     if j <= n_signals then ;			/* is it known? */
	     else if signal_type1 = "term" | signal_type1 = "init" then do; /* these messages have error code in word 2 */
		tcode = bc.code;			/* extract code (xxxx) from "term"xxxx or "init"xxxx */
		if tcode ^= 0			/* Validate it. We don't want to be hacked. */
		then if tcode_left_half ^= baseno (null)/* Oops. Not an error_table_ code. */
		     then do;			/* wonder what is is  ... */
			call ioa_$rsnnl ("Code = ^w", error_mess, i, tcode); /* lets see */
			tcode = 0;		/* don't try to convert_status_code_ it */
		     end;
		j = 1;				/* Terminate his process. */
	     end;
	     else if new_proc_auth.np_signal = "np" then	/* new_proc -auth AUTH */
		j = 13;				/* new_proc to new authorization */
	     else if ute.sus_sent & ^ute.suspended then do; /* if waiting for response from sus_, this must be it */
		ute.sus_channel = ev_msg.ev_message;	/* save event channel that process is blocked on */
		if ute.ignore_cpulimit then do;	/* if process got released before it responded */
		     ute.sus_sent = ""b;		/* clear the suspended flag */
		     if ute.whotabx > 0 then
			whotab.e (ute.whotabx).suspended = ""b; /* publish it */
		     call hcs_$wakeup (ute.proc_id, ute.sus_channel, (0), (0)); /* tell process it may run */
		end;				/* leave the ignore_cpulimit switch on */
		else do;				/* not released already (normal case) */
		     ute.suspended = "1"b;		/* remember that process responded correctly */
		     if ute.whotabx > 0 then
			whotab.e (ute.whotabx).suspended = "1"b; /* publish it */
		     call timer_manager_$reset_alarm_wakeup (ute.event); /* turn off the alarm timer */
		end;
		goto exit1;			/* and get out */
	     end;					/* end sus sent */
	     else do;				/* That's all a user can signal. */
		j = 1;				/* Creative user tried to write own logout, and goofed. */
		funct = "badsignl";			/* Or he may have tried to hack us. */
		tcode = as_error_table_$illegal_signal; /* Might as well tell user. */
	     end;
	end;
	else do;					/* Must be a system-generated event. */
	     do j = 1 to n_system_signals while (funct ^= system_signals (j)); end;
	     if j <= n_system_signals then j = j + 19;	/* See if it is a system signal. */
	     else do;				/* Probably a hangup ... check it out */
		if ^have_cdte then goto fals0;	/* can't be hangup if no cdte */
		call astty_$tty_state (cdtep, code);
		if code ^= 0 then go to chn_error;	/* tolerate no errors */

		if cdte.state = TTY_DIALED		/* not a hangup cause terminal is still there */
		then go to fals0;			/* ignore it (but log it first) */

		j = 20;				/* set jump index to hangup */
	     end;
	end;

	if have_ate then do;			/* watch out for detach of tty with no process (no ate) */
	     if ute.preempted ^= PREEMPT_TERM_SENT then	/* unless we have already done so */
		ute.logout_type = signal_type1;	/* remember the reason for the logout */
	     ute.login_flags.noprint = "0"b;		/* usually print logout message. */
	end;

	i = 0;					/* message length = 0 until we build a message */

	go to logout_handler (j);			/* Fast dispatch. */

logout_handler (27):				/* ("terminat") Operator terminated process. */
	if asu_$send_term_signal (utep, j)		/* send term signal if appropriate */
	then goto exit1;				/* if we did, wait for process to destroy itself */
	tcode = as_error_table_$term_by_operator;	/* Tell user why process died. */
						/* Fall through into normal case. */

logout_handler (1):					/* ("term"xxxx or "init"xxxx) Process termination. */
	if have_cdte then
	     call astty_$tty_abort (cdtep, 1, ignore_code); /* abort any read ahead (let writing finish!) */
	if tcode ^= 0 then do;			/* If code is not zero then */
	     call convert_status_code_ (tcode, shxx, error_mess);
	     call sys_log_ (SL_LOG_SILENT, "^a: process terminated ^a.^a ^a ^a",
		ME, ute.person, ute.project, ute.tty_name, shxx);
	     tcode = 0;				/* Don't print it again... */
	end;

	if ute.disconnected then do;			/* if a disconnected process gets a fatal error */
	     ute.destroy_flag = WAIT_LOGOUT;		/* log the user out (no point in anything else) */

/* TO BE CODED: send the user a message with the reason in it (error_mess contains the reason) */

	end;

	else if signal_type1 = "init" then do;		/* fatal error during process initialization */
	     ute.destroy_flag = WAIT_LOGOUT_HOLD;	/* a new process would just get another fatal error */
	     call ioa_$rs (init_term_fmt, buff, i, error_mess); /* Put reason for fatal error into message:
						   Fatal error during process initialization. <error_mess> */
	     call sys_log_ (SL_LOG, "^a: fatal error during process creation for ^a.^a ^a",
		ME, ute.person, ute.project, cdte.name);
	     helphelp = "1"b;			/* offer some help - its the least we can do */
	end;

	else do;					/* fatal error not during initialization -
						   but check for fatal error loop anyway, since
						   user might be getting errors during start_up.ec */
	     if ute.recent_fatal_error_time + installation_parms.fatal_error_loop_seconds * 1000000 < anstbl.current_time then
		do;				/* if previous fatal error was long ago */
		if ute.uflags.fpe_causes_logout then do;
		     call convert_status_code_ (as_error_table_$fpe_caused_logout, shxx, error_mess);
		     call ioa_$rs ("^a", buff, i, error_mess);
		     ute.destroy_flag = WAIT_LOGOUT_HOLD;
		end;
		else do;
		     ute.recent_fatal_error_time = anstbl.current_time; /* reset the fatal error loop timer */
		     ute.recent_fatal_error_count = 1;	/* and set the counter back to 1 */
create_another_new_proc:
		     ute.destroy_flag = WAIT_NEW_PROC;	/* let user have another new process after destroying this one. */
		     call ioa_$rs (proc_term_fmt, buff, i, error_mess); /* put reason for fatal error into message:
						   Fatal error. Process has terminated. <error_mess>
						   New process created. */
		end;
	     end;					/* not too many FPEs */

	     else do;				/* we seem to have a loop */
		ute.recent_fatal_error_count = ute.recent_fatal_error_count + 1; /* count times around it */
		if ute.recent_fatal_error_count < installation_parms.fatal_error_loop_count then /* if not too many */
		     goto create_another_new_proc;	/* keep going a while longer */
		ute.destroy_flag = WAIT_LOGOUT_HOLD;	/* too many. get out of the loop, but don't hang up */
		call ioa_$rs (proc_term_loop_fmt, buff, i, error_mess); /* put reason for fatal error into message:
						   Fatal error. Process has terminated. <error_mess>
						   You appear to be in a fatal process error loop. */

		call sys_log_ (SL_LOG, "^a: terminating fatal process error loop for ^a.^a ^a",
		     ME, ute.person, ute.project, ute.tty_name);
		helphelp = "1"b;			/* offer some help */
	     end;
	end;

kill_audit:
	call as_access_audit_$process (utep, AS_AUDIT_PROCESS_TERMINATE,
	     (signal_type1));
	go to kill;

logout_handler (2):					/* New_proc */
	ute.destroy_flag = WAIT_NEW_PROC;		/* Create new process after destroying process. */
	ute.login_flags.noprint = "1"b;		/* no message from us. */
	go to kill;

logout_handler (3):					/* logout -hold */
	if installation_parms.trusted_path_login then do;
	     ute.destroy_flag = WAIT_LOGOUT;
	     tcode = as_error_table_$no_logout_hold;
	end;
	else ute.destroy_flag = WAIT_LOGOUT_HOLD;	/* User wants to login again. */
	go to kill;

logout_handler (5):					/* logout -bf */
	ute.destroy_flag = WAIT_LOGOUT;
	ute.login_flags.noprint = "1"b;		/* Inhibit printing of messages. */
	go to kill;

logout_handler (6):					/* logout -hold -bf */
	if installation_parms.trusted_path_login then do;
	     ute.destroy_flag = WAIT_LOGOUT;
	     tcode = as_error_table_$no_logout_hold;
	end;
	else do;
	     ute.login_flags.noprint = "1"b;		/* Inhibit printing of logout message. */
	     ute.destroy_flag = WAIT_LOGOUT_HOLD;	/* Set transfer vector to mallow login */
	end;
	go to kill;

logout_handler (7):					/* init_err */
	ute.destroy_flag = WAIT_LOGOUT_HOLD;
	tcode = as_error_table_$init_err;		/* Process cannot be initialized. */
	helphelp = "1"b;				/* offer some help */
	go to kill;

logout_handler (8):					/* no_ioatt */
	ute.destroy_flag = WAIT_LOGOUT_HOLD;
	tcode = as_error_table_$no_io_attach;		/* Cannot attach process I/O streams */
	helphelp = "1"b;				/* offer some help */
	go to kill;

logout_handler (9):					/* no_initproc */
	ute.destroy_flag = WAIT_LOGOUT_HOLD;
	tcode = as_error_table_$no_init_proc;		/* Cannot locate initial procedure. */
	helphelp = "1"b;				/* offer some help */
	go to kill;

logout_handler (10):
						/* disconnect command */
	if ^ute.at.disconnect_ok then do;
	     tcode = as_error_table_$no_perm_disc;	/* Error: No permission to disconnect */
	     call asu_$write_message (utep, as_error_table_$no_perm_disc,
		shxx, ignore_code);
	     call as_access_audit_$process (utep,
		-AS_AUDIT_PROCESS_DISCONNECT, (shxx));
	     ute.destroy_flag = WAIT_LOGOUT_HOLD;
	     goto kill_audit;
	end;
	if installation_parms.trusted_path_login then do;
	     tcode = as_error_table_$no_disc_hd;	/* Error: Cannot hold line after disconnect */
	end;
	else tcode = as_error_table_$disc_hd_msg;	/* Not an error msg, just information for user */
	go to logout_handler (20);

logout_handler (13):				/* new_proc -auth AUTH */
	ute.destroy_flag = WAIT_NEW_PROC;		/* always get new process */

	if ^have_cdte then do;			/* can't new_proc -auth in a disconnected process */
	     tcode = as_error_table_$illegal_new_proc;
	     goto kill;
	end;

	if ^aim_check_$in_range ((new_proc_auth.authorization), ute.process_authorization_range) then do;
illegal_new_proc: tcode = as_error_table_$illegal_new_proc; /* Can't go above max auth */
	     go to kill;				/* leave at old auth */
	end;

	if ^aim_check_$in_range ((new_proc_auth.authorization), cdte.access_class) then
	     go to illegal_new_proc;


	if installation_parms.trusted_path_login
	then if ^aim_check_$equal ((new_proc_auth.authorization), cdte.current_access_class (1)) then
		go to illegal_new_proc;
	     else ;
	else do;					/* ^trusted_path_login */
	     call initialize_current_access_class;	/* forget and relearn */
	     if cdte.current_access_class_valid		/* We know definitively */
	     then if ^aim_check_$equal ((new_proc_auth.authorization), cdte.current_access_class (1)) then /* so we must enforce */
		     go to illegal_new_proc;		/* still no dice */
		else ;
	     else do;				/* we are setting to whatever the user logs in as */
		/*** so we can switch auth to requested proc auth */
		cdte.current_access_class (*) = new_proc_auth.authorization;
		cdte.current_access_class_valid = "1"b;
	     end;
	end;

	ute.process_authorization = new_proc_auth.authorization; /* CHANGE AUTHORIZATION */
	userx = ute.whotabx;			/* find user's whotab entry */
	if userx ^= 0				/* if he has one */
	then whotab.e (userx).process_authorization = ute.process_authorization;

	go to kill;

logout_handler (14):				/* termsgnl */

/* ate.preempted says what to do here:
   -1 user unbumped after term signal sent
   0  user unbumped; ignore alarm___
   1  value internally used in load_ctl_
   2  user bumped; when alarm___ comes in, send term signal
   3  term signal sent; destroy process if termsgnl, alarm___, or cpulimit signals come in
   4  user bumped; process sick, so destroy without sending term signal
   5  trm_ signal sent, termsgnl received; (if still 3, we never got the termsgnl).
*/

	call timer_manager_$reset_alarm_wakeup (ute.event); /* turn off realtime limit */
	if ute.preempted = PREEMPT_UNBUMP then do;	/* unbumped just a little late */
	     tcode = as_error_table_$bump_cancelled;	/* apologize */
	     goto logout_handler (1);			/* give the guy a new process */
	end;
	else if ute.preempted = PREEMPT_TERM_SENT then do;/* sent term signal, expecting termsgnl */
	     ute.preempted = PREEMPT_TERMSGNL_RECEIVED;	/* remember that we're no longer waiting for termsgnl */
	     goto logout_handler (ute.logout_index);	/* go finish what we started to do */
	end;
	else do;					/* unexpected termsgnl */
	     call sys_log_ (SL_LOG_SILENT, "^a: Unexpected termsgnl for ^a.^a ^a (preempted=^a, ^d).",
		ME, ute.person, ute.project, ute.tty_name,
		PREEMPT_VALUES (ute.preempted), ute.preempted);
						/* tell sysprogs */
	     tcode = as_error_table_$illegal_signal;	/* complain to user */
	     goto logout_handler (1);			/* but give the guy a new process */
	end;

logout_handler (12):				/* inacrcvd */

	if (ute.preempted = PREEMPT_BUMPED & ute.activity_can_unbump) then do;
						/* user waiting on bump timer */
	     call asu_$reschedule_bump_timer (utep, installation_parms.warning_time);
	end;
	go to exit1;

/* User may not signal any of the functions below */

logout_handler (20):				/* hangup */

	if have_ate then				/* if we have an ate */
	     if ute.active = NOW_HAS_PROCESS		/* with a process */
		& ute.preempted <= PREEMPT_UNBUMP_IGNORE_ALARM then
						/* that's not already being destroyed */
		if ute.save_if_disconnected | (signal_type = "disconn" & ute.at.disconnect_ok) then do;
						/* that the user wants saved across hangups */

		     call asu_$suspend_process (utep);	/* try to save it */
		     ute.disconnected = "1"b;		/* remember that it's disconnected */
		     ute.disconnection_rel_minutes =
			divide (clock () - ute.login_time, USEC_PER_MINUTE, 17, 0);
		     if ute.whotabx > 0 then
			whotab.e (ute.whotabx).disconnected = "1"b;
						/* publish it */
		     ute.pdtep -> user.n_disconnected = /* increment count of user's disconnected processes */
			max (0, ute.pdtep -> user.n_disconnected + 1);
		     ute.channel = null;		/* and don't try to use the old cdte again for this process */
		     if cdte.state = TTY_DIALED then	/* if operator disconnect command */
			cdte.tra_vec = WAIT_HANGUP;
		     cdte.process = null;		/* also, don't let future channel operations affect the process */
		     if cdte.charge_type > 0 then	/* if we were charging for the channel */
			call device_acct_$off ((cdte.charge_type), cdte.name, utep); /* stop charging - it's hung up */

/**** When a process disconnects, we need two audit messages.  One, for
      the disconnect itself, in order to preserve CONNECT/DISCONNECT
      audit message consistency, and the other, for a LOGOUT message
      since the communications channel is no longer identified and
      authenticated. */

		     call as_access_audit_$process (utep,
			AS_AUDIT_PROCESS_DISCONNECT, "hangup"); /* Audit  the process disconnection */

		     call lg_ctl_$logout_no_process (utep, "disconnect");

		     code = 0;			/* nothing wrong with the channel */
		     if tcode = as_error_table_$disc_hd_msg then do;
			call grab_tty;
			call timer_manager_$reset_alarm_wakeup (cdte.event);
			cdte.in_use = NOW_DIALED;
			just_dialed_up = "1"b;
			say_hello = "1"b;
			call initialize_current_access_class;
			call set_tabs_and_modes (code);
			call ioa_$rs (convert_message (as_error_table_$disc_hd_msg), buff, i);
			call astty_$tty_force (cdtep, addr (buff), i, ignore_code);
			go to login;
		     end;

		     goto cleanup_hangup;		/* go clean up and listen on hung-up channel */
		end;

	if asu_$send_term_signal (utep, j) then		/* send a term signal if appropriate */
	     goto exit1;				/* if we did, wait for process to destroy itself */
	ute.destroy_flag = WAIT_LOGOUT;
	ute.logout_type = "hngp";			/* for audit message */
	goto kill;

logout_handler (21):				/* Shutdown */
	if asu_$send_term_signal (utep, j) then		/* send term signal if appropriate */
	     goto exit1;				/* if we did, wait for process to destroy itself */
	ute.destroy_flag = WAIT_LOGOUT;
	tcode = as_error_table_$shutdown;		/* Multics is shutting down. */
	go to kill;

logout_handler (22):				/* bump */
	if asu_$send_term_signal (utep, j) then		/* send term signal if appropriate */
	     goto exit1;				/* if we did, wait for process to destroy itself */
	ute.destroy_flag = WAIT_LOGOUT;
	tcode = as_error_table_$automatic_logout;	/* Automatic logout. */
	go to kill;

logout_handler (23):				/* alarm___ */

/* alarm___ can occur as a result of several conditions.
   Also, we can come here from the termsgnl handler if we sent term in response to alarm___.
   Sort it all out here.

   ***** CHECK FOR LEFT OVER ALARM AFTER PROCESS HAS BEEN DESTROYED
*/

	if funct = "alarm___" then do;		/* if really alarm rather than termsgnl */

/* TEMPORARY - NEEDS BETTER ERROR MESSAGES */

	     if ute.sus_sent & ^ute.suspended then do;	/* process ignored sus_ */
ignored_sus:					/* come here from cpulimit */
		call sys_log_ (SL_LOG, "^a: process ignored sus_ signal ^a.^a ^a",
		     ME, ute.person, ute.project, ute.tty_name);

		if asu_$send_term_signal (utep, 20) then goto exit1;
		ute.destroy_flag = WAIT_LOGOUT;
		goto kill;
	     end;

/* END TEMPORARY */
	     if ute.preempted <= PREEMPT_UNBUMP_IGNORE_ALARM then
						/* if user has been unbumped */
		goto exit1;			/* go away quietly */
	     else if (ute.preempted = PREEMPT_BUMPED & ute.activity_can_unbump) then do;
						/* see if user woke up */
		call act_ctl_$activity_unbump (utep, code);
		if code = 0 then do;		/* acceptably active */
		     call sys_log_ (SL_LOG, "^a: cancelling inactivity bump of ^a.^a", ME, ute.person, ute.project);
		     call convert_status_code_ (as_error_table_$activity_unbump, shxx, error_mess);
		     call send_mail ((error_mess));
		     go to logout_handler (25);	/* unbump */
		end;
	     end;
	     if asu_$send_term_signal (utep, j) then	/* send term signal if appropriate */
		goto exit1;			/* if we did, wait for process to destroy itself */
	     else if ute.preempted = PREEMPT_TERM_SENT then do;
						/* sent term and process failed to respond */
ignored_term:					/* come here if cpu timer runs out after term sent */
		ute.preempted = PREEMPT_TERMSGNL_RECEIVED;
						/* indicate that we're no longer waiting for termsgnl */
		call sys_log_ (SL_LOG, "^a: process ignored trm_ signal ^a.^a ^a", ME, ute.person, ute.project, ute.tty_name);
		if ute.logout_index = 23 then		/* if original objective was bump after X minutes */
		     goto bump_or_shut;		/* go do it */
		else goto logout_handler (ute.logout_index); /* go finish what we started to do */
	     end;
	end;

bump_or_shut:

	ute.destroy_flag = WAIT_LOGOUT;
	if anstbl.session = "shutdown" then tcode = as_error_table_$shutdown;
	else tcode = as_error_table_$automatic_logout;	/* Three minutes' grace expired. */
	go to kill;

logout_handler (24):				/* detach */
	if cdte.in_use < NOW_LOGGED_IN then		/* operator detach. someone on line? */
	     tcode = as_error_table_$detach;		/* No. Automatic detach. */
	else do;					/* Yes. Must destroy user. Automatic logout. */
	     if asu_$send_term_signal (utep, j) then	/* send term signal if appropriate */
		goto exit1;			/* if we did, wait for process to destroy itself */
	     tcode = as_error_table_$automatic_logout;
	end;
	if have_ate then
	     ute.destroy_flag = WAIT_DETACH;		/* After proc is destroyed, leave phone hung. */
	else cdte.tra_vec = WAIT_DETACH;		/* if no process, use cdte to remember what to do */
	go to kill;

logout_handler (25):				/* ("unbump") is operator cancelling a bump? */
	ute.activity_can_unbump = "0"b;		/* tidy up */
	if ute.preempted = PREEMPT_TERM_SENT then	/* if term signal sent before unbump */
	     ute.preempted = PREEMPT_UNBUMP;		/* remember that it happened */
	else ute.preempted = PREEMPT_UNBUMP_IGNORE_ALARM; /* else just cancel the bump */
	go to exit1;

logout_handler (26):				/* "stopstop"  Check for out-of-sequence signals. */
	call sys_log_ (SL_LOG_SILENT, "^a: premature stopstop for ^a.^a ^a",
	     ME, ute.person, ute.project, ute.tty_name);
	call hcs_$wakeup (anstbl.as_procid, ute.event, termstop_msg, code);
	call hcs_$wakeup (anstbl.as_procid, ute.event, STOPstop_msg, code);
	go to exit1;

logout_handler (28):				/* "termstop" */
	tcode = as_error_table_$no_signal;		/* Process terminated without signalling answering service. */
	if installation_parms.trusted_path_login then
	     ute.destroy_flag = WAIT_LOGOUT;		/* hangup channel */
	else ute.destroy_flag = WAIT_LOGOUT_HOLD;	/* hangup not needed */
	goto kill;

logout_handler (29):				/* cpulimit: Process used too much cpu time after sus_ or trm_ */
	if ute.ignore_cpulimit then do;		/* there's no way to turn of cpulimit timer */
	     ute.ignore_cpulimit = ""b;		/* except for this switch, which we now turn off */
	     goto exit1;				/* and go away quietly */
	end;

	call timer_manager_$reset_alarm_wakeup (ute.event); /* turn off realtime timer */

	if ute.preempted = PREEMPT_TERM_SENT then	/* if we had sent trm_ */
	     goto ignored_term;			/* go complain and kill process */
	else if ute.sus_sent then			/* or, if we had sent sus_ */
	     goto ignored_sus;			/* likewise, complain and kill process */
	else goto fals;				/* otherwise, log and ignore this unexpected signal */


logout_handler (4):					/* Standard logout. */
logout_handler (11):				/* Unused. Treat as logout. */
logout_handler (15):				/* Unused. Treat as logout. */
logout_handler (16):				/* Unused. Treat as logout. */
logout_handler (17):				/* Unused. Treat as logout. */
logout_handler (18):				/* Unused. Treat as logout. */
logout_handler (19):				/* Unused. Treat as logout. */
	ute.destroy_flag = WAIT_LOGOUT;

kill:

	if have_ate then do;			/* if there is an answer table entry for this channel */

/**** The following check turns off the real-time timer which was set
      if this process was bumped.  If this is not disabled, then we
      log an "ignored alarm___" message when the alarm goes off.  Also,
      if the ute is reused, then the poor user whose ute it is will be
      bumped.  We do not do this, however, if the user is new_proc'ing.
      Otherwise, we would allow him/her to escape a bump command. */

	     if ute.preempted = PREEMPT_BUMPED &	/* awaiting bump */
		ute.destroy_flag ^= WAIT_NEW_PROC then	/* not new_proc */
		call timer_manager_$reset_alarm_wakeup (ute.event); /* disable the realtime timer */

	     if ute.preempted = PREEMPT_TERM_SENT then do;/* if we were waiting for termsgnl and never got it */
		call sys_log_ (SL_LOG_SILENT, "^a: process did not respond properly to trm_ signal. ^a.^a ^a",
		     ME, ute.person, ute.project, ute.tty_name);
		if ute.logout_index ^= 27 &		/* if original objective was other than terminate */
		     ute.logout_index ^= 2 then	/* or connect new_proc */
		     if ute.destroy_flag = WAIT_NEW_PROC then /* if response was f.p.e or newproc */
						/* don't allow tricky user to get out of being bumped */
			if ute.logout_index = 24 then /* put back the original objective */
			     ute.destroy_flag = WAIT_DETACH;
			else ute.destroy_flag = WAIT_LOGOUT;
	     end;

	     if ute.active = NOW_HAS_PROCESS then	/* if user has a process then destroy it */
		call dpg_ (utep, (funct));

	     if have_cdte then			/* if we have a cdte also */
		cdte.tra_vec = ute.destroy_flag;	/* tell cdte what we're about to do to the ate */
	end;					/* end have ate */

	if have_cdte then do;			/* if we have a cdte */

	     call grab_tty;				/* Take over the typewriter */

	     if tcode ^= 0 then call asu_$write_chn_message (cdtep, tcode, shxx, ignore_code);
	     if i > 0 then call astty_$tty_force (cdtep, addr (buff), i, ignore_code);
						/* Write nice message if process terminated. */

	     if helphelp then			/* if user is having fatal process error problems */
		call asu_$write_chn_message (cdtep, as_error_table_$ask_for_help, shxx, ignore_code); /* offer help */

	     if cdte.charge_type > 0 then
		if have_ate then			/* don't try to turn off charging if no user owns device */
		     call device_acct_$off ((cdte.charge_type), cdte.name, utep);

	     i = 0;				/* Don't print twice. */

	     if cdte.in_use < NOW_LOGGED_IN then goto process_destroyed; /* if no process to destroy, don't try */
	     if cdte.in_use = NOW_LOGGED_IN then go to process_stopped; /* Do we need to wait for a process to die? */
	     if cdte.in_use > NOW_LOGGED_IN then goto exit1; /* wait for process to be stopped by ring zero */

	end;					/* end have cdte */

/* If we get here, we don't have a cdte */

	if ute.active = NOW_LOGGED_IN then goto process_stopped;
	if ute.active > NOW_LOGGED_IN then goto exit1;	/* wait for ring zero to stop process */

/* If we get here, there's a bug */

	call sys_log_ (SL_LOG_BEEP, "^a: cdtep = null and ate.active = ^d for ^p", ME, ute.active, utep);
	goto exit1;				/* what else should we do? */

/* Return here when the process has had a chance to run and destroy itself.
   Call accounting to log him out completely, get his channel back, type nice messages. */

hand (9):						/* WAIT_LOGOUT */
hand (10):					/* WAIT_LOGOUT_HOLD */
hand (11):					/* WAIT_DETACH */
hand (12):					/* WAIT_NEW_PROC */
hand (13):					/* WAIT_REMOVE */
hand (20):					/* WAIT_DELETE_CHANNEL */

	if wakeup_from_user then go to fals0;		/* User cannot send this. */
	if signal_type ^= "STOPstop" then
	     if signal_type ^= "stopstop" then do;	/* we're waiting for a stopstop, and this isn't one */

		if signal_type = "device" then
		     goto fals0;			/* worse-than-useless signal from network */

/**** The following code fragment checks for an operator "detach" command
      after the channel has already been detached and is hung up. */

		if wakeup_from_as & signal_type = "detach" then
		     if have_cdte then
			if cdte.in_use = NOW_HUNG_UP then
			     goto exit1;		/* ignore detach attempt */

		if asu_$check_for_stopped_process (utep, ME) then /* if process is stopped */
		     goto process_stopped;		/* the stopstop wakeup must have been lost */
		else goto fals0;			/* process not stopped; log and ignore this wakeup */
	     end;

process_stopped:

	call dpg_$finish (utep);
	call act_ctl_$dp (utep);
	ute.active = NOW_LOGGED_IN;			/* No process any more. */
	if have_cdte then
	     cdte.in_use = NOW_LOGGED_IN;
	i = 0;
	if ute.destroy_flag ^= WAIT_NEW_PROC then do;	/* Unless a new_proc, log him out. */
	     call act_ctl_$close_account (utep);	/* Close account and print logged out msg to opr */
	     call lg_ctl_$logout (utep);

	     if ^have_cdte then goto process_destroyed;	/* if no cdte, skip the following channel stuff */

	     if cdte.tra_vec = WAIT_DELETE_CHANNEL then do; /* channel was deleted by CDT installation */
		cdte.in_use = CHANNEL_DELETED;	/* but we had to keep it long enough to destroy the process */
		cdte.tra_vec = WAIT_HANGUP;		/* ignore all wakeups */
		cdte.current_service_type = INACTIVE;	/* INACTIVE */
		goto exit1;			/* now we can mark it deleted and get out */
	     end;

	     if cdte.tra_vec = WAIT_REMOVE then do;	/* we hung up the channel before destroying the process */
		cdte.in_use = NOW_HUNG_UP;		/* line will be ignored until ATTACHed or CDT installed */
		go to exit1;			/* we quit before trying to print message, listen, etc. */
	     end;
	     if ^ute.login_flags.noprint then do;	/* If logout message will be needed. */
		i = float (ute.cpu_usage, 63) / 1e6 + .5e0; /* convert usec to sec, rounded */
		j = divide (i, 60, 17, 0);		/* j= number of usage minutes */
		i = i - j * 60;			/* i= mod (usage, minutes)  */
		t1 = float (ute.mem_usage, 63) / 1e3;	/* Get memory usage. */
		date_time = date_time_$format ("date_time", anstbl.current_time, "", "");
		if j > 0 then			/* Use different message if there were minutes. */
		     call ioa_$rs (logout_fmt, buff, i, ute.person, ute.project, date_time, j, i, t1, ute.session_cost);
		else call ioa_$rs (logout_fmt1, buff, i, ute.person, ute.project, date_time, i, t1, ute.session_cost);
	     end;
	end;

process_destroyed:
	if ^have_cdte then do;			/* if no cdte, we just destroyed a disconnected process */
	     call unlock;				/* so clean up the way listen_again (below) does */
	     call user_table_mgr_$free (utep);		/* imitate a little bit of asu_$release_ate */
	     goto exit1;				/* and then get out quickly */
	end;


	call astty_$tty_state (cdtep, code);		/* Verify that user has not hung up. */
	if code ^= 0 then go to cleanup_hangup;		/* random error */
	if cdte.state < TTY_DIALED then go to cleanup_hangup; /* Is tty hung up already? */

	if i > 0 then				/* Do we have logout message? */
	     if ^ute.login_flags.noprint then do;	/* User want messages? */
		call astty_$tty_force (cdtep, addr (buff), i, code); /* write logout message */
		if code ^= 0 then go to cleanup_hangup;
	     end;

	call update_term_info ();			/* go get the latest about the term */

	if cdte.tra_vec = WAIT_LOGOUT_HOLD then do;	/* Was logout hold, type "users" message. */
	     call timer_manager_$reset_alarm_wakeup (cdte.event);
	     if ute.login_flags.noprint then say_hello = "0"b;
	     else say_hello = "1"b;
	     just_dialed_up = "0"b;
	     call free_ute;				/* we'll get a new one if we must */
	     call initialize_current_access_class;
	     cdte.in_use = NOW_DIALED;
	     go to login;
	end;
	else if cdte.tra_vec = WAIT_NEW_PROC then go to create; /* Make new process as result of term or new_proc */

	cdte.in_use = NOW_DIALED;			/* No user any more. */

/* Hang up the terminal, and set up to listen for next dialup (unless detach) */

listen_again:
timeout (1):
timeout (8):
timeout (9):
timeout (10):
timeout (11):
timeout (12):
timeout (13):
timeout (14):
timeout (15):
	call unlock;				/* release answer table, permit updates */
	call free_ute;
	call timer_manager_$reset_alarm_wakeup (cdte.event);
	call ipc_$drain_chn (cdte.event, code);		/* .. he's got no future */

/**** * NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE * ****/
/**** *					  * ****/
/**** * The following tests should be replaced by    * ****/
/**** * code that classifies a wakeup as a hangup    * ****/
/**** * wakeup, rather than taking an error          * ****/
/**** * elsewhere.				  * ****/

	if cdte.state = TTY_DIALED then do;		/* If he's still there, tell him hang is on purpose */
	     call turn_printer_on (ignore_code);
	     if tcode = as_error_table_$no_disc_hd then do;
		call ioa_$rs (convert_message (as_error_table_$no_disc_hd), buff, i);
		call astty_$tty_force (cdtep, addr (buff), i, ignore_code);
	     end;
	     else call astty_$tty_force (cdtep, addr (hangup_msg), hangup_msg_lth, ignore_code);

/* Don't order the hangup until all the output is finished printing. */

	     cdte.detach_after_hangup = (cdte.tra_vec = WAIT_DETACH); /* remember if detaching */
	     cdte.tra_vec = WAIT_BEFORE_HANGUP;
hand (25):					/* WAIT_BEFORE_HANGUP */
	     call timer_manager_$reset_alarm_wakeup (cdte.event); /* we don't know if we got a timer or an output complete */
	     call ipc_$drain_chn (cdte.event, code);	/* so we'll clear out both, to avoid an extraneous wakeup */
	     write_status_info.output_pending = ""b;
	     call astty_$tty_order (cdtep, "write_status", addr (write_status_info), code);

	     if code ^= 0 then			/* FOR DEBUGGING */
		if loudsw then do;			/* only if tracing is on */
		     if ^loud_select_sw		/* if tracing all channels */
			| substr (cdte.name, 1, length (loud_select_channel)) = loud_select_channel /* or tracing this one */
		     then call sys_log_$error_log (SL_LOG, code, ME, "From write_status order on ^a", cdte.name);
		end;				/* END DEBUGGING CODE */
						/* Note that the write_status order might fail legitimately,
						   if the dim doesn't support it; that's not a real error. */
	     if code = 0 then			/* if write status order worked */
		if write_status_info.output_pending then do; /* and there's stuff yet to be printed */
		     call timer_manager_$alarm_wakeup (10, "11"b, cdte.event); /* set 10 second timer, since we don't
						   always get a wakeup when output is complete */
		     goto exit1;			/* don't hang up until it's all done */
		end;				/* we'll get a wakeup when it's done */
	     if cdte.detach_after_hangup then		/* if we were detaching the channel */
		cdte.tra_vec = WAIT_DETACH;		/* put back the proper tra_vec value */

	     call astty_$tty_order (cdtep, "hangup", null, ignore_code); /* also clears modes & flags in ttydim */
	     cdte.in_use = NOW_HUNG_UP;		/* keep our records straight */
	end;

	if cdte.in_use > NOW_LISTENING then do;		/* TRAP BUG where state and in_use get inconsistent */
	     call sys_log_ (SL_LOG_SILENT, "^a: cdte ^p (^a) state ^d in use ^d - notify system programmer",
		ME, cdtep, cdte.name, cdte.state, cdte.in_use);
	     cdte.in_use = NOW_HUNG_UP;		/* to avoid losing the channel */
	end;

	cdte.dialed_up_time = cdte.dialed_up_time +	/* Compute running total, in seconds */
	     float (anstbl.current_time - cdte.dialup_time, 63) / 1e6 + .5e0;

	if cdte.tra_vec ^= WAIT_DETACH then do;		/* If operator wants this tty detached, omit the listen  */
	     call astty_$tty_state (cdtep, code);	/* We want the channel back again */
	     if cdte.state = TTY_DIALED then		/* Still dialed, wait for hangup to happen */
		cdte.tra_vec = WAIT_HANGUP;		/* hand(17) does listen after hangup wakeup, ignores others */
	     else do;				/* channel is already hung up */
		call ipc_$drain_chn (cdte.event, code); /* so discard the hangup wakeup, which would
						   just confuse us if it came along later */
		if ^sc_stat_$shutdown_typed then	/* if not shutting down */
		     if cdte.state ^= TTY_MASKED then
			call asu_$asu_listen (cdtep, code); /* Turn on channel again. Reset CDTE */
	     end;
	end;
	go to exit1;
%page;
/* Come here if cannot write fatal process error message, or if user
   hangs up during a new_proc */

cleanup_hangup:
	if cdte.tra_vec = WAIT_NEW_PROC then do;	/* were we going to give a new process? */
	     call act_ctl_$close_account (utep);	/* close account & log logout */
	     call lg_ctl_$logout (utep);		/* remove user from whotab */
	end;

/* If the error was caused by an FNP crash, the cdte could be in any state,
   and asu_listen will quit before fixing it up - so we fix it up a little, here */

	call astty_$tty_order (cdtep, "hangup", null, ignore_code); /* be sure of hangup, and set cdte.state */
	cdte.in_use = NOW_HUNG_UP;			/* or it will be, real soon */

	if code = 0 then go to listen_again;		/* just a hangup, do normal reset */
	go to chn_error;				/* some other error, bomb out */

%page;
/* Come here if any call to astty_ returns a non-zero code */
/* If -1 (hangup) is always returned when the FNP has gone down, then there is no problem -
   otherwise, FNP crashes will result in channels being removed, which we don't want */

chn_error:
	if channel_error () then go to exit1;
	else go to listen_again;

/* come here when something goes wrong with the tty channel which can
   probably be blamed on something the user did.  For example, typing in
   an outrageous answerback, or causes some invalid combination of modes and
   line types. */

chn_user_error:
	call convert_status_code_ (code, shxx, error_mess); /* tell user 'what' went wrong */
	call ioa_$rs ("Error during initialization or while processing last pre-access command:^/ ^a", buff, i, error_mess);
	call print_buff;
	go to try_again;				/* count offences and proceed */

ttt_error:
	call remove_channel ("ttt");
	go to exit1;

/* Come here in case of fault during login or logout. */

abort:	static_label = exit;			/* so as not to loop */
	if utep = null then go to listen_again;		/* not much to do */
	funct = "ucs     ";
	ute.destroy_flag = WAIT_LOGOUT_HOLD;		/* pretend logout hold */
	if have_cdte then
	     cdte.tra_vec = WAIT_LOGOUT_HOLD;		/* make cdte tra_vec equal the one in ate */
	ute.logout_type = "ucs ";
	ute.login_flags.noprint = "0"b;
	tcode = as_error_table_$dialup_error;
	i = 0;					/* Buff is empty */
	go to kill;
%page;
evil3:	call sys_log_ (SL_LOG_BEEP, "^a: called with null message ptr", ME);
	goto return_immediately;			/* metering was not turned on */

evil2:	call sys_log_ (SL_LOG_BEEP, "^a: called while ansp = null", ME);
	goto return_immediately;			/* metering was not turned on */

evil1:	call sys_log_ (SL_LOG_BEEP, "^a: called with bad ptr ^p by ^w", ME, ev_msg.data_ptr, ev_msg.fromproc);
	goto exit1;				/* metering was on; go turn it off before returning */

evil:	call asu_$find_process (ev_msg.fromproc, i, q);	/* find out who sent signal */
	if q ^= null then do;
	     call get_trace_info;
	     call sys_log_ (SL_LOG_BEEP, "^a: ignored ^a from ^a.^a for ^a st=^d,inuse=^d,tv=^d",
		ME, tsignal_type, q -> ute.person, q -> ute.project, tname, tstate, tinuse, ttv);
	     goto exit1;				/* metering was turned on so go turn it off */
	end;					/* can't find process; fall thru and print a different message */
fals:	i = SL_LOG_BEEP;				/* print with alarm */
falsi:	call get_trace_info;
	call sys_log_ (i, "^a: ignored ^a for ^a st=^d,inuse=^d,tv=^d",
	     ME, tsignal_type, tname, tstate, tinuse, ttv);
	goto exit1;				/* metering was turned on, so go turn it off */
fals0:	i = SL_LOG_SILENT;				/* just log */
	goto falsi;
%page;

/* Come here when a channel (terminal) that has been requested by a user
   process finally dials up. TTYDIM won't let us connect it to user unless
   it is actually dialed up. */

hand (14):					/* WAIT_FIN_PRIV_ATTACH */
	call astty_$tty_state (cdtep, code);		/* get current state of channel */
	if cdte.state = TTY_DIALED then do;
	     call initialize_current_access_class;
	     call dial_ctl_$finish_priv_attach (cdtep);	/* do the work */
	end;
	else if cdte.state <= TTY_HUNG then do;		/* up and then down too fast for us */
	     call ipc_$drain_chn (cdte.event, code);	/* get rid of any dross */
	     if ^sc_stat_$shutdown_typed then
		if cdte.state ^= TTY_MASKED then
		     call asu_$asu_listen (cdtep, code);/* turn on channel again. Reset CDTE */
	end;
	go to exit1;

/* Next section of code takes care of dialed consoles' events */

hand (15):					/* WAIT_DIAL_RELEASE */
	call astty_$tty_state (cdtep, code);		/* get current state of channel */
	if cdte.state > TTY_HUNG then go to exit1;	/* wait for correct event */
	call dial_ctl_$dial_term (cdtep);		/* Reset CDTE & tell master */
	go to exit1;				/* All done. */

/* This code handles completion of auto_call dialing */

hand (16):					/* WAIT_DIAL_OUT */
	call dial_ctl_$finish_dial_out (cdtep);		/* That's all folks! */
	go to exit1;

/* This code handles waiting for the hangup event to occur. When */
/* it does, we will listen to the channel */

hand (17):					/* WAIT_HANGUP */
	call astty_$tty_state (cdtep, code);		/* get current state of channel */
	if cdte.state > TTY_HUNG then go to exit1;	/* wait for correct event */

	if ^sc_stat_$shutdown_typed			/* if we're not shutting down */
	     & cdte.in_use ^= CHANNEL_DELETED		/* or being deconfigured */
	     & (cdte.current_service_type = ANS_SERVICE | /* and this is still live */
	     cdte.current_service_type = SLAVE_SERVICE)
	then if cdte.state ^= TTY_MASKED
	     then call asu_$asu_listen (cdtep, code);	/* ready for use, reconnect to channel */
/**** * This will swallow all wakeups for channel from now on. */
	go to exit1;

/* This code handles wakeups for slave service channels before anyone has asked
   for them. It just ignores the wakeups */

hand (18):					/* WAIT_SLAVE_REQUEST */
	go to hand (17);				/* go discard all wakeups except hangups */

/* This code allows a procedure other than dialup_ to invite a user to log in
   on an already dialed up channel. It is used by dial_ctl_$dial_broom, when
   the master process of a dialed channel terminates. That procedure sets
   cdte.tra_vec to WAIT_GREETING_MSG and sends a wakeup with "device" as a
   message */

hand (19):					/* WAIT_GREETING_MSG */
	call grab_tty;				/* make sure we can read and write on the channel */
	say_hello = "1"b;
	just_dialed_up = ""b;
	cdte.in_use = NOW_DIALED;
	goto login;

/* Come here when a channel that has been requested for T & D attachment hangs up. It must be hung up and not listening
   in order for the attachment to continue. */

hand (22):					/* WAIT_TANDD_HANGUP */
	call astty_$tty_state (cdtep, code);		/* get current state of channel */
	if cdte.state > TTY_HUNG then go to exit1;	/* wait for correct event */
	call dial_ctl_$continue_tandd_attach (cdtep);	/* do the work */
	go to exit1;

/* Come here when a channel that has been requested for T & D attachment signals dialup.
   This is a simulated dialup that allows the attaching process to communicate with the
   channel in a normal fashion. */

hand (23):					/* WAIT_FIN_TANDD_ATTACH */
	call astty_$tty_state (cdtep, code);
	if cdte.state ^= TTY_DIALED then go to exit1;	/* wait for correct event */
	call initialize_current_access_class;
	call dial_ctl_$finish_tandd_attach (cdtep);	/* if so, process it */
	go to exit1;

/* Come here when changes in a channel's state are uninteresting -- it is not available for use until the master
   process lets go of it. */

hand (24):					/* WAIT_DISCARD_WAKEUPS */
	go to exit1;				/* really just discard it */
%page;

/**** INTERNAL PROCEDURES, IN ALPHA ORDER BY NAME.
      keep it that way! --bim */

change_type: proc (new_type, do_tabs, do_init, code);

dcl  new_type char (*);
dcl  do_tabs bit (1);
dcl  do_init bit (1);
dcl  code fixed bin (35);

	set_type_info.version = stti_version_1;
	set_type_info.name = new_type;
	string (set_type_info.flags) = "0"b;
	call astty_$tty_order (cdtep, "set_term_type", addr (set_type_info), code);
	if code ^= 0 then return;

	call ttt_info_$dialup_flags (new_type, cdte.dialup_flags.ppm, cdte.dialup_flags.cpo, code);
	if code ^= 0 then return;

	cdte.current_terminal_type = new_type;
	if ^do_tabs then return;
	if do_init then call set_tabs_and_modes (code);	/* Reset options for new type. */
	else call set_tabs_and_modes_gently (code);

     end change_type;
%page;
channel_error: proc returns (bit (1) aligned);		/* "1"b if a real error happened */
	call astty_$tty_state (cdtep, (0));		/* Make sure we dont remove a merely hung-up terminal */
	if code = -1 then do;			/* code = -1 means "it hung up." */
						/* even if it comes right back we should process that putative */
						/* hangup. */
						/* We trust that ring 0 or mpx_mgr_ will send us a hangup note */
						/* to clean up this mess. */
	     cdte.in_use = NOW_HUNG_UP;		/* keep cdte consistent */
	     return ("0"b);
	end;
	if code = 0 & cdte.state = TTY_DIALED		/* code bug */
	then do;
	     call sys_log_ (SL_LOG, "^a: channel_error called with cdte in functional state.", ME);
	     return ("0"b);
	end;
	call remove_channel ("tty_dim");
	return ("1"b);
     end;
%page;
convert_message: proc (p_status_code) returns (char (100) varying);

declare  p_status_code fixed binary (35) parameter;

declare  short character (8) aligned automatic,
         long character (100) aligned automatic;

	call convert_status_code_ (p_status_code, short, long);

	return (rtrim (long, " "));

     end convert_message;
%page;
DISPLAY_PROCESS_AUTHORIZATION:
     procedure ();

/* This procedure displays the "Your authorization is ..." message on the
   interactive user's terminal upon process creation and reconnection. */

dcl  authorization_string char (200) automatic;
dcl  code fixed bin (35) automatic;
dcl  format char (100) aligned automatic;
dcl  line char (200) automatic;
dcl  line_lth fixed bin automatic;

	call convert_access_class_$to_string (ute.process_authorization,
	     authorization_string, code);
	if code ^= 0 then
	     if code = error_table_$smallarg then ;	/* we'll use what we can */
	     else authorization_string = "Unknown";

	if authorization_string ^= "" then do;
	     call convert_status_code_ (as_error_table_$login_auth_msg,
		(""), format);
	     if format ^= "" then do;
		call ioa_$rs (format, line, line_lth,
		     authorization_string);
		call astty_$tty_force ((ute.channel), addr (line),
		     line_lth, (0));
	     end;
	end;

     end DISPLAY_PROCESS_AUTHORIZATION;
%page;
free_ute: proc;

	call asu_$release_ate (cdtep, code);		/* Free the ATE */
	utep = null;
	have_ate = ""b;
     end;
%page;
get_next_disc_ate_jkp: proc;

/* This procedure gets the next disconnected ate in a disconnected list, and checks the list for consistency.
   Global variables j, k, and p are implied arguments. j is the position in the list (input),
   and k and p are the ate index, and pointer, respectively, of the next ate in the list (output). */

	if j = 1 then
	     k = cdte.disconnected_ate_index;
	else k = p -> ute.next_disconnected_ate_index;
	if k <= 0 | k > anstbl.current_size then do;
	     call sys_log_ (SL_LOG, "^a: program error: disconnected ate index no. ^d for ^a.^a is ^d",
		ME, j, ute.person, ute.project, k);
	     goto abort;
	end;
	p = addr (anstbl.entry (k));			/* get ptr to next ate in list */

	if ^p -> ute.disconnected			/* if ate is not disconnected */
	     | ^(p -> ute.person = ute.person		/* or doesn't belong to this user */
	     & p -> ute.project = ute.project)
	     | ^(p -> ute.active = NOW_HAS_PROCESS)	/* or doesn't have a live process */
	then do;					/* inform user, and logout -hold */
	     call ioa_$rs ("Your disconnected process^x^[#^d^x^;^s^]has changed state unexpectedly;
it may have been bumped or connected to another terminal.",
		buff, i, (cdte.n_disconnected_procs > 1), j);
	     call print_buff;
	     logout_hold = "1"b;
	     goto log_disconnected_user_out;
	end;
	return;

     end get_next_disc_ate_jkp;
%page;
get_trace_info: proc;				/* format information for printing,
						   either in trace or error message */

dcl  i fixed bin;
dcl  o_sw bit (1);					/* says whether to print msg in octal or character */
dcl  char8 char (8);


/* First, format the contents of the wakeup message, in ASCII, octal, or both */

	char8 = "........";
	o_sw = "0"b;				/* assume character */
	do i = 1 to length (signal_type);		/* check each character */
	     if unspec (substr (signal_type, i, 1)) < "040"b3 |
		unspec (substr (signal_type, i, 1)) > "176"b3 then
		o_sw = "1"b;			/* if nonprinting char, remember to print in octal */
	     else substr (char8, i, 1) = substr (signal_type, i, 1); /* copy printing char into ASCII string */
	end;
	call ioa_$rsnnl ("^[""^a""^x^;^s^]^[(^w ^w)^;^2s^]", tsignal_type, (0), (char8 ^= "........"), char8, o_sw,
	     substr (unspec (signal_type), 1, 36), substr (unspec (signal_type), 37, 36));

/* Then get state information from either the cdte or ate (whichever we have) or maybe both */

	if wakeup_for_channel & cdtep ^= null then do;	/* if wakeup came in over a cdte channel */
	     tname = rtrim (cdte.name);
	     if utep ^= null then
		tname = tname || " (" || rtrim (ute.person) || "." || rtrim (ute.project) || ")";
	     tanswb = cdte.tty_id_code;
	     tstate = cdte.state;
	     ttv = cdte.tra_vec;
	     tinuse = cdte.in_use;
	end;

	else if wakeup_for_process & utep ^= null then do;/* or, if it came in over an ate channel */
	     tname = rtrim (ute.person) || "." || rtrim (ute.project); /* construct an informative name */
	     if cdtep ^= null then do;		/* if we have a cdte, get more debugging info */
		tname = tname || " (" || rtrim (cdte.name) || ")";
		tstate = cdte.state;
	     end;
	     else do;
		tname = tname || " (" || rtrim (ute.tty_name) || ")";
		tstate = 0;			/* no channel state info in ate */
	     end;
	     tanswb = ute.tty_id_code;		/* a copy of cdte.tty_id_code */
	     ttv = ute.destroy_flag;			/* a copy of cdte.tra_vec */
	     tinuse = ute.active;			/* a copy of cdte.in_use */
	end;

	else do;					/* should never happen, but be cautious */
	     tname = "???";
	     tanswb = "";
	     tstate, tinuse, ttv = 0;
	end;
	return;

     end get_trace_info;
%page;
grab_tty: proc;

/* Internal procedure to assign a channel back to the answering service so
   we can talk to it.  It must always work, so we ignore any codes which
   might indicate errors or hangups */

	call astty_$tty_order (cdtep, "quit_disable", null, ignore_code);
	call astty_$tty_event (cdtep, ignore_code);	/* Set read terminations to come to me */
	call turn_printer_on (ignore_code);

     end grab_tty;
%page;
grab_ute: proc;
	call asu_$attach_ate (cdtep, code);		/* allocate user table entry */
	if code ^= 0 then do;
	     call sys_log_$error_log (SL_LOG, code, ME, "attempting to allocate a user table entry for ^a", cdte.name);
	     if code = as_error_table_$tty_no_room then do; /* if answer table is full */
		call sys_log_ (SL_LOG, "^a: The answer table is full (^d entries).", ME, anstbl.max_size);
		code = as_error_table_$sys_full;	/* don't burden user with details, just say "System full." */
	     end;
	     call asu_$write_chn_message (cdtep, code, shxx, ignore_code);
	     if ignore_code ^= 0 then goto chn_error;	/* don't really ignore the code */
	     goto listen_again;			/* go hang up and listen - no use saying please try again */
	end;
	utep = cdte.process;			/* copy ptr to ate that we just got */
	have_ate = "1"b;				/* and tell everyone else that it's ok to reference the ate */
     end;
%page;
hello: proc (leading_NLs);				/* returns code from write_force */

dcl  leading_NLs fixed bin;
dcl  special_msg_fmt char (5) static options (constant) init ("^v/^a");
dcl  special_message char (anstbl.message_lng) based (addr (anstbl.special_message));

	if anstbl.message_lng > 0 | leading_NLs > 0 then do; /* Any special flash for all users? */
	     call ioa_$rsnnl (special_msg_fmt, buff, i, leading_NLs, special_message); /* already have NL */
	     call astty_$tty_force (cdtep, addr (buff), i, code);
	     if code ^= 0 then return;		/* Lay it on them */
	end;
	t1 = anstbl.n_units / 10.0e0;			/* format load message */
	t2 = anstbl.max_units / 10.0e0;		/* ... */
	date_time = date_time_$format ("date_time", anstbl.current_time, "", "");
	call ioa_$rs (greeting_fmt, buff, i, whotab.sysid, installation_parms.installation_id, cdte.name,
	     t1, t2, anstbl.n_users, date_time);
	call astty_$tty_force (cdtep, addr (buff), i, code);
     end hello;
%page;

initialize_current_access_class: procedure;

declare  1 tac aligned like tty_access_class;

	call asu_$reset_access_class (cdtep);
	if ^cdte.current_access_class_valid then do;
	     unspec (tac) = ""b;
	     call astty_$tty_order (cdtep, "get_required_access_class",
		addr (tac), code);
	     if code = 0 & tac.access_class_set then do;
		cdte.current_access_class_valid = "1"b;
		cdte.current_access_class = tac.access_class;
	     end;
	     else if code = 0 | code = error_table_$undefined_order_request /* noonme set it, or this MPX dosen't grok */
	     then ;				/* leave cdte as is, leave it to lg_ctl_ and dial_ctl_ */
						/* to notice that the access class is undetermined. */
	     else do;
		call sys_log_$error_log (SL_LOG, code, ME, "get_required_access_class order failed for ^a", cdte.name);
		go to chn_error;
	     end;
	end;
	return;
     end initialize_current_access_class;
%page;
lock: procedure;

	ute.lock_value = ute.lock_value + 1;
	anstbl.lock_count = anstbl.lock_count + 1;

	return;

     end lock;
%page;

print_access_class: procedure;			/* prints a banner line */

	if cdte.current_access_class_valid
	then call print_access_class_ (cdte.current_access_class);
	else call print_access_class_ (cdte.access_class);
	return;

print_access_class_:
	procedure (range);

declare  range (2) bit (72) aligned;
declare  c_a_c char (500);
	     call convert_authorization_$to_string_range (range, c_a_c, code);
	     if code = 0 then call print_ascii_msg (as_error_table_$aclass_banner_msg, c_a_c);
	     return;
	end print_access_class_;
     end print_access_class;

print_ascii_msg: proc (a_code, a_string);

dcl  a_code fixed bin (35);
dcl  a_string char (*);

	call ioa_$rs (convert_message (a_code), buff, i, a_string);
	call print_buff;
	return;

     end print_ascii_msg;
%page;
print_buff: proc;					/* replaces dozens of copies of these two lines */

	call astty_$tty_force (cdtep, addr (buff), i, code);
	if code ^= 0 then goto chn_error;
	return;

     end print_buff;
%page;
print_help: proc (ename);

dcl  ename char (*);

dcl  segp ptr init (null);
dcl  segl fixed bin;
dcl  seg char (segl) based (segp);

	call hcs_$initiate_count (anstbl.sysdir, (ename), "", segl, (0), segp, code);
	if segp = null then do;
	     call sys_log_$error_log (SL_LOG_BEEP, code, ME,
		"Getting pointer to help file, ^a>^a",
		anstbl.sysdir, ename);
	     call ioa_$rs ("^a ^a>^a", buff, i, convert_message (code), anstbl.sysdir, ename);
	     call astty_$tty_force (cdtep, addr (buff), i, code);
	     if code ^= 0 then goto chn_error;
	end;
	else do;
	     segl = divide (segl, 9, 17, 0);		/* get length in characters */

	     do i = 1 repeat i + j while (i < segl);	/* Write one line at a time of help file */
		j = index (substr (seg, i), NL);	/* Scan for end of line. */
		if j = 0 then j = segl - i + 1;	/* if last newline missing, print what's there */
		call astty_$tty_force (cdtep, addr (substr (seg, i, 1)), j, code);
		if code ^= 0 then go to chn_error;
	     end;
	     call astty_$tty_force (cdtep, addr (NL), length (NL), code); /* put out a blank line */
	     if code ^= 0 then goto chn_error;
	     call hcs_$terminate_noname (segp, code);
	end;

	return;

     end print_help;
%page;
print_logged_out: proc;

	date_time = date_time_$format ("date_time", anstbl.current_time, "", "");
	call ioa_$rs (convert_message (as_error_table_$logout_disconnected_msg), buff, i,
	     ute.person, ute.project, date_time);
	call print_buff;

	call lg_ctl_$logout_no_process (utep, "logout, no process");
	return;

     end print_logged_out;
%page;
remove_channel: proc (err_type);

dcl  err_type char (*);

	call sys_log_$error_log (SL_LOG_BEEP, code, ME, "^a error, removing channel ^a ^a",
	     err_type, cdte.name, cdte.comment);
	call unlock;				/* release answer table, permit updates */
	call free_ute;				/* Free the UTE */
	call timer_manager_$reset_alarm_wakeup (cdte.event);
	call asu_$asu_remove (cdtep);
     end;
%page;
send_mail:
     proc (message);

dcl  message char (*);

dcl  user_id char (32);

	if utep = null
	then return;				/* can't do anything */
	user_id = rtrim (ute.person) || ".";		/* build Person.Project */
	user_id = rtrim (user_id) || ute.project;
	unspec (send_mail_info) = "0"b;
	send_mail_info.version = send_mail_info_version_2;
	send_mail_info.wakeup = "1"b;
	send_mail_info.always_add = "1"b;
	send_mail_info.sent_from = "answering service";

	call send_mail_$access_class (user_id, message, addr (send_mail_info), ute.process_authorization, code);
	if code ^= 0 & code ^= error_table_$messages_deferred & code ^= error_table_$messages_off
	then call sys_log_$error_log (SL_LOG_SILENT, code, ME, "when attempting to notify user ^a of dialup event", user_id);
	return;

     end send_mail;
%page;
set_tabs_and_modes: procedure (bv_tabs_code);

declare  bv_tabs_code fixed bin (35) parameter;

dcl  init_sw bit (1) init ("1"b);

join:	if cdte.cur_line_type ^= LINE_TELNET		/* this isn't the way to set network tabs         */
	then do;
	     call ttt_info_$initial_string (cdte.current_terminal_type, tab_string, bv_tabs_code);
	     if bv_tabs_code ^= 0 then return;
	     if length (tab_string) ^= 0 then do;
		call astty_$tty_changemode (cdtep, "rawo", bv_tabs_code); /* write string out exactly */
		if bv_tabs_code ^= 0 then return;

		p = addrel (addr (tab_string), 1);	/* varying string */
		call astty_$tty_force (cdtep, p, length (tab_string), bv_tabs_code);
		if bv_tabs_code ^= 0 then return;
	     end;
	end;

	call ttt_info_$modes (cdte.current_terminal_type, modes_string, bv_tabs_code);
	if bv_tabs_code ^= 0 then return;

	if init_sw then call astty_$tty_changemode (cdtep, "force,init," || modes_string, bv_tabs_code);
	else call astty_$tty_changemode (cdtep, "force," || modes_string, bv_tabs_code);
	return;

set_tabs_and_modes_gently: entry (bv_tabs_code);

	init_sw = "0"b;
	go to join;

     end set_tabs_and_modes;
%page;
trace: proc;

	if loud_select_sw then do;			/* trace only specified channel(s) */
	     if have_cdte then do;
		if loud_select_channel ^=		/* if specified string is not equal to */
		     substr (cdte.name, 1, length (loud_select_channel)) /* the beginning of this channel's name */
		then return;			/* then don't trace it */
	     end;
	     else if have_ate then do;
		if loud_select_channel ^=
		     substr (ute.tty_name, 1, length (loud_select_channel))
		then return;
	     end;
	end;
	call get_trace_info;
	call sys_log_ (SL_LOG, "^a: trace event ^a ^a ^w ^p st=^d,inuse=^d,tv=^d",
	     ME,					/* "dialup_" */
	     tname,				/* channel name */
	     tsignal_type,				/* what was signalled */
	     ev_msg.fromproc,			/* signalling processid */
	     ev_msg.data_ptr,			/* ptr to cdte or ate */
	     tstate, tinuse, ttv);			/* line state, entry state, wait point */

     end trace;
%page;
turn_printer_on: proc (bv_turn_code);

declare  bv_turn_code fixed bin (35) parameter;

	call astty_$tty_order (cdtep, "printer_on", null, bv_turn_code);
	if bv_turn_code ^= 0
	then if bv_turn_code = error_table_$action_not_performed
	     then bv_turn_code = 0;

	return;

     end turn_printer_on;
%page;
type_black: proc;

	call astty_$tty_order (cdtep, "printer_off", null, code);
	if code ^= 0				/* allow only 0 or action_not_performed */
	then if code ^= error_table_$action_not_performed
	     then go to chn_error;

	if (ute.mask_ctl = DO_MASK)
	     | (ute.mask_ctl = DERIVE_MASK & (code ^= 0))
	then do;
	     substr (ubits, 1, 36) = bit (fixed (anstbl.current_time, 36, 0), 36);
	     substr (ubits, 37, 36) = bit (fixed (fixed (anstbl.current_time, 35) * 99991, 36, 0), 36);
	     do i = 2 to 13;
		substr (garbg, 39 + i, 1) = substr (RANDOM, fixed (substr (ubits, 1 + 5 * i, 5), 17) + 1, 1);
	     end;
	     call astty_$tty_force (cdtep, addr (garbg), garbg_lth, code);
	end;
	else call astty_$tty_force (cdtep, addr (NL), size (NL), code); /* now that printer is off, signal user */
	if code ^= 0 then go to chn_error;
	return;

     end type_black;
%page;
ucs: proc (mcptr, condname, coptr, infoptr, continue);

dcl  (mcptr, coptr, infoptr) ptr, condname char (*), continue bit (1);
dcl  errm char (120) aligned, erri fixed bin;
dcl  non_local bit (1);
dcl  as_check_condition_ entry (char (*), bit (1), bit (1));

	call as_check_condition_ (condname, continue, non_local);
	if continue | non_local then return;

	tname, tanswb = "";
	tstate, tinuse, ttv = -999;

	if ^static_fault_sw then do;			/* avoid infinite loop of get_trace_info faults */
	     static_fault_sw = "1"b;
	     call get_trace_info;			/* get info out of either ate or cdte */
	     static_fault_sw = ""b;
	end;
	call ioa_$rsnnl ("^a: Error ^a ^a ""^a"" ^a st=^d,inuse=^d,tv=^d",
	     errm, erri, ME, condname, tname, tanswb, tsignal_type, tstate, tinuse, ttv);
	call as_dump_ (errm);
	go to static_label;

     end ucs;
%page;
unlock: proc;

	if utep ^= null				/* Might unlock when not needed. */
	then anstbl.lock_count = anstbl.lock_count - ute.lock_value;
	if anstbl.lock_count < 0 then anstbl.lock_count = 0;
	if anstbl.lock_count = 0 then do;
	     code = 0;
	     if ^simulated_wakeup_sw then do while (code = 0);
		call ipc_$unmask_ev_calls (code);
		if code = 0 then call sys_log_ (SL_LOG, "^a: error - event calls were masked", ME);
	     end;
	end;
	if utep ^= null then ute.lock_value = 0;
	if ((anstbl.lock_count = 0) & (anstbl.update_pending = "1"b)) then do;
	     anstbl.update_pending = "0"b;		/* reset update-pending flag  */
	     call hcs_$wakeup (as_procid, anstbl.update_channel, dum_msg, code);
						/* trigger dormant update procedure */
	end;

	return;

     end unlock;
%page;
update_term_info: proc;


	term_info.version = terminal_info_version;
	call astty_$tty_order (cdtep, "terminal_info", addr (term_info), code);
	if code ^= 0 then go to chn_error;		/* Get the info that's available. */

	cdte.current_terminal_type = term_info.term_type; /* Store info in CDTE for this channel */
	cdte.tty_id_code = term_info.id;		/* .. */
	cdte.cur_line_type = term_info.line_type;	/* .. */
	if cdte.flags.autobaud then			/* if it changes, save what he said */
	     cdte.baud_rate = term_info.baud_rate;	/* .. */

	return;

     end update_term_info;
%page;
/* ADDITIONAL ENTRY POINTS */

/* initialize: we're happy to do this as many times as asked, because we
   don't touch any tables. */

init: entry;

	wcr = as_data_$CR;				/* set up characters hard to type */
	greeting_fmt = convert_message (as_error_table_$greeting_msg);
	bad_login_word_fmt = convert_message (as_error_table_$bad_login_word_msg);
	proc_term_fmt = convert_message (as_error_table_$proc_term_msg);
	init_term_fmt = convert_message (as_error_table_$init_term_msg);
	proc_term_loop_fmt = convert_message (as_error_table_$proc_term_loop_msg);
	logout_fmt = convert_message (as_error_table_$logout_msg);
	logout_fmt1 = convert_message (as_error_table_$logout1_msg);

	call convert_status_code_ (as_error_table_$pw_msg, shxx, format);
	call ioa_$rsnnl (rtrim (format), pw_msg, pw_msg_lth);

	call convert_status_code_ (as_error_table_$npw_msg, shxx, format);
	call ioa_$rsnnl (rtrim (format), npw_msg, npw_msg_lth);

	call convert_status_code_ (as_error_table_$npw_again_msg, shxx, format);
	call ioa_$rsnnl (rtrim (format), npw_again_msg, npw_again_msg_lth);

	call ioa_$rsnnl ("^/YourPassword^aXWXWXWXWXWXW^a986543986543^agqypjmmjpyqg^a", garbg, garbg_lth,
	     wcr, wcr, wcr, wcr);

	call convert_status_code_ (as_error_table_$hangup_msg, shxx, format);
	call ioa_$rsnnl (rtrim (format), hangup_msg, hangup_msg_lth);

	unspec (dum_msg) = unspec (unlock_string);	/* wakeup message sent by unlock */

	return;
%page;
trace_on: entry options (variable);

dcl  cu_$arg_count entry returns (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  argp ptr, argl fixed bin, arg char (argl) based (argp);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  loud_select_sw bit (1) aligned int static init (""b);
dcl  loud_select_channel char (32) varying int static init ("");

	loudsw = "1"b;

	if cu_$arg_count () = 0 then			/* if no argument, trace all channels */
	     loud_select_sw = ""b;
	else do;					/* trace the specified channel(s) */
	     loud_select_sw = "1"b;
	     call cu_$arg_ptr (1, argp, argl, code);
	     loud_select_channel = arg;		/* can be something like "a.h1" */
	end;

	call sys_log_ (SL_LOG, "^a: tracing turned on^[ for channel ^a^].",
	     ME, loud_select_sw, loud_select_channel);

	return;

trace_off: entry;

	loudsw = "0"b;

	call sys_log_ (SL_LOG, "^a: tracing turned off.", ME);

	return;
%page;
re_introduce: entry;				/* say hello to dialed up channels again */

	begin;
dcl  i fixed bin;					/* no interference from anyone! */
	     ansp = as_data_$ansp;
	     do i = 1 to scdtp -> cdt.current_size;
		cdtep = addr (scdtp -> cdt.cdt_entry (i));
		utep = cdte.process;
		if cdte.service_type = ANS_SERVICE &
		     cdte.tra_vec = WAIT_LOGIN_LINE then do;
		     call astty_$tty_state (cdtep, code); /* let's double-check */
		     if code ^= 0 then say_hello = ^channel_error (); /* ignore return value */
		     else if cdte.in_use = NOW_DIALED &
			cdte.state = TTY_DIALED then do; /* should do a read_status or check the ipc channel */
			call astty_$tty_abort (cdtep, 2, code); /* conserve tty_buf, flush anything backed */
			if code ^= 0 then go to reintro_fails;
			call hello (2);		/* keep talking */
			if code ^= 0 then
reintro_fails:		     say_hello = ^channel_error (); /* ignore return value */
		     end;				/* have a client */
		end;
	     end;					/* all CDTEs */
	     return;
	end;

/* format: off */
%page; %include answer_table;
%page; %include access_audit_bin_header; /* not used by needed by PL/I */
%page; %include as_audit_structures;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include as_meter_numbers;
%page; %include as_wakeup_priorities;
%page; %include author_dcl;
%page; %include cdt;
%page; %include dialup_values;
%page; %include net_event_message;
%page; %include installation_parms;
%page; %include line_types;
%page; %include pdt;
%page; %include sc_stat_;
%page; %include send_mail_info;
%page; %include set_term_type_info;
%page; %include sys_log_constants;
%page; %include terminal_info;
%page; %include tty_access_class;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;

/* format: on */
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   dialup_: ERROR_MESSAGE.  Trying to wakeup process after reconnection
   for PERSON.PROJECT.TAG

   S:	$as0

   T:	Called in response to a user reconnecting to an interactive process.

   M:	A failure occurred while sending a wakeup to the process being
   connected to the terminal.  ERROR_MESSAGE is the text associated with the
   error code returned by hcs_$wakeup.

   A:	$ignore


   Message:
   dialup_: non-null atep (UTEP) for cdte (CDTEP,CHANNEL), tv=TRAVEC,inuse=INUSE

   S:	$as0

   T:	$run

   M:	A wakeup occurred for CHANNEL whose user table entry pointer (UTEP)
   was non-null.  A test on the above information determined that the state of
   the channel to be inconsistant.  The system will null the UTEP pointer in
   the CDT for the above channel.

   A:	$contact

   Message:
   dialup_: re-used cdte (CDTEP,CHANNEL) by ate UTEP, destroy_flag=DDDD

   S:	$as0

   T:	$run

   M:	An ate wakeup occurred which pointed to a CDTEP that was already in
   use by another process.

   A:	$inform

   Message:
   dialup_: turning on disconnected flag for ate UTEP

   S:	$as0

   T:	$run

   M:	If after detecting a re-used cdte and the disconnected flag is not
   on, the disconnected flag will be turned on and noted by this message.

   A:	$inform

   Message:
   dialup_: turning off disconnected flag for ate UTEP, cdte CDTEP,CHANNEL

   S:	$as0

   T:	$run

   M:	If processing an ate wakeup, the CHANNEL is known and the process is
   disconnected, the disconnected flag for the ate will be turned off.

   A:	$inform

   Message:
   dialup_: Program error: null atep with per-process tra_vec value

   S:	$as2

   T:	$run

   M:	A system programming error in the answering service has occurred as a
   wakeup occurred when tra_vec indicated to expect a process termination but
   the ate pointer was null.

   A:	$inform

   Message:
   dialup_: Program error: null cdtep with per-channel tra_vec value

   S:	$as2

   T:	$run

   M:	A wakeup was received when the tra_vec value indicated a channel
   operation was required but the cdtep was null.  This is considered to be a
   programming error.

   A:	$inform

   Message:
   dialup_: Program error: per-process wakeup with per-channel-only tra_vec value

   S:	$as2

   T:	$run

   M:	A process wakeup occurred when the tra_vec value indicated it should
   be a channel wakeup.  This is considered a programing error.

   A:	$inform

   Message:
   dialup_: CDT damaged at CDTEP, tra_vec=TTTT

   S:	$as2

   T:	$run

   M:	The tra_vec value was found to be invalid for a channel wakeup.
   Damage to the CDT is indicated.

   A:	$inform

   Message:
   dialup_: answer table damaged at UTEP, tra_vec=TTTT

   S:	$as2

   T:	$run

   M:	The tra_vec value was found to be invalid for an answer table wakeup.
   Damage to the answer table is indicated.

   A:	$inform

   Message:
   dialup_: Unable to determine initial terminal type for channel CHAN

   S:	$as2

   T:	$run

   M:	cdte.initial_terminal_type is not set, indicating CDT damage.
   Channel CHAN is removed from the system.

   A:	$inform

   Message:
   dialup_: wrong answerback on CHANNEL (COMMENT); expected "ID1", got "ID2".

   S:	$as2

   T:	$run

   M:	A terminal attempted to connect on CHANNEL (whose CDT comment is
   COMMENT) that is restricted to a specific answerback and did not return the
   expected value.  ID1 is the answerback expected; ID2 is the answerback
   actually received.  The terminal is hung up.

   A:	$ignore

   Message:
   dialup_: ERROR_MESSAGE  Unable to declare handler for ev chn EVENT_CHN for ate UTEP for CDT_CHANNEL

   S:	$as2

   T:	$run

   M:	An ERROR_MESSAGE was returned when an attempt was made to declare an
   event call channel for new process (UTEP) on EVENT_CHN attached to
   CDT_CHANNEL.

   A:	$inform

   Message:
   dialup_: program error. cdte.current_access_class_valid = "0"b at disconnected process manipulation for PERSON.PROJECT channel CHANNEL.

   S:	$as1

   T:	$run

   M:	When the AIM authorization of the current process was to be checked,
   the cdte.current_access_class_valid flag was found to be off.  It should
   never be at this point in the software.

   A:	$inform_ssa

   Message:
   dialup_: program error: attempt to create process for PERSON.PROJECT CHANNEL,
   .brf
   with ate UTEP not filled in; n_disc=XX,disc_com=YY,disc_ate_ix=ZZ

   S:	$as1

   T:	$run

   M:	The lg_ctl_ program is supposed to have filled in process creation
   variables and set ute.uflags.proc_create_ok but apparently did not.  This
   message in the log indicates a program error.

   A:	$inform

   Message:
   dialup_: ERROR_MESSAGE creating process for PERSON.PROJECT

   S:	$as2

   T:	$run

   M:	An ERROR_MESSAGE was returned and the system was unable to create a
   user process for PERSON.PROJECT.

   A:	If possible, get in touch with the user. (He got a
   message to contact you.) Ask him to try again and to tell
   you of any peculiarities of his login.  Note all particulars
   and contact the programming staff.

   Message:
   dialup_: ERROR_MESSAGE  setting new tty info for CHANNEL

   S:	$as0

   T:	$run

   M:	An ERROR_MESSAGE was returned by a call to cpg_$set_pit_tty_info when
   setting new terminal attributes in a reconnected process on channel CHANNEL.

   A:	$inform

   Message:
   dialup_: SLAVE       CHANNEL

   S:	$as0

   T:	$run

   M:	Logging message indicating that the slave command has been entered in
   on channel CHANNEL which does not have the "slave_dial" keyword in its
   check_acs statement.

   A:	$ignore

   Message:
   dialup_: SLAVE       PERSON.PROJECT CHANNEL

   S:	$as0

   T:	$run

   M:	Logging message indicating that the slave command has been entered in
   on channel CHANNEL which does have the "slave_dial" keyword in its
   check_acs statement.

   A:	$ignore

   Message:
   dialup_: process terminated PERSON.PROJECT CHANNEL TERM_MESSAGE

   S:	$as0

   T:	$run

   M:	The process for PERSON.PROJECT on CHANNEL was terminated abnormally
   due to reason in TERM_MESSAGE.

   A:	$ignore

   Message:
   dialup_: fatal error during process creation for PERSON.PROJECT CHANNEL

   S:	$as1

   T:	$run

   M:	A fatal error occurred during process creation for PERSON.PROJECT on
   CHANNEL.  Reason is given in previous log entry.  This may be due to a user
   error: incorrect segments in the user's home directory or bad login
   arguments can cause this problem.

   A:	$ignore

   Message:
   dialup_: terminating fatal process error loop for PERSON.PROJECT CHANNEL

   S:	$as1

   T:	$run

   M:	The process for PERSON.PROJECT on CHANNEL has taken too many fatal
   process errors.  This is governed by fatal_error_loop_seconds and
   fatal_error_loop_count in the installation_parms.  The user will not get a
   new process.  The channel will not be hungup but will get a message
   indicating this condition.  This message may be due to a user error.

   A:	$ignore

   Message:
   dialup_: Unexpected termsgnl for PERSON.PROJECT CHANNEL (preempted=DDDD).

   S:	$as0

   T:	$run

   M:	A "termsgnl" wakeup was received for the PERSON.PROJECT process on
   CHANNEL whose ute.preempted value DDDD did not indicate one was allowed.
   This is considered to be a program error.  User will be given a new process.

   A:	$inform

   Message:
   dialup_: process ignored sus_ signal PERSON.PROJECT CHANNEL

   S:	$as1

   T:	$run

   M:	The PERSON.PROJECT process on CHANNEL ignored the sus_ signal that
   had been sent to it.  The user can cause this message.

   A:	$ignore

   Message:
   dialup_: cancelling inactivity bump of PERSON.PROJECT

   S:	$as1

   T:	$run

   M:	This is a logging message indicating that the PERSON.PROJECT process
   that had been previously bumped due to inactivity has become active.  The
   automatic logout was therefore cancelled.  The user will receive a message
   to this effect.

   A:	$ignore

   Message:
   dialup_: process ignored trm_ signal PERSON.PROJECT CHANNEL

   S:	$as1

   T:	$run

   M:	The PERSON.PROJECT process on CHANNEL had been sent a trm_ signal but
   the process did not respond to it.  The process will be handled as was
   intended to be; bumped, logged out, etc.

   A:	$ignore

   Message:
   dialup_: premature stopstop for PERSON.PROJECT CHANNEL

   S:	$as0

   T:	$run

   M:	$err

   A:	$inform

   Message:
   dialup_: process did not respond properly to trm_ signal. PERSON.PROJECT CHANNEL

   S:	$as0

   T:	$run

   M:	The PERSON.PROJECT process on CHANNEL was being terminated and had
   been sent the trm_ signal but it did not respond.  User process will be
   bumped, logged out or new_proced.  It is possible that the user can cause
   this message.

   A:	$ignore

   Message:
   dialup_: cdtep = null and ate.active = DDDD for UTEP

   S:	$as2

   T:	$run

   M:	$err

   A:	$inform

   Message:
   dialup_: ERROR_MESSAGE From write_status order on CHANNEL

   S:	$as1

   T:	$run

   M:	This is a debugging message that will only appear if tracing has been
   enabled.  An ERROR_MESSAGE by a call to astty_$tty_order with a
   "write_status" order.

   A:	$inform

   Message:
   dialup_: cdte CDTEP (CHANNEL) state M in use N - notify system programmer",

   S:	$as0

   T:	$run

   M:	$err

   A:	$contact

   Message:
   dialup_: called with null message ptr

   S:	$as2

   T:	$run

   M:	A programming error in the interprocess communication
   system, the network software, or the Answering Service itself
   has occurred.  An invalid message pointer has been passed to
   the Answering Service.  The system ignores the message and
   attempts to continue.  This message may be the result of an incorrect
   library installation.

   A:	Shut down the system and perform a bootload operation.
   Inform the system programming staff.

   Message:
   dialup_: called while ansp = null

   S:	$as2

   T:	$run

   M:	A programming error in the Answering Service or an incorrect
   library installation has caused the Answering Service to be called
   before being initialized.  The system will ignore the error and attempt
   to continue.

   A:	Shut down the system and perform a bootload operation.

   Message:
   dialup_: called with bad ptr EVENT_MSG_PTR by WWWWWWWWWWWW

   S:	$as2

   T:	$run

   M:	A programming error in the interprocess communication
   system, the network software, or the Answering Service itself has
   occurred.  An invalid message pointer has been passed to the Answering
   Service.  The system ignores the message and attempts to continue.
   This message may be the result of an incorrect library installation.

   A:	Shut down the system and perform a bootload operation.

   Message:
   dialup_: ignored SSSS from PERSON.PROJECT for CHANNEL state=DDDD,inuse=UUUU,tv=TTTT

   S:	$as2

   T:	$run

   M:	A spurious signal SSSS from user PERSON.PROJECT has arrived for
   CHANNEL.  The state of the channel is DDD, inuse is UUUU and tra_vec is
   TTTT.

   A:	This may be some user trying to disrupt the system.  Do a
   who and save it for the programming staff.

   Message:
   dialup_: ignored SSSS for CHANNEL st=DDDD,inuse=UUUU,tv=TTTT

   S:	$as2

   T:	$run

   M:	A spurious signal SSSS has arrived for CHANNEL.  The state of the
   channel is DDD, inuse is UUUU and tra_vec is TTTT.

   A:	This may be some user trying to disrupt the system.  Notify the
   programming staff.

   Message:
   dialup_: channel_error called with cdte in functional state.

   S:	$as1

   T:	$run

   M:	$err

   A:	$inform

   Message:
   dialup_: program error: disconnected ate index no. CUR_IDX for PERSON.PROJECT is NEXT_IDX

   S:	$as1

   T:	$run

   M:	$err

   A:	$inform

   Message:
   dialup_: ERROR_MESSAGE attempting to allocate a user table entry for CHANNEL

   S:	$as1

   T:	$run

   M:	An ERROR_MESSAGE was returned from a call to asu_$attach_ate which
   allocates a user table entry.

   A:	$inform

   Message:
   dialup_: The answer table is full (MAX entries).

   S:	$as1

   T:	$run

   M:	The system answer table is full and has MAX entries.  No more users
   will be able to login.

   A:	$inform

   Message:
   dialup_: ERROR_MESSAGE get_required_access_class order failed for CHANNEL

   S:	$as1

   T:	$run

   M:	An ERROR_MESSAGE was returned by a call to astty_$tty_order with a
   get_required_access_class order for CHANNEL.  The channel will be hungup.

   A:	$inform_ssa

   Message:
   dialup_: ERROR_MESSAGE  Getting pointer to help file, SYS_DIR>ENTRY_NAME

   S:	$as2

   T:	$run

   M:	An ERROR_MESSAGE was returned when an attempt was made to find the
   login_help or connect_help segment in the SYS_DIR, usually >sc1.

   A:	$inform

   Message:
   dialup_: ERROR_MESSAGE ttt error, removing channel CHANNEL COMMENT

   S:	$as2

   T:	$run

   M:	An ERROR_MESSAGE resulting from accessing the TTT has caused the
   CHANNEL with COMMENT to be unusable when attempting to set the default
   terminal type based on line-type/baud-rate.  The channel has been removed
   from known channels.

   A:	$inform
   An attach of the CHANNEL can be tried.  If the channel is to be left
   detached, busy out the modem.

   Message:
   dialup_: ERROR_MESSAGE tty_dim error, removing channel CHANNEL COMMENT

   S:	$as2

   T:	$run

   M:	An ERROR_MESSAGE caused the CHANNEL to be unusable. The
   CHANNEL with COMMENT will be removed from service.

   A:	You may try to attach the channel.  If that fails, notify the system
   programmers.  If the channel is to be left detached, busy out the modem.

   Message:
   dialup_: ERROR_MESSAGE when attempting to notify user PERSON.PROJECT of dialup event

   S:	$as0

   T:	$run

   M:	An ERROR_MESSAGE was returned when an attempt was made to send a
   message to PERSON.PROJECT about a dialup event.

   A:	$inform

   Message:
   dialup_: trace event CHANNEL FFFFFFFF WWWWWWWWWWWW RRRRRRDDDDDD SS XXXX st N wp M

   S:	$as1

   T:	$run

   M:	This is trace output.  When dialup_$trace_on is called,
   these messages are printed out for every signal concerning a device
   channel. FFFFFFFF is the function being performed. WWWWWWWWWWWW is
   the sending process ID. RRRRRR is the ring origin of the signal.
   DDDDDD is the device signal information.  The pointer SS XXXX locates the
   answer table entry for CHANNEL.  The channel state is N and the wait
   point (transaction vector) is M.

   A:	$ignore  To turn these messages
   off, type dialup_$trace_off while in admin mode.

   Message:
   dialup_: error - event calls were masked

   S:	$as1

   T:	$run

   M:	This message indicates a serious error in the Initializer
   programs.  The system attempts to recover and keep running.

   A:	$inform

   Message:
   dialup_: tracing turned on.

   S:	$as1

   T:	$run

   M:	The dialup_$trace_on entry point was called without arguments.  All
   channels will be traced.

   A:	$ignore If tracing is to be turned off, type dialup_$trace_off in
   admin mode.

   Message:
   dialup_: tracing turned on for channel CHANNEL.

   S:	$as1

   T:	$run

   M:	The dialup_$trace_on entry point was called with an argument, the
   begining part of a CDT channel name; to trace all channels on FNP a, then
   supply "a"; to trace all channels on second hsla of FNP B, supply "b.h1".

   A:	$ignore If tracing is to be turned off, type dialup_$trace_off in
   admin mode.

   Message:
   dialup_: tracing turned off.

   S:	$as1

   T:	$run

   M:	The dialup_ tracing function has been turned off.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end dialup_;




		    dpg_.pl1                        08/29/88  0953.1rew 08/29/88  0858.7      199269



/****^  ***********************************************************
        *                                                         *
        * 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: style4 */
dpg_: proc (p, P_reason);

/* DPG_ - destroy process group.

   Called from dialup_, absentee_user_manager_, daemon_user_manager_, and asu_
   to destroy a user process. Updates usage meters in answer table entry.

   Initially coded by Michael J. Spier on February 15, 1969.
   Recoded in PL/1 by MJS on April 7, 1970
   Modified for new destroy strategy 9/73 THVV
   Modified May 1978 by T. Casey to notify pdir_volume_manager_ when we delete a pdir.
   Modified October 1979 by T. Casey to save pdir after fatal process error if user has save_pdir attribute.
   Modified March 1980 by Tom Casey to add metering.
   Modified June 1981 by J. Bongiovanni to save stack_0 in dead pdir
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified December 1981 by J. Bongiovanni to expand pdir quota, if necessary, to copy stack_0
   Modified October 1982 by E. N. Kittlitz for register_buzzard.
   Modified September 1983 by E. N. Kittlitz to notify buzzards after ring0 destruction complete, change structure names.
   Modified 84-06-06 BIM. Change buzzard for new structure.
   Modified September 1984 by Keith Loepere to understand the error code from
   del_dir_tree (via destroy_process_finish).
   Modified September 1984 by B. L. Braun to add sma for the SysMaint and SysAdmin projects to the saved process directory.
   Modified:
   10/05/84 by R. Michael Tague:  up_sysctl_$check_acs now returns a bit (36)
   mode string instead of a fixed bin (5) and no longer takes a directoy arg.
   11/05/84 by R. Michael Tague:  Changed check on process_termination_monitor
   ACS to be a RW check instead of W only.
   Modified 84-12-29 by E. Swenson for new AS auditing.
   Modified 15 January 1985 by B. L. Braun to replace the acl on the saved
   process directory with Person.Project.*, SysMaint, and SysAdmin projects.
   Modified 1985-02-20, BIM: call as_user_message_$priv_delete_process_messages.
*/

/****^  HISTORY COMMENTS:
  1) change(86-06-05,GJohnson), approve(86-06-05,MCR7387),
     audit(86-06-10,Martinson), install(86-07-11,MR12.0-1092):
     Correct error message documentation.
  2) change(87-04-27,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  3) change(87-07-22,GDixon), approve(87-07-22,MCR7741),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
      A) Add operator doc for undoc'd sys_log_ calls.
  4) change(87-07-24,Dickson), approve(87-07-24,MCR7722),
     audit(87-07-27,Brunelle), install(87-08-04,MR12.1-1055):
     Changed the entry point register_buzzard to perform auditing of GRANTS or
     DENYS when setting the process termination monitor.
  5) change(88-04-27,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-03,Lippard), install(88-08-29,MR12.2-1093):
      A) Call pdir_volume_manager_ to note deletion of a pdir when an attempt
         to save it has failed. (phx17303)
                                                   END HISTORY COMMENTS */

/* Parameters */

dcl  p ptr parameter;				/* points to answer table or abs user table entry */
dcl  P_reason char (*) parameter;			/* short reason why we're destroying. */

/* Entries */

dcl  as_access_audit_$dpg_buzzard entry (char (*), ptr, fixed bin (35));
dcl  as_access_audit_$process entry (ptr, fixed bin (17), char (*));
dcl  as_user_message_$priv_delete_process_messages entry (bit (36) aligned, fixed bin (35));
dcl  (as_meter_$enter, as_meter_$exit) entry (fixed bin);
dcl  dial_ctl_$dial_broom entry (ptr, char (8) aligned);
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  get_group_id_$tag_star entry () returns (char (32));
dcl  hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$replace_dir_acl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  hphcs_$copy_stack_0 entry (bit (36) aligned, ptr, fixed bin (35));
dcl  hphcs_$destroy_process_begin entry (ptr, fixed bin (35));
dcl  hphcs_$destroy_process_finish entry (ptr, fixed bin (35));
dcl  hphcs_$quota_read entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36),
	fixed bin (1), fixed bin, fixed bin (35));
dcl  hphcs_$quota_set entry (char (*), fixed bin (18), fixed bin (35));
dcl  hphcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (6), fixed bin (35));
dcl  lv_request_$cleanup_process entry (bit (36) aligned);
dcl  pdir_volume_manager_$note_pdir_deletion entry (ptr);
dcl  rcp_sys_$unassign_process entry (bit (36) aligned, fixed bin (35));
dcl  sys_log_$error_log entry options (variable);
dcl  sys_log_ entry options (variable);
dcl  unique_chars_ entry (bit (*) aligned) returns (char (15) aligned);

dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$no_dir ext fixed bin (35);

/* Automatic */

dcl  1 buzzard aligned based (buzzardp),		/* describe a process which is camping on death notifications */
       2 prev ptr,					/* two-way wrist linked list */
       2 next ptr,					/* ... */
       2 info_channel fixed bin (71),			/* IPC channel */
       2 process_id bit (36),				/* and, of course, who he is */
       2 user_reference_id bit (36),			/* user supplied data to be included in wakeup */
       2 group_id char (32);				/* and name (for ease of use) */
dcl  buzzardp ptr;
dcl  code fixed bin (35);
dcl  dir_name char (168);
dcl  ltrp fixed bin (71);
dcl  pdir_saved bit (1) aligned init (""b);
dcl  pdquota fixed bin (18);
dcl  reason char (8) automatic;
dcl  rqo_sw bit (1);
dcl  1 segment_acl (1) aligned,
       2 access_name char (32),
       2 modes bit (36),
       2 zero_pad bit (36),
       2 status_code fixed bin (35);
dcl  slvid bit (36);
dcl  stack_0_ptr ptr;
dcl  taccsw fixed bin (1);
dcl  tup bit (36) aligned;
dcl  used fixed bin;

/* Constant */

dcl  ME char (32) initial ("dpg_") internal static options (constant);

dcl  ZERO_RING_BRACKETS (3) fixed bin (6) int static options (constant) init (0, 0, 0);
dcl  STACK_0_NAME char (32) int static options (constant) init ("stack_0"); /* until level_0_ is fixed	*/
dcl  STACK_0_QUOTA fixed bin int static options (constant) init (16); /* how much to expand quota for stack_0 copy */


dcl  (addr, null, rtrim, unspec) builtin;

dcl  any_other condition;
dcl  record_quota_overflow condition;
%page;
/* Program */

	call as_meter_$enter (DPG_METER);
	utep = p;					/* copy ptr to answer table entry */
	reason = P_reason;

	call dial_ctl_$dial_broom (utep, (reason));	/* clean up attached consoles. */
	if ^as_data_$debug_flag then do;		/* we might not be Initializer */
	     call rcp_sys_$unassign_process (ute.proc_id, (0)); /* get rid of RCP cdevices and volumes */

	     if ute.lvs_attached then
		call lv_request_$cleanup_process (ute.proc_id); /* get rid of attached LVs. */

	end;

	unspec (process_status_return) = ""b;
	process_status_return.target_proc = ute.proc_id;
	call hphcs_$destroy_process_begin (addr (process_status_return),
	     code);
	if code ^= 0 then
	     call sys_log_$error_log (SL_LOG, code, ME,
		"Calling hphcs_$destroy_process_begin for ^a.^a.^a on channel ^a, process_id ^w.",
		ute.person, ute.project, ute.tag, ute.tty_name,
		ute.proc_id);

	call as_meter_$exit (DPG_METER);
	return;					/* Now wait for process to die. */
%page;
finish: entry (p);

	call as_meter_$enter (DPG_METER);
	utep = p;

	unspec (process_status_return) = ""b;
	process_status_return.target_proc = ute.proc_id;
	process_status_return.aptptr = null ();

	if ute.at.save_pdir &			/* if user has save_pdir attribute */
	     (ute.logout_type = "init" |		/* and this is a fatal process error */
	     ute.logout_type = "term" |		/* then save his pdir by renaming it, */
	     ute.logout_type = "no_i") then		/* so ring zero can't find it to delete it */
	     call Save_Pdir ();
	if ^pdir_saved then
	     if ^as_data_$debug_flag then
	     call pdir_volume_manager_$note_pdir_deletion (utep);

	call hphcs_$destroy_process_finish (addr (process_status_return), code);
	if code ^= 0				/* if a real error occurred destroying the process */
	     & (^pdir_saved | code ^= error_table_$no_dir) then do; /* no_dir because of save_pdir isn't real */
	     call sys_log_$error_log (SL_LOG, code, ME, "destroying process ^w for ^a.^a",
		ute.proc_id, ute.person, ute.project);
	     ute.cpu_usage = ute.cpu_usage + ute.cpu_this_process;
	     ute.mem_usage = ute.mem_usage + ute.mem_this_process;
	     ute.cpu_this_process = 0;
	     ute.mem_this_process = 0;
	end;
	else do;					/* got usage */
	     ute.cpu_this_process =
		process_status_return.virtual_cpu - ute.cpu_this_process;
						/* use as temporary loc to hold last delta */
	     ute.cpu_usage =
		ute.cpu_usage + process_status_return.virtual_cpu; /* count cpu usage for all process */
	     ute.mem_this_process =
		process_status_return.up_page - ute.mem_this_process;
	     ute.mem_usage = ute.mem_usage + process_status_return.up_page;
	end;

	call as_access_audit_$process (utep, AS_AUDIT_PROCESS_DESTROY,
	     "");

	call notify_buzzards (ute.proc_id);		/* if it didn't die in deact_proc, tough. I did my best. */
	call as_user_message_$priv_delete_process_messages (ute.proc_id, (0));
	call as_meter_$exit (DPG_METER);
	return;
%page;
register_buzzard: entry (P_request_header_ptr, P_asr_sender_ptr);

dcl  P_request_header_ptr ptr;
dcl  P_asr_sender_ptr ptr;

dcl  mode bit (36);

dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  error_table_$insufficient_access fixed bin (35) ext static;

dcl  up_sysctl_$check_acs entry (char (*), char (*), fixed bin, bit (36), fixed bin (35));

	as_request_sender_ptr = P_asr_sender_ptr;
	asr_buzzard_infop = P_request_header_ptr;
	asr_replyp = addr (as_request_sender.reply_message);
	unspec (asr_reply) = ""b;
	if asr_buzzard_info.version ^= asr_buzzard_info_version_1 &
	     asr_buzzard_info.version ^= "buteo_01" then do; /* grandfather clause for NDM */
	     asr_reply.code = error_table_$unimplemented_version; /* not good enough */
	     goto ERROR_RETURN;
	end;

	call up_sysctl_$check_acs ("process_termination_monitor.acs",
		as_request_sender.group_id, (as_request_sender.validation_level),
		mode, asr_reply.code);
	if asr_reply.code ^= 0 then goto ERROR_RETURN;
	if ((mode & RW_ACCESS) ^= RW_ACCESS) then do;
	     asr_reply.code = error_table_$insufficient_access;
	     goto ERROR_RETURN;
	end;

	buzzardp = as_data_$buzzardp;			/* start walking the list */
	do while (buzzardp ^= null);			/* down to the end of the list */
	     if buzzard.process_id = as_request_sender.process_id then do; /* whoops; this process already here */
		if asr_buzzard_info.info_channel = 0 then /* zero means stop telling me */
		     call remove_buzzard (buzzardp);	/* so stop */
		else do;				/* otherwise overwrite the channel for this process */
		     buzzard.info_channel = asr_buzzard_info.info_channel;
		     buzzard.user_reference_id = asr_buzzard_info.my_reference_id;
		     asr_reply.data = "1"b;		/* indicate this is a replacement */
		     call sys_log_ (SL_LOG_SILENT, "^a: ^a (^w) replaced process termination monitor.",
			ME, buzzard.group_id, buzzard.process_id);
		end;
		return;
	     end;					/* got a match */
	     buzzardp = buzzard.next;			/* press on */
	end;					/* do loop */
	if asr_buzzard_info.info_channel = 0 then do;	/* well, I'm certainly not going to add THAT */
	     asr_reply.code = error_table_$action_not_performed;
	     goto ERROR_RETURN;
	end;
	asr_reply.code = 0;
	allocate buzzard;
	buzzard.prev = null;
	buzzard.next = as_data_$buzzardp;
	buzzard.info_channel = asr_buzzard_info.info_channel;
	buzzard.process_id = as_request_sender.process_id;
	buzzard.user_reference_id = asr_buzzard_info.my_reference_id;
	buzzard.group_id = as_request_sender.group_id;
	if as_data_$buzzardp ^= null then
	     as_data_$buzzardp -> buzzard.prev = buzzardp;
	as_data_$buzzardp = buzzardp;

ERROR_RETURN:
	call as_access_audit_$dpg_buzzard (ME, addr(as_request_sender), asr_reply.code);

	if asr_reply.code = 0 then
	     call sys_log_ (SL_LOG_SILENT, "^a: ^a (^w) set process termination monitor.",
		ME, buzzard.group_id, buzzard.process_id);

	return;
%page;
notify_buzzards: proc (deceased);
dcl  deceased bit (36) aligned;
dcl  processid_message fixed bin (71);
dcl  bp ptr;

	asr_replyp = addr (processid_message);
	asr_buzzard_notification.process_id = deceased;
	bp = as_data_$buzzardp;
	do while (bp ^= null);
	     buzzardp = bp;
	     bp = buzzard.next;
	     if buzzard.process_id = deceased then
		call remove_buzzard (buzzardp);
	     else do;
		asr_buzzard_notification.your_reference_id = buzzard.user_reference_id;
		call hcs_$wakeup (buzzard.process_id, buzzard.info_channel, processid_message, code);
		if code ^= 0 then call remove_buzzard (buzzardp);
	     end;
	end;
     end notify_buzzards;
%page;
remove_buzzard: proc (bp);
dcl  bp ptr;

	if bp -> buzzard.next ^= null then
	     bp -> buzzard.next -> buzzard.prev = bp -> buzzard.prev;
	if bp -> buzzard.prev ^= null then
	     bp -> buzzard.prev -> buzzard.next = bp -> buzzard.next;
	if as_data_$buzzardp = bp then
	     as_data_$buzzardp = bp -> buzzard.next;
	call sys_log_ (SL_LOG_SILENT, "^a: removed ^a (^w) process termination monitor.",
	     ME, buzzard.group_id, buzzard.process_id);
	free bp -> buzzard;
     end;
%page;
Save_Pdir:
     procedure ();

dcl  1 CI aligned like condition_info automatic;
dcl  1 dir_acl (5) structure aligned automatic,
       2 access_name char (32) unaligned,
       2 mode bit (36) aligned,
       2 status_code fixed bin (35);
dcl  n_acl_entries fixed bin automatic;
dcl  name char (32) automatic;
dcl  newname char (32) automatic;
dcl  newdir char (168) automatic;

dcl  1 DIR_ACL_INIT (5) aligned int static options (constant),
       2 access_name char (32) unal
	  init ("*.*.*", "*.SysMaint.*", "*.SysAdmin.*", "", ""),
       2 mode bit (36) aligned			/*  null for *.*.*, sma access for the rest */
	  init ((1) ((36)"0"b), (3) ("111"b || (33)"0"b), ""b),
       2 status_code fixed bin (35) init ((5) 0);

	name = unique_chars_ (ute.proc_id);		/* get its current name */
/**** Then make up a meaningful new name for it */
	newname = rtrim (ute.person) || "." || rtrim (ute.project) || ".f." ||
	     rtrim (ute.tty_name);
	call hcs_$chname_file (">pdd", name, name, newname, code);
	if code ^= 0 then
	     call sys_log_$error_log (SL_LOG, code, ME,
		"Attempting to rename pdir for ^a.^a ^a after fatal process error.",
		ute.person, ute.project, ute.tty_name);
	else do;
	     pdir_saved = "1"b;
	     call sys_log_ (SL_LOG,
		"^a: Saved >pdd>^a after fatal process error.",
		ME, newname);

/* Set the ACLS on the dead process directory. */

	     dir_acl (*) = DIR_ACL_INIT (*);
	     dir_acl (4).access_name = rtrim (ute.person) || "." ||
		rtrim (ute.project) || ".*";

	     if ^as_data_$debug_flag then
		n_acl_entries = 4;
	     else do;
		n_acl_entries = 5;
		dir_acl (5).access_name = get_group_id_$tag_star ();
		dir_acl (5).mode = SMA_ACCESS;
	     end;

	     call hcs_$replace_dir_acl (">pdd", newname, addr (dir_acl),
		n_acl_entries, "0"b /* add *.SysDaemon.* */, code);
	     if code ^= 0 then
		return;

	     on any_other begin;
dcl  rcode fixed bin (35) automatic;
		call find_condition_info_ (null (), addr (CI), rcode);
		if rcode = 0 then
		     call sys_log_ (SL_LOG_SILENT,
			"^a: ^a condition signalled while copying stack_0 into >pdd>^a",
			ME, CI.condition_name, newname);
		goto join_after_nasty_error;
	     end;

	     newdir = ">pdd>" || rtrim (newname);
	     call hcs_$make_seg (newdir, STACK_0_NAME, "", 01010b, stack_0_ptr,
		code);
	     if code = 0 then do;
		rqo_sw = "0"b;
		on record_quota_overflow begin;
		     rqo_sw = "1"b;
		     dir_name = ">pdd>" || rtrim (newname);
		     call hphcs_$quota_read (dir_name, pdquota, ltrp, tup,
			slvid, taccsw, used, code);
		     if code ^= 0 then do;
rqo_error:		call sys_log_ (SL_LOG_SILENT,
			     "^a: record_quota_overflow condition signalled while copying stack_0 into >pdd>^a",
			     ME, newname);
			goto join_after_nasty_error;
		     end;
		     call hphcs_$quota_set (dir_name, pdquota + STACK_0_QUOTA,
			code);
		     if code ^= 0 then
			goto rqo_error;
		     goto retry_copy_stack;
		end;

retry_copy_stack:
		if rqo_sw then
		     revert record_quota_overflow;
		call hphcs_$copy_stack_0 (ute.proc_id, stack_0_ptr, code);
		revert record_quota_overflow;
		if code = 0 then do;
		     call hcs_$terminate_noname (stack_0_ptr, code);
		     segment_acl.access_name = rtrim (ute.person) || "." ||
			rtrim (ute.project) || ".*";
		     segment_acl.modes = RW_ACCESS;
		     segment_acl.zero_pad = "0"b;
		     call hcs_$add_acl_entries (newdir, STACK_0_NAME,
			addr (segment_acl), 1, code);
		     call hphcs_$set_ring_brackets (newdir, STACK_0_NAME,
			ZERO_RING_BRACKETS, code);
		end;
		else
		     call hcs_$delentry_seg (stack_0_ptr, code);
	     end;
	     else
		call sys_log_$error_log (SL_LOG_SILENT, code, ME,
		     "Creating saved stack_0 for ^a.^a (^w).", ute.person,
		     ute.project, ute.proc_id);

join_after_nasty_error:
	     revert any_other;
	     revert record_quota_overflow;
	end;
	return;
/**** format: off */
%page; %include condition_info;
/**** format: on */
     end Save_Pdir;

/* format: off */
%page; %include access_audit_bin_header; /* not used, but needed by PL/I */
%page; %include access_mode_values;
%page; %include as_audit_structures;
%page; %include as_data_;
%page; %include as_meter_numbers;
%page; %include as_request_header;
%page; %include as_requests;
%page; %include as_request_sender_;
%page; %include process_status_return;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   dpg_: ERROR_MESSAGE. Calling hphcs_$destroy_process_begin for 
   PERSON.PROJECT.TAG on channel CHN, process_id PID.

   S:	$as1

   T:	$run

   M:	An error has occurred while destroying a process belonging
   to the user PERSON.PROJECT.TAG connected to terminal channel CHN.
   This process probably cannot be destroyed.  ERROR_MESSAGE is the text
   associated with the error returned by hphcs_$destroy_process_begin.

   A:	$inform


   Message:
   dpg_: ERROR_MESSAGE. destroying process WWWWWWWWWWWW for NAME.PROJ

   S:	as (severity2)

   T:	$run

   M:	An error has occurred while destroying a process belonging
   to the user NAME.PROJ.  He was not charged for his CPU usage.

   A:	$inform


   Message:
   dpg_: Saved >pdd>PERS.PROJ.f.CHN after fatal process error.

   S:	as (severity1)

   T:	$run

   M:	The process directory belonging to user PERS.PROJ has been saved after a
   fatal process error. It has been renamed to the name shown in the message.
   It will be saved until the next shutdown. System programmers might want to
   examine its contents to determine the cause of the fatal process error.

   A:	Inform the system programming staff. Do so well in advance of the next shutdown.


   Message:
   dpg_: ERROR_MESSAGE. Attempting to rename pdir for NAME.PROJ CHN after fatal process error.

   S:	as (severity1)

   T:	$run

   M:	The error described by ERROR_MESSAGE occurred while attempting to save
   the process directory belonging to the user PERS.PROJ after a fatal process error.
   The directory was not saved. A typical cause of this is that the user already has
   a saved process directory from a previous fatal process error in this bootload.

   A:	$inform


   Message:
   dpg_: ERROR_MESSAGE. Creating saved stack_0 for PERS.PROJ (PROCESSID).

   S:	as (severity0)

   T:	$run

   M:	An error has occurred while attempting to create a segment in the
   saved process directory for copying the ring-0 stack of the defunct process.
   The ring-0 stack will not be copied into the saved process directory.

   A:	$ignore


   Message:
   dpg_: COND condition signalled while copying stack_0 into >pdd>DIRNAME

   S:	as (severity0)

   T:	$run

   M:	An error occurred while copying the ring-0 stack of the defunct
   process from ring-0 into the saved process directory.  This error caused
   the COND condition to be signalled.  The ring-0 stack will not be copied
   into the saved process directory.

   A:	$ignore


   Message:
   dpg_: USER (PROCESSID) {set/replaced} process termination monitor.

   S:	as (severity0)

   T:	$run

   M:	USER (processid PROCESSID) will receive notifications of all
   process destructions from the Answering Service.  'set' indicates that
   the process was not already monitoring processes; 'replaced' indicates that
   the process already had a monitor established, and that it has been
   replaced by this request.

   A:	$ignore


   Message:
   dpg_: removed USER (PROCESSID) process termination monitor.

   S:	as (severity0)

   T:	$run

   M:	Process termination monitoring for USER (process id PROCESSID)
   has been terminated by user request, IPC error, or the destruction
   of the process.

   A:	$ignore


   END MESSAGE DOCUMENTATION */

     end dpg_;




		    lg_ctl_.pl1                     02/27/89  1204.9rew 02/27/89  1052.0     1063512



/****^  ***********************************************************
        *                                                         *
        * 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-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1055):
     Correct error message documentation.
  2) change(86-08-03,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to check for RW access on channel ACS segments upon login.
     (Actual change date was 85-08-03)
  3) change(86-08-03,Swenson), approve(86-08-13,MCR7512),
     audit(86-08-13,EJSharpe), install(86-09-08,MR12.0-1150):
     Modified to correctly check authorizations for anonymous users.
     (Actual change date was 85-08-03)
  4) change(87-02-19,Farley), approve(87-07-06,MCR7691),
     audit(87-03-11,Fawcett), install(87-08-04,MR12.1-1055):
     Changed DETERMINE_AUTHORIZATIONS to use convert_access_class_$(minimum and
     maximum) instead of aim_check_$greater to find the minimum range of
     authorizations between the SAT, PDT and PNT.
  5) change(87-03-05,Farley), approve(87-07-06,MCR7691),
     audit(87-03-11,Fawcett), install(87-08-04,MR12.1-1055):
     Corrected to properly enforce password expiration interval.
  6) change(87-03-20,Beattie), approve(87-04-06,MCR7656),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
     Add support for hasp operator subchannels to be login service.
  7) change(87-04-07,GDixon), approve(87-07-06,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
      A) Correct coding standard violations.
      B) Changed to not reference whotab entry if none is associated with the
         ute.
      C) Changed to call asu_$blast_user instead of astty_$force_write when
         warning user of another login.
      D) Clear out the message buffer used to hold messages produced by
         act_ctl_ and load_ctl_.
      E) Eliminate lg_ctl_$reset entrypoint.  Either user_table_mgr_$allocate
         or $reset should be used instead. (dsa 206, dsa 214)
      F) Eliminate use of ute.logged_in flag, in favor of ute.active =
         NOW_LOGGED_IN.
      G) Remove code which prevents whotab.process_authorization from being
         set.
      H) Avoid referencing whotab entry if process does not appear in whotab.
      I) Upgraded for change to answer_table.incl.pl1 and
         user_table_entry.incl.pl1.
  8) change(87-05-12,GDixon), approve(87-07-06,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
      A) Don't send warning of other login to disconnected or UFT processes.
         Neither could receive the warning or acted upon invalid logins.
  9) change(87-05-14,GDixon), approve(87-07-06,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
      A) Avoid null_pointer fault when notifying MNA user of another login.
 10) change(87-06-22,GDixon), approve(87-07-06,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
      A) Print login info when -brief is given (or defaults) and
         ute.active = NOW_LOGGED_IN.  Because it is being set to that
         prior to the test.
 11) change(87-06-22,GDixon), approve(87-06-30,MCR7656),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
      A) Set outer module properly for hasp operator console logins.
      B) Avoid null_pointer fault when notifying MCS user of already-logged in
         DSA user.
 12) change(87-06-23,GDixon), approve(87-07-06,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
      A) Move auditing of all logins involving process creation into
         as_access_audit_.  Continue to audit operator login/logout and
         connect loop logouts here.
 13) change(87-08-07,GDixon), approve(87-08-07,MCR7741),
     audit(87-08-07,Brunelle), install(87-08-10,MR12.1-1076):
      A) Call ASSERT_LOGGED_IN_STATE when "login Person -connect" was given
         and that person.project has no disconnected processes.
 14) change(87-10-04,Beattie), approve(87-10-26,MCR7785),
     audit(87-12-04,Parisek), install(87-12-07,MR12.2-1008):
     Accomodate changes in format of date_time strings.
 15) change(87-11-20,Parisek), approve(88-02-11,MCR7849),
     audit(88-02-23,Lippard), install(88-07-13,MR12.2-1047):
     Set the new answer_table element ute.lowest_ring to the highest of PDTs
     low ring value and SATs low ring value. SCP6367
 16) change(88-05-02,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-03,Lippard), install(88-08-29,MR12.2-1093):
      A) Changed to expand project alias -change_default_project is used to
         modify pnte.default_project.
 17) change(89-01-17,TLNguyen), approve(89-01-17,MCR8054),
     audit(89-02-06,Parisek), install(89-02-27,MR12.3-1015):
     Supply the correct number of arguments relative to the control codes
     specified in a ioa_ control string for a call to sys_log_ to
     log the disconnected count for a user.
                                                   END HISTORY COMMENTS */

/* format: style4 */

lg_ctl_: procedure ();

/* LOGIN_CONTROL - User Control procedure to determine whether, and how,
   a given user who identified himself with a name/password/project
   combination should be logged into the system. It also contains the
   procedure to log a user out, and manages the system "whotab" which
   publishes who's logged in. */

/*
   Initially coded by Michael J. Spier, September 18, 1969
   Revised and recoded in PL/1 by Michael J. Spier, 12.22.69
   mod 8/14/70 to allow unregistered responders & correct for bumping oldest, THVV
   changed for absentee feb 71 EDS
   variable attributes & load ctl, THVV 12/71
   dynamic changing of password, J. Phillipps 7/72
   Modified 740821 by PG for authorizations, misc. bug fixes, etc.
   Modified 750313 by T. Casey to pass pnt size to up_pnt_$make_hash.
   Modified 750604 by T. Casey to move setting of load control group (ate.group) to load_ctl_
   .	(it got too complicated, with the coming of the priority scheduler)
   Modified 750805 by THVV for cdte
   Modified 751024 by T. Casey to process name of prelinked subsystem, from login line or from pdt.
   Modified 751110 by PG to change handling of -gpw errors
   Modified April 1976 by T. Casey to move check for correct typing of generated password to dialup_, and
   .		to initialize ate.recent_fatal_error_(time count).
   Modified 760804 by THVV for sending mail and telling long info as answer
   Modified July 1976 by T. Casey to make "initproc,direct" work right.
   Modified 760819 by Roy Planalp to pass error msg up to dialup_/ftp_dialup_,
   .	to send mail for bad pw, to obey -brief ctl arg, and not allow login if illegal ctl args are used.
   Modified October 1976 by T. Casey to fix bad password counting.
   Modified January, 1977, by D. M. Wells, to include line types in PDT user structure
   Modified April, 1977, by D. M. Wells, to fix bug introduced last time that caused
   .	term types to be wrong for the first login with AS 9.2
   Modified June, 1977, by Robert Coren to use TTT-style terminal types
   Modified September 1977 by T. Casey to prevent hanging up after login refusal in cases
   .	where successful login might be possible with differnt args.
   Modified May 1978 by T. Casey to put min of project and user pdir quota figures into user table entry,
   .	and to log instances of init_ring, max_ring, or pdir_quota in PDTE exceeding limits in SATE.
   Modified June 1978 by T. Casey to use hash tables to search SAT and PDTs.
   Modified Fall 1978 by Larry Johnson for ring-0 demultiplexing.
   Modified November 1978 by T. Casey for MR7.0 absentee enhancements.
   Modified April 1979 by T. Casey for MR7.0a to fix bugs in foreground absentee implementation.
   Modified July 1979 by B. Margulies to remove the v_outer_module attribute.
   Modified July 1979 by T. Casey for MR8.0 to support process preservation across hangups.
   Modified July 1979 by C. Hornig for new MSF PNT.
   Modified January 1980 by T. Casey to fix bugs in process preservation.
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA)
   Modified September 1980 by C. Hornig to send login denial messages at user's default authorization
   Modified 1980*12*31 B. Margulies for reconnection outer module switch.
   Modified April 13 1981 by E. N. Kittlitz to honour -bf with disconnected procs
   Modified June 1981 by E. N. Kittlitz for UNCA rate structures
   Modified June 1981 by T. Casey for MR9.0 to improve absentee load control efficiency,
   .	by returning load_ctl_'s detailed reason for deferral to AUM.
   Modified September 1981 by E. N. Kittlitz to assume 'create' for FTP logins.
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified December 1981, E. N. Kittlitz.  whotab header extension.
   Modified April 1982, E. N. Kittlitz. New AS initialization.
   Modified June 1982,  E. N. Kittlitz. Force pdt disconnected count if it disagrees with answer_table.
   Modified September 1982, E. N. Kittlitz. dial/slave -user support. default login ring.
   Modified February 1983, E. N. Kittlitz. sort_disc_list fix per Schiller identified problem.
   Modified February 1983, J. Schiller to allow multiple connection loops for a user, and to fix bug so that max_ring is enforced (once again).
   Modified May 1983, E. N. Kittlitz. stop cross-AIM creates if AIM required on channel.
   Modified July 1983, B. Margolin, to update the Mail Table when the user changes his default project.
   Modified 84-04-02 BIM for AIM ranges on communications channels.
   Modified 84-07-12 BIM for login AIM ranges.
   Modified 84-08-28 by E. Swenson for Version 2 PNT calling sequences.
   Modified 10/02/84 by R. Michael Tague: Changed the directory containing
   the ACS segments for the device channels from as_data_$acsdir to
   as_data_$rcpdir.
   Modified 84-10-03 by E. Swenson to incorporate Jim Falksen's changes
   for date_time_$format.
   Modified 84-10-26 by E. Swenson to not respect the "brief" flag for
   security-relevant messages and to disregard the project-id in
   deciding whether to notify of additional logins.
   Modified 84-11-14 by E. A. Ranzenbach for whotab.session...
   Modified 84-12-17 by EJ Sharpe to use merge_access_audit_flags_
   Modified 1985-01-10, BIM: MC access control.
   Modified 85-01-10 by E. Swenson restructured for new AS auditing.
   Modified 85-01-15 by Keith Loepere for pdir_dir_quota.
   Modified 1985-01-23 by E. Swenson for binary audit messages.
   Modified 1985-02-12 by E. Swenson to fix multip checking.
   Modified 1985-03-04 by E. Swenson for password restrictions.
   Modified 1985-04-17 by E. Swenson to check for damaged PDTs.
   Modified 1985-04-19 by E. Swenson to initialize anstbl.session to
   "special" for special session rather than "init".
   Modified 1985-04-24 by E. Swenson to set projectid before notifying of
   bad passwords.
*/

/* pictures */

dcl  four_digits picture "9999";

/* builtins */

dcl  (addr, addrel, clock, index, length, max, min, mod, null,
     reverse, rtrim, string, substr, unspec, verify) builtin;

/* entries */

dcl  act_ctl_$check entry (ptr, ptr, char (8) aligned, char (*) varying, fixed bin (35));
dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
dcl  astty_$tty_force entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  as_access_audit_$login entry (ptr, char(*));
dcl  as_access_audit_$logout entry (ptr, char(*));
dcl  asu_$blast_user entry (ptr, char (*), char (*), fixed bin (35));
dcl  asu_$format_ftp_msg entry (char (200) aligned, fixed bin, fixed bin, fixed bin) returns (char (200) aligned);
dcl  asu_$write_message entry (ptr, fixed bin (35), char (8) aligned, fixed bin (35));
dcl  display_access_class_ entry (bit (72) aligned) returns (character (32) aligned);
dcl  display_access_class_$range entry ((2) bit (72) aligned) returns (character (32) aligned);
dcl  convert_access_class_$maximum entry ((*) bit (72) aligned, fixed bin, bit (72) aligned);
dcl  convert_access_class_$minimum entry ((*) bit (72) aligned, fixed bin, bit (72) aligned);
dcl  convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_access_class_$to_string_range_short entry ((2) bit (72) aligned, character (*),
	fixed binary (35));
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  hash_$search entry (ptr, char (*), fixed bin, fixed bin (35));
dcl  hcs_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin, bit (36) aligned, bit (36) aligned,
	fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  ioa_$rs entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  load_ctl_ entry (ptr, ptr, ptr, ptr, fixed bin, char (8) aligned, char (*) varying, fixed bin (35));
dcl  load_ctl_$unload entry (ptr, fixed bin);
dcl  mail_table_initializer_$set_dft_proj entry (char (*) var, char (*), fixed bin (35));
dcl  mc_check_access_$log_in_as_daemon entry (char (*), char (*), fixed bin (35));
dcl  merge_access_audit_flags_ entry (bit (36) aligned, bit (36) aligned) returns (bit (36) aligned);
dcl  pnt_manager_$admin_get_entry entry (char (*), ptr, fixed bin (35));
dcl  pnt_manager_$login_get_entry entry (char (*), char (*), ptr, fixed bin (35));
dcl  pnt_manager_$update_entry entry (ptr, bit (1), bit (1), fixed bin (35));
dcl  scramble_ entry (char (8) aligned) returns (char (8) aligned);
dcl  send_mail_$access_class entry (char (*), char (*), ptr, bit (72) aligned, fixed bin (35));
dcl  sub_err_ entry () options (variable);
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);
dcl  ttt_info_$decode_type entry (fixed bin, char (*), fixed bin (35));
dcl  ttt_info_$encode_type entry (char (*), fixed bin, fixed bin (35));
dcl  up_sat_$make_sat_hash entry (ptr, fixed bin, ptr, char (*), fixed bin (35));

/* external static */

dcl  as_error_table_$already_in_msg fixed bin (35) ext;
dcl  as_error_table_$already_in_notify_msg fixed bin (35) ext;
dcl  as_error_table_$already_in_warn_msg fixed bin (35) ext;
dcl  as_error_table_$bad_anon_pw fixed bin (35) ext;
dcl  as_error_table_$bad_password fixed bin (35) ext;
dcl  as_error_table_$bad_personid fixed bin (35) ext;
dcl  as_error_table_$bad_project fixed bin (35) ext;
dcl  as_error_table_$breach fixed bin (35) external;
dcl  as_error_table_$cant_give_dft_auth fixed bin (35) external;
dcl  as_error_table_$cant_give_that_authorization fixed bin (35) external;
dcl  as_error_table_$dft_auth_changed fixed bin (35) external;
dcl  as_error_table_$dft_proj_changed fixed bin (35) ext;
dcl  as_error_table_$dialup_error fixed bin (35) ext;
dcl  as_error_table_$illegal_hd_arg fixed bin (35) ext;
dcl  as_error_table_$illegal_ip_arg fixed bin (35) ext;
dcl  as_error_table_$illegal_om_arg fixed bin (35) ext;
dcl  as_error_table_$illegal_save_arg fixed bin (35) ext;
dcl  as_error_table_$illegal_ss_arg fixed bin (35) ext;
dcl  as_error_table_$last_login_msg fixed bin (35) ext;
dcl  as_error_table_$login_anon_msg fixed bin (35) ext;
dcl  as_error_table_$login_msg fixed bin (35) ext;
dcl  as_error_table_$long_ip_arg fixed bin (35) external;
dcl  as_error_table_$long_ss_arg fixed bin (35) external;
dcl  as_error_table_$multiple_login_msg fixed bin (35) external;
dcl  as_error_table_$must_change fixed bin (35) external;
dcl  as_error_table_$must_use_generate_pw fixed bin (35) external;
dcl  as_error_table_$n_disconnected_procs_msg fixed bin (35) ext;
dcl  as_error_table_$no_change fixed bin (35) ext;
dcl  as_error_table_$no_daemon_bit fixed bin (35) ext;
dcl  as_error_table_$no_disconnected_procs fixed bin (35) ext;
dcl  as_error_table_$no_line_permission fixed bin (35) ext;
dcl  as_error_table_$no_name fixed bin (35) ext;
dcl  as_error_table_$no_primary fixed bin (35) ext;
dcl  as_error_table_$not_in_pdt fixed bin (35) ext;
dcl  as_error_table_$password_changed fixed bin (35) ext;
dcl  as_error_table_$password_expired fixed bin (35) external;
dcl  as_error_table_$password_expired_msg fixed bin (35) external;
dcl  as_error_table_$password_locked fixed bin (35) ext;
dcl  as_error_table_$password_probe1_mail_msg fixed bin (35) ext;
dcl  as_error_table_$password_probe1_msg fixed bin (35) ext;
dcl  as_error_table_$password_probe_mail_msg fixed bin (35) ext;
dcl  as_error_table_$password_probe_msg fixed bin (35) ext;
dcl  as_error_table_$password_unused_too_long_msg fixed bin (35) external;
dcl  as_error_table_$pdt_missing fixed bin (35) ext;
dcl  as_error_table_$ring_too_low fixed bin (35) ext;
dcl  as_error_table_$ring_too_high fixed bin (35) ext;
dcl  as_error_table_$special_sess_msg fixed bin (35) ext;
dcl  as_error_table_$user_fg_cpu_limit fixed bin (35) ext;
dcl  as_error_table_$user_max_bg fixed bin (35) ext;
dcl  as_error_table_$user_max_fg fixed bin (35) ext;
dcl  error_table_$bad_password 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;
dcl  error_table_$messages_off fixed bin (35) external;
dcl  error_table_$out_of_sequence fixed bin (35) ext static;
dcl  error_table_$smallarg fixed bin (35) external;
dcl  error_table_$wakeup_denied fixed bin (35) external;

/* Internal Static */

dcl  (pdt_htp) ptr int static init (null);
dcl  tracing bit (1) aligned int static init ("0"b);	/* trace switch */

/* Constants */

dcl  DISC_STATE (0:5) char (12) internal static options (constant) initial
	(
	"connect loop",				/* no command */
	"connect loop",				/* list */
	"create",					/* create */
	"connect",				/* connect */
	"new_proc",				/* new_proc */
	"destroy"					/* destroy */
	);

dcl  ME char (7) initial ("lg_ctl_") internal static options (constant);
dcl  NL char (1) int static options (constant) init ("
");
dcl  PT_DIAL_SLAVE initial (-1) fixed bin internal static options (constant);
dcl  USECS_PER_DAY fixed bin (71) initial (86400000000) internal static options (constant);

dcl  SUCCESS bit (1) aligned initial ("1"b) internal static options (constant);

/* Automatic */

dcl  ans char (64);
dcl  answer char (200) aligned;			/* message buffer */
dcl  authorization (3) bit (72) aligned;
dcl  authorization_string char (200);
dcl  bstemp bit (36) aligned;
dcl  char64 char (64);				/* temporary */
dcl  code fixed bin (35);
dcl  coded_type fixed bin;				/* numeric form of terminal type */
dcl  debg char (8) aligned init ("");			/* Short message from as_error_table_ */
dcl  errmsg char (168) varying;
dcl  first_pass bit (1) aligned;			/* whether this is the first pass or not */
dcl  flonginfo char (100) aligned;			/* this is used to get long messages out of as_error_table_ */
dcl  i fixed bin;
dcl  id_code char (4) aligned;			/* idcode */
dcl  l fixed bin;
dcl  last_term_type char (32);			/* used when printing previous login info */
dcl  login_state char (12);				/* what the user is doing */
dcl  logout_reason char (12);				/* reason for the logout */
dcl  mcode fixed bin (35) init (0);			/* Error code, which is reason for no login. */
dcl  octal_auth_string char (32) aligned;
dcl  p ptr;
dcl  password_changed_flag bit (1) initial ("0"b);	/* Indicates we changed the password */
dcl  pdt_name char (32);
dcl  pdtep ptr;
dcl  pdtp ptr;
dcl  process_type fixed bin (17);			/* -1 => dial/slave validation, 1 = interactive, 2 = absentee, 3 = daemon */
dcl  process_types (-1:3) char (3) initial (
	"int",
	"???",
	"int",
	"abs",
	"dmn");
dcl  rewrite_pnte bit aligned;
dcl  satep ptr;
dcl  scan_reason fixed bin;				/* why should we scan the answer table: 0 = don't; 2 = find current login instance, warn it, and explain refusal; 3 = notify current login instances of the new login instance. */
dcl  tcdtep ptr;
dcl  temp_coded_type fixed bin;			/* temporary version of same */
dcl  temp_person_name char (28);			/* for searching PDT */
dcl  temp_term_type char (32);			/* sometimes holds random device type */
dcl  tty_term_type char (32) aligned;			/* current device type */
dcl  user_limit bit (1) aligned init (""b);		/* 1 if login rejected because of fg or bg limit */
dcl  userx fixed bin;
dcl  vlonginfo char (100) varying;
dcl  w_date char (80) aligned;
dcl  xdebg char (8) aligned;				/* .. same when is to be thrown away */
dcl  xlonginfo char (100) varying;			/* these are used to hold message control formats */
dcl  xpw char (8);

dcl  1 old_pnte aligned like pnt_entry;
dcl  1 pnte aligned like pnt_entry;

/* Parameters */

dcl  P_cdtep ptr parameter;				/* pointer to cdt entry for logout */
dcl  P_code fixed bin (35) parameter;			/* error code for caller */
dcl  P_password char (8) aligned parameter;		/* password to check */
dcl  P_reason char (*) parameter;			/* reason for a no-process logout */
dcl  P_startflag bit (1) aligned parameter;		/* session type */
dcl  P_status char (*) parameter;			/* text message for caller */
dcl  P_text char (168) varying parameter;		/* text message for caller */
dcl  P_utep pointer parameter;			/* user_table_entry pointer */

/* Conditions */

dcl  seg_fault_error condition;			/* for checking for PDT damage */
%page;
/* Program */

MAIN_RETURN:					/* main return point */
	return;
%page;
init: entry (P_startflag);

	if ^sc_stat_$Multics_typed | sc_stat_$Go_typed then
	     call sub_err_ (error_table_$out_of_sequence, "lg_ctl_$init", "s");
	ansp = as_data_$ansp;

	if ^P_startflag then do;			/* Starting special session? */
	     anstbl.session, whotab.session = "special";	/* indicate system is in special session */
	     four_digits = mod (clock (), 10000);	/* Generate a number between 000 and 9999 */
	     anstbl.login_word = four_digits;		/* and use it as login word */
	     call sys_log_ (SL_LOG, "lg_ctl_: login word is ""^a""", anstbl.login_word);
	     call ioa_$rs (convert_message (as_error_table_$special_sess_msg), anstbl.special_message, i, "");
	     anstbl.message_lng = i;
	     anstbl.message_update_time = clock ();
	end;
	else do;					/* Normal startup. */
	     anstbl.session, whotab.session = "normal";	/* Set session type. */
	     anstbl.login_word = "login   ";		/* Set standard login word. */
	end;

/* now reset all project entries in the system administrator's table */

	do i = 1 to sat.current_size;			/* Do all SAT entries. */
	     satep = addr (sat.project (i));		/* Get ptr to project entry. */
	     project.pdt_ptr = null;			/* reset project's PDT pointer */
	end;

	return;					/* Done. */
%page;
abs_in: entry (P_utep, P_status, P_code);

/**** This entry is called when attempting to log an absentee user in. */

/**** The path being followed here to validate absentee process
      logins needs to be kept in sync with path followed by interactive
      process logins in the login entrypoint.  This is important to
      maintain equivalent functional testing for both kinds of processes.
      If any changes are made within this entrypoint make sure 
      lg_ctl_$login is updated as needed. */

	P_status = "";

	call SETUP (PT_ABSENTEE);			/* copy parameters, set initial values */
	call VALIDATE_PERSON ();
	call LOOKUP_PROJECT ();
	call PROCESS_ATTRIBUTES ();
	call DETERMINE_AUTHORIZATIONS ();
	call CHECK_PROCESS_LIMITS ();
	call SET_UP_FOR_PROCESS_CREATION ();
	goto login_returns;
%page;
daemon_in: entry (P_utep, P_status, P_code);

/**** This entry is called to validate an attempted daemon login */

	P_status = "";

	call SETUP (PT_DAEMON);
	call VALIDATE_PERSON ();
	call PROCESS_CHANGE_ARGUMENTS ();
	call PROCESS_AUTH_ARGUMENT ();
	call LOOKUP_PROJECT ();

	if ute.anonymous = 1 then do;
	     mcode = as_error_table_$not_in_pdt;
	     goto login_incorrect;
	end;

	call check_daemon_source_acs (mcode);
	if mcode ^= 0 then
	     go to login_abort_1;

	call PROCESS_ATTRIBUTES ();

/**** Ensure this user has the "daemon" attribute.  If not, do not allow
      the login.  This prevents operator mistakes and ensures operators
      don't log in just anyone. */

	if ^ute.at.daemon then do;
	     mcode = as_error_table_$no_daemon_bit;
	     go to login_incorrect;
	end;

	call DETERMINE_AUTHORIZATIONS ();
	call CHECK_PROCESS_LIMITS ();
	call SET_UP_FOR_PROCESS_CREATION ();
	goto login_returns;
%page;
validate: entry (P_utep, P_password, P_text, P_code);

/**** Special entry for validating the use of "dial" / "slave" preaccess
      commands. */

	call SETUP (PT_DIAL_SLAVE);
	call VALIDATE_PERSON ();
	call PERFORM_PASSWORD_CHECKS ();
	call CHECK_FOR_SECURITY_BREACH ();
	call PROCESS_CHANGE_ARGUMENTS ();
	call PROCESS_AUTH_ARGUMENT ();
	call LOOKUP_PROJECT ();

	if ute.anonymous = 1 then
	     if user.password ^= "" then		/* If anonymous user has password, check it. */
		if scramble_ (user.password) ^= P_password then do;
		     mcode = as_error_table_$bad_anon_pw;
		     go to login_incorrect;		/* anonymous user's password is incorrect */
		end;

	if cdte.flags.access_control.slave_dial then
	     if ^check_channel_acs () then do;
		mcode = as_error_table_$no_line_permission;
		go to login_abort_1;
	     end;

	call PROCESS_ATTRIBUTES ();
	call DETERMINE_AUTHORIZATIONS ();
	call CHECK_CHANNEL_ACCESS_CLASS ();

/* for dial and slave, allows server to learn name given on -user control argument. */
	cdte.user_name.project = substr (ute.project, 1, length (cdte.user_name.project));
	cdte.user_name.person = substr (ute.person, 1, length (cdte.user_name.person));
	ute.login_result = 0;
	mcode = 0;
	go to login_returns;
%page;
login: entry (P_utep, P_password, P_text, P_code);

/**** Come here to validate an interactive login */

/**** The path being followed here to validate interactive process
      logins needs to be kept in sync with path followed by absentee
      process logins in the abs_in entrypoint.  This is important to
      maintain equivalent functional testing for both kinds of processes.
      If any changes are made within this entrypoint make sure 
      lg_ctl_$abs_in is updated as needed. */

	call SETUP (PT_INTERACTIVE);

	first_pass = ute.active < NOW_LOGGED_IN;	/* remember this if the first pass */

	call VALIDATE_PERSON ();

/**** Here, we test for a fairly unusual condition, namely, that the user
      has logged in successfully, and we have already checked his password,
      and may have even changed it, and we've notified him of any bad
      passwords, and printed all the messages connected with a successful
      login.  But he had one or more disconnected processes and didn't give
      one of the connect arguments on the login line, so we returned to
      dialup_ to ask him what to do. And he said to create a new process.
      So now we're back here, to see if he can have another process, and
      if so, to set up the parameters for it. But we have to skip over the
      password checking and message printing that we already did.

      ute.active >= NOW_LOGGED_IN tells us that we're in this situation. */

	if ute.active < NOW_LOGGED_IN then do;		/* skip these checks, done already */
	     call PERFORM_PASSWORD_CHECKS ();
	     call CHECK_FOR_SECURITY_BREACH ();
	     call PROCESS_CHANGE_ARGUMENTS ();
	end;

	call PROCESS_AUTH_ARGUMENT ();
	call LOOKUP_PROJECT ();

	if ute.anonymous = 1 then
	     if user.password ^= "" then		/* If anonymous user has password, check it. */
		if scramble_ (user.password) ^= P_password then do;
		     mcode = as_error_table_$bad_anon_pw;
		     go to login_incorrect;		/* anonymous user's password is incorrect */
		end;


	if cdte.flags.access_control.login then
	     if ^check_channel_acs () then do;
		mcode = as_error_table_$no_line_permission;
		goto login_abort_1;
	     end;

	call PROCESS_ATTRIBUTES ();

	if ute.active < NOW_LOGGED_IN then		/* first trip through lg_ctl_ */
	     call SET_OUTER_MODULE ();

	call DETERMINE_AUTHORIZATIONS ();
	call CHECK_CHANNEL_ACCESS_CLASS ();
	call CHECK_PROCESS_LIMITS ();

/**** If this is not an anonymous login, we must check for such things
      as already logged in and ^multip, or for the existence of
      disconnected processes. */

	if ute.anonymous ^= 1 then
	     call CHECK_FOR_MULTIPLE_LOGINS ();

	call SET_UP_FOR_PROCESS_CREATION ();
	goto login_returns;
%page;
login_returns:
	if process_type ^= PT_DIAL_SLAVE & ute.uprojp ^= null then do;
						/* If project is empty, */
	     satep = ute.uprojp;			/* .. try to clean up our KST */
	     if project.n_users <= 0 then
		if project.project_id ^= "SysDaemon" then do;

/* See comment at label logout_returns. */

		     if project.n_users < 0
			| ute.login_result = 0 then	/* if n_users has illegal value, log it */
			call sys_log_ (SL_LOG_SILENT, "lg_ctl_: project.n_users = ^d for ^a (login ^a)",
			     project.n_users, project.project_id, ute.person);

/* *		     call hcs_$terminate_noname (project.pdt_ptr, code); /* */
/* *		     project.pdt_ptr = null;		/* If needed again we re-initiate. */
		end;
	end;

	if ute.login_result ^= 0 then do;
	     P_code = mcode;			/* return detailed reason to caller */
	     if ute.failure_reason = 1		/* if lg_ctl_ said no */
	     then do;				/* expand mcode into short and long messages */
		call convert_status_code_ (mcode, debg, flonginfo);
		i = length (flonginfo) + 1 - verify (reverse (flonginfo), " ");
		if process_type = PT_INTERACTIVE | process_type = PT_DIAL_SLAVE
						/* interactive/validate, return long message */
		then do;
		     if i = length (flonginfo) + 1	/* if expanded message was all blanks */
		     then P_text = "";		/* return a null string */
		     else P_text = substr (flonginfo, 1, i) || NL; /* else return message with NL appended */
		end;
		else if process_type = PT_ABSENTEE	/* if absentee, return message to AUM in P_status */
		then do;
		     P_status = flonginfo;
		end;
		else P_status, flonginfo = debg;	/* for daemons, return short form, and replace long one with it,
						   for use below */
	     end;
	     else do;				/* but if act_ctl_ or load_ctl_ said no, they returned errmsg */
		if process_type = PT_INTERACTIVE
		then P_text = errmsg;		/* return it in P_text for interactive */
		else if process_type = PT_ABSENTEE
		then P_status = errmsg;		/* or in P_status for absentee */
		else P_status = debg;		/* but just return the short form, for daemons */

		if process_type ^= PT_DAEMON		/* if not daemon */
		then flonginfo = errmsg;		/* put returned long message in flonginfo,
						   where lg_ctl_'s message would have been */
		else flonginfo = debg;		/* but if daemon, put the short message there */
	     end;
	end;

lrt2:						/* come here if reason is "already logged in" */

	if ute.login_result = 0 then			/* successful login */
	     if first_pass then			/* only do this the first time through */
		call AUDIT_LOGIN (SUCCESS);
	     else ;				/* don't log anything if we've already done it */

/**** Avoid logging 2nd and subsequent instances of absentee refused by load
      control.  */

	else do;
	     if ^(ute.login_result = 2 & ute.uflags.deferral_logged) then

		call AUDIT_LOGIN (^SUCCESS);

	     if ute.login_result = 2 then		/* if normal deferral */
		ute.uflags.deferral_logged = "1"b;	/* remember not to log deferral of this job again */
	end;

	if process_type ^= PT_INTERACTIVE & process_type ^= PT_DIAL_SLAVE then
	     P_status = flonginfo;			/* Tell daemon or abs about failure */
	else P_password = "";			/* .. blank password of interactive. */
	return;					/* Done. */
%page;
login_incorrect:
	if rewrite_pnte then
	     call maybe_write_pnte;
login_abort_2:
	ute.login_result = 2;			/* allow guy to try once more */
	if process_type = PT_ABSENTEE & ^user_limit then
	     ute.login_result = 1;			/* abs can only retry if user limit was reason */
	ute.failure_reason = 1;			/* lg_ctl_ proper threw him out */
	go to login_returns;

login_abort_1:
	ute.login_result = 1;			/* it's hopeless, hang him up right away */
	ute.failure_reason = 1;			/* lg_ctl_ proper threw him out */
	go to login_returns;
%page;
abs_out: entry (P_utep);

/**** This entry is called when an absentee process logs out */

	if as_data_$ansp = null then return;		/* procedure not initialized */
	ansp = as_data_$ansp;
	if as_procid ^= anstbl.as_procid then return;	/* privileged entry point */

	process_type = PT_ABSENTEE;			/* Absentee. */
	utep = P_utep;				/* copy ptr to AUT entry */

	if ute.queue > 0 then			/* if not foreground absentee */
	     whotab.abs_users = whotab.abs_users - 1;	/* decrease count of absentee users */
	else whotab.fg_abs_users = whotab.fg_abs_users - 1; /* else decrease foreground user count */
	go to logout_returns;
%page;
daemon_out: entry (P_utep);

	if as_data_$ansp = null then return;		/* procedure not initialized */
	ansp = as_data_$ansp;
	if as_procid ^= anstbl.as_procid then return;	/* privileged entry pint */

	process_type = PT_DAEMON;			/* daemon */
	utep = P_utep;				/* copy ptr */

	whotab.n_daemons = whotab.n_daemons - 1;	/* count down */
	go to logout_returns;
%page;
logout: entry (P_utep);

	if as_data_$ansp = null then return;		/* procedure not initialized */
	ansp = as_data_$ansp;
	if as_procid ^= anstbl.as_procid then return;	/* privileged entry point */

	process_type = PT_INTERACTIVE;		/* normal user */
	utep = P_utep;				/* copy ptr */

	if ^(ute.active = NOW_LOGGED_IN & ute.proc_create_ok) then do; /* check if ute has a real, logged in user */
	     call sys_log_ (SL_LOG_SILENT, "lg_ctl_$logout: called with active=^d,^[^;^^^]proc_create_ok for ^a.^a ^a ute ^p",
		ute.active, ute.proc_create_ok, ute.person, ute.project, ute.tty_name, utep);
	     return;				/* don't decrement counters twice */
	end;

logout_returns:
	call load_ctl_$unload (utep, process_type);	/* May promote somebody. */
	if ute.uprojp ^= null then do;		/* If project is empty, */
	     satep = ute.uprojp;			/* .. try to clean up our KST */
	     if project.n_users <= 0 then
		if project.project_id ^= "SysDaemon" then do;

/* There is a bug in the pdt reference counting, that causes the reference count to go to zero
   while there are still users logged in on the project. To avoid the repercussions arising
   from terminating a pdt while there are still pointers to it in other
   user table entries, the code to terminate the pdt is being commented out, and replaced
   by a statement to log the instance of the ref count going to zero, to help
   find the cause of the bug that is making it go to zero too soon. This will
   result in higher segment numbers being used in the initializer process, but there are 4095
   segment numbers available, and the bug that caused the lot to overflow when high segment numbers
   were used has been fixed in MR8.0 */

		     if project.n_users < 0 then	/* log only if illegal value */
			call sys_log_ (SL_LOG_SILENT, "lg_ctl_: project.n_users = ^d for ^a (logout ^a)",
			     project.n_users, project.project_id, ute.person);

/* *		     call hcs_$terminate_noname (project.pdt_ptr, code); /* */
/* *		     project.pdt_ptr = null;		/* If needed again we re-initiate. */
/* *		     ute.pdtep = null;		/* this ptr is now invalid; simfault if we try to use it */
		end;
	end;

	ute.active = NOW_DIALED;			/* indicate user no longer logged-in */

	whotab.n_users = whotab.n_users - 1;		/* count users down. */
	whotab.n_units = whotab.n_units - ute.user_weight;
	userx = ute.whotabx;			/* locate whotab entry */
	if userx ^= 0 then do;			/* If user had entry, free it. */
	     whotab.e (userx).active = NOW_FREE;	/* mark idle */
	     whotab.e (userx).person, whotab.e (userx).project = "";
	     whotab.e (userx).chain = whotab.freep;	/* chain free entries together. */
	     whotab.freep = userx;			/* put on top of chain */
	     ute.whotabx = 0;			/* unhook from anstbl */
	end;

	call AUDIT_LOGOUT ("");			/* perform auditing */
	return;
%page;
logout_no_process:
     entry (P_utep, P_reason);

/**** This entry is used by programs which effectively logout an
      anthenticated user, when no process is associated with the
      specified utep */

	if as_data_$ansp = null then return;
	ansp = as_data_$ansp;
	if as_procid ^= anstbl.as_procid then return;

	utep = P_utep;

/**** This entry is only used for interactive logins */

	process_type = PT_INTERACTIVE;

	call AUDIT_LOGOUT (P_reason);
	return;
%page;
logout_channel:
     entry (P_cdtep, P_reason);

/**** This entry is used by programs which effectively logout an authenticated
      user/channel when a process is not affected by the logout. */

	if as_data_$ansp = null then return;
	ansp = as_data_$ansp;
	if as_procid ^= anstbl.as_procid then return;

	cdtep = P_cdtep;				/* get pointer to the cdte */

	call sys_log_ (SL_LOG, "LOGOUT^20t^a.^a int ^a (^a)", 
	     cdte.user_name.person, cdte.user_name.project, cdte.name,
	     P_reason);

	cdte.user_name.person = "";			/* reset these values */
	cdte.user_name.project = "";
	return;
%page;
login_operator:
     entry (P_sc_subsystem_info_ptr, P_success_sw, P_operator_name, P_reason);

/**** This entry is called by sc_requests_ to log operator logins.
      Currently the password checking is done within sc_requests_,
      but this should be moved here for consistency. */

dcl  P_sc_subsystem_info_ptr ptr parameter;		/* pointer to relevant info */
dcl  P_success_sw bit (1) aligned parameter;		/* whether this is successful or not */
dcl  P_operator_name char (*) parameter;		/* name of operator logging in */

	sc_subsystem_info_ptr = P_sc_subsystem_info_ptr;

	call sys_log_ (SL_LOG, "LOGIN^[^; DENIED^]^20t^a.Operator opr ^a (^a)",
	     P_success_sw, P_operator_name, sc_subsystem_info.source_name,
	     P_reason);
	return;
%page;
logout_operator:
     entry (P_sc_subsystem_info_ptr, P_operator_name, P_reason);

/**** This entry is called by sc_requests_ to log operator logouts. */

	sc_subsystem_info_ptr = P_sc_subsystem_info_ptr;

	call sys_log_ (SL_LOG, "LOGOUT^20t^a.Operator opr ^a (^a)",
	     P_operator_name, sc_subsystem_info.source_name, P_reason);
	return;
%page;
trace_on:
     entry ();

	tracing = "1"b;
	call sys_log_ (SL_LOG, "lg_ctl_: tracing turned on.");
	return;


trace_off:
     entry ();

	tracing = "0"b;
	call sys_log_ (SL_LOG, "lg_ctl_: tracing turned off.");
	return;
%page;
convert_message:
     procedure (p_status_code) returns (char (100) varying);

declare  p_status_code fixed binary (35) parameter;
declare  long character (100) aligned automatic;

/* A side effect of invoking this function is that the short form of the
   message is available in the global variable xdebg */

	call convert_status_code_ (p_status_code, xdebg, long);

	return (rtrim (long, " "));

     end convert_message;
%page;
maybe_write_pnte:
     procedure ();

	call pnt_manager_$update_entry (addr (pnte),
	     password_changed_flag,			/* Are we changing the password? */
	     "0"b,				/* lg_ctl_ doesn't use the network password */
	     code);
	rewrite_pnte = "0"b;
	if code ^= 0 then do;
	     call sys_log_$error_log (SL_LOG_BEEP, code, "lg_ctl_", "Error updating PNT entry of ^a.", ute.person);
	     mcode = as_error_table_$dialup_error;
	     goto login_abort_2;
	end;
     end maybe_write_pnte;
%page;
check_channel_acs:
     procedure () returns (bit (1) aligned);

dcl  group_id char (32);
dcl  mode bit (36) aligned;
dcl  ok bit (1) aligned;
dcl  type char (8);
dcl  user_id char (32);

	if ute.login_flags.dial_pw then type = "dial";
	else if ute.login_flags.slave_pw then type = "slave";
	else type = "login";
	if ute.person = "" then mode = ""b;
	else do;
	     user_id = rtrim (ute.person) || "." || rtrim (ute.project);
	     group_id = rtrim (user_id) || "." || "a";
	     call hcs_$get_user_access_modes (as_data_$rcpdir, rtrim (cdte.name) || ".acs", group_id, 0, mode, ""b, code);
	     if code ^= 0 then do;
		call sys_log_$error_log (SL_LOG, code, "lg_ctl_", "Unable to check access for channel ^a.", cdte.name);
		mode = ""b;
	     end;
	end;

	ok = (mode & RW_ACCESS) = RW_ACCESS;

	if ^ok then
	     call sys_log_ (SL_LOG_SILENT, "lg_ctl_: ^a access to channel ^a by ^a denied by ACS.",
		type, cdte.name, user_id);
	return (ok);
     end check_channel_acs;
%page;
check_daemon_source_acs:
     procedure (code);

dcl  group_id char (32);
dcl  code fixed bin (35);

	call ioa_$rsnnl ("^a.^a.z", group_id, (0), ute.person, ute.project);
	call mc_check_access_$log_in_as_daemon (group_id, ute.tty_name, code); /* This logs its decision */
	return;

     end check_daemon_source_acs;
%page;
BAD_PASSWORD:
     procedure ();

/**** This procedure is called for interactive users when the password
      supplied is invalid.  This code was moved from the inline code
      for clarity. */

	pnte.n_bad_pw = pnte.n_bad_pw + 1;
	pnte.n_bad_pw_since_good = pnte.n_bad_pw_since_good + 1;
	pnte.time_last_bad_pw = anstbl.current_time;
	pnte.last_bad_pw_reported = "0"b;
	pnte.bad_pw_term_id = cdte.tty_id_code;
	pnte.bad_pw_term_type = cdte.current_terminal_type;
	pnte.bad_pw_line_type = cdte.cur_line_type;
	rewrite_pnte = "1"b;
	if pnte.n_bad_pw_since_good = 1
	then vlonginfo = convert_message (as_error_table_$password_probe1_mail_msg);
	else vlonginfo = convert_message (as_error_table_$password_probe_mail_msg);

	if vlonginfo ^= ""
	then do;
	     unspec (send_mail_info) = "0"b;		/* prepare to tell the user */
	     send_mail_info.version = 1;
	     send_mail_info.wakeup = "1"b;
	     send_mail_info.always_add = "1"b;
	     send_mail_info.sent_from = "login";

	     if pnte.n_bad_pw_since_good = 1 then
		call ioa_$rs (vlonginfo, answer, i, ute.person, tty_term_type, cdte.tty_id_code);
	     else call ioa_$rs (vlonginfo, answer, i, ute.person, pnte.n_bad_pw_since_good, tty_term_type, cdte.tty_id_code);

	     call ioa_$rsnnl ("^a.^a", pdt_name, (0), ute.person, ute.project);
	     call send_mail_$access_class (pdt_name, substr (answer, 1, i), addr (send_mail_info), pnte.default_person_authorization, code);
	     if (code ^= 0) & (code ^= error_table_$wakeup_denied) & (code ^= error_table_$messages_off)
	     then do;
		call ioa_$rsnnl ("^a.^a", pdt_name, (0), ute.person, pnte.default_project);
		call send_mail_$access_class (pdt_name, substr (answer, 1, i), addr (send_mail_info), pnte.default_person_authorization, code);

/* if that fails, we save the info to print later */

		if (code = 0) | (code = error_table_$wakeup_denied) | (code = error_table_$messages_off)
		then pnte.flags.last_bad_pw_reported = "1"b;
	     end;
	     else pnte.flags.last_bad_pw_reported = "1"b;
	end;
	if mod (pnte.n_bad_pw_since_good, installation_parms.login_tries - 1) = 0 then

/* Somebody is hacking. Tell operator */

	     call sys_log_ (SL_LOG_BEEP, "lg_ctl_: too many bad passwords for ^a.^a from ^a (^a terminal ""^a"").",
		ute.person, ute.project, ute.tty_name, tty_term_type, id_code);
	return;
     end BAD_PASSWORD;
%page;
CHECK_FOR_MULTIPLE_LOGINS:
     procedure ();

/**** This procedure is called for interactive, non-anonymous logins to
      check for the existence of other interactive processes.  If the
      user does not have the multip attribute and there are other interactive
      processes, the login is rejected.  Other cases are handled as well. */

	cdte.n_disconnected_procs = 0;		/* be sure there's no garbage in these */
	cdte.disconnected_ate_index = 0;
	if user.n_disconnected = 0 then do;		/* if user has no disconnected processes */
	     if cdte.disconnected_proc_command = 0	/* and user didn't give one of the special args */
		| cdte.disconnected_proc_command = 2 then do; /* or said -create, see if we can create a process for him */

		if ute.at.multip then		/* user has interactive processes, but it's ok */
		     scan_reason = 3;		/* but notify the current login instances of the new one */
		else scan_reason = 2;		/* he doesn't have multip; warn current one and say no to him */
	     end;

	     else do;
		call asu_$write_message (utep, as_error_table_$no_disconnected_procs, debg, code);
						/* say "You have no disconnected processes" */
		call ASSERT_LOGGED_IN_STATE ();
		call ASSERT_INTERACTIVE_LOGIN ();	/* record we are logged in */
		login_state = "connect loop";
		goto login_returns;
	     end;
	end;					/* end user has no disconnected processes */

	else do;					/* user does have disconnected processes */
	     if ute.active < NOW_LOGGED_IN then do;	/* if we didn't already do this */
		vlonginfo = convert_message (as_error_table_$n_disconnected_procs_msg);
		if (vlonginfo ^= "") & (^ute.at.brief | cdte.disconnected_proc_command = 0)
		then do;				/* if site hasn't turned off the message, say
						   You have N disconnected processes. */
		     call ioa_$rs (vlonginfo, answer, l, user.n_disconnected, (user.n_disconnected > 1));
		     call astty_$tty_force (cdtep, addr (answer), l, (0));
		end;
	     end;

	     if cdte.disconnected_proc_command = 2 then do; /* create */
		if ute.at.multip then		/* if its ok */
		     scan_reason = 3;		/* tell current instances about the new one */
		else scan_reason = 2;		/* warn current instance about the attempt */
	     end;
	     else if cdte.service_type ^= FTP_SERVICE then do; /* we'll do something with the disconnected processes */
		call ASSERT_LOGGED_IN_STATE ();
		call BUILD_DISCONNECTED_LIST ();
		call ASSERT_INTERACTIVE_LOGIN ();	/* record we are logged in */
		login_state = DISC_STATE (cdte.disconnected_proc_command);
		goto login_returns;
	     end;
	end;					/* end there are disconnected processes */

	if scan_reason ^= 0 then
	     call SCAN_ANSWER_TABLE (scan_reason);
	return;
     end CHECK_FOR_MULTIPLE_LOGINS;
%page;
SCAN_ANSWER_TABLE:
     procedure (P_reason);

/**** This procedure is called to scan the answer table for the existence
      of other interactive processes.  The reason for the scan is specified
      as P_reason.  2 specifies that we are to find any other
      instances warn them of the attempted login and refuse the login.
      3 specifies that we are to find any other instances and warn them
      of the new instance. */

dcl  P_reason fixed bin (17) parameter;			/* The reason why we are scanning */
dcl  found_identical_userid bit (1) aligned;		/* whether exact match found */
dcl  n_processes fixed bin (17);			/* number of other processes */
dcl  saved_utep ptr;				/* ptr to ute of other login instance for ^multip */
dcl  try_message bit (1) aligned;			/* whether to attempt a message */


	try_message = "1"b;				/* initially we will */
	found_identical_userid = "0"b;		/* not yet */
	n_processes = 0;

	do i = 1 to anstbl.current_size;		/* Scan through answer table. */
	     p = addr (anstbl.entry (i));		/* get pointer to answer table entry */
	     if p -> ute.active > NOW_LOGGED_IN		/* if this is a logged-in user with a process */
		& p ^= utep			/* (and not the temporary ate used by this dialup) */
		& p -> ute.person = ute.person	/* if the name is the same */
		& p -> ute.anonymous = 0		/* check only authenticated users */
	     then do;

		n_processes = n_processes + 1;	/* count user's processes as we find them */
		if p -> ute.project = ute.project	/* identical match */
		     & P_reason = 2			/* and we're we don't have multip */
		then do;
		     found_identical_userid = "1"b;
		     saved_utep = p;
		end;
	          if p -> ute.tag ^= TAG_UFT		/* if not a file transfer process */
		   & ^p -> ute.disconnected then	/* and not a disconnected process */

		call WARN_OF_ANOTHER_LOGIN (P_reason, try_message, found_identical_userid);
	     end;					/* end ate belongs to another instance of user logging in */
	end;					/* end scan of answer table */

	if P_reason = 2 & found_identical_userid then do; /* deny login */
	     mcode = as_error_table_$already_in_msg;	/* Too bad. */

	     if saved_utep -> ute.disconnected then	/* if logged in proc is disconnected, don't try to use the cdte */
		temp_term_type = "DISCONNECTED";	/* make up a reasonable terminal type */
	     else temp_term_type = saved_utep -> ute.terminal_type;

	     call ioa_$rs (convert_message (mcode), P_text, l,
		saved_utep -> ute.person, saved_utep -> ute.project,
		temp_term_type,
		saved_utep -> ute.tty_id_code);
	     ute.login_result = 2;			/* Login is denied, but don't hang up on the user */
	     debg = xdebg;				/* log reason for denial */
	     ute.failure_reason = 1;
	     go to lrt2;				/* take special return */
	end;					/* end reason = 2 */

	else if n_processes > 0			/* he has other processes */
	then do;					/* print "This is your Nth interactive login instance." */
	     n_processes = n_processes + 1;		/* add in this new process, too. */
	     xlonginfo = convert_message (as_error_table_$multiple_login_msg);
	     if (n_processes > 9) & (n_processes < 20)
	     then xdebg = as_data_$teens_suffix (n_processes);
	     else xdebg = as_data_$suffix (mod (n_processes, 10));

	     call ioa_$rs (xlonginfo, answer, i, n_processes, xdebg);
						/* "This is your 3rd interactive login instance." */
	     call astty_$tty_force (cdtep, addr (answer), i, code);
	end;
     end SCAN_ANSWER_TABLE;
%page;
BUILD_DISCONNECTED_LIST:
     procedure ();

/**** This procedure builds a list of all disconnected processes belonging
      to this user. */

dcl  back_thread fixed bin (17);			/* index of last disconnected process found */
dcl  i fixed bin (17);				/* temporary index of ute entries */
dcl  n_processes fixed bin (17);			/* number of other processes found */
dcl  p ptr;					/* temporary pointer to ute entries */

	n_processes = 0;				/* no processes found yet */
	back_thread = 0;				/* no entries yet */
	do i = 1 to anstbl.current_size;		/* scan through the answer table */
	     p = addr (anstbl.entry (i));		/* get pointer to ute */
	     if p -> ute.active > NOW_LOGGED_IN		/* if associated with a process */
		& p ^= utep			/* and not the temporary ute for this dialup */
		& p -> ute.anonymous = 0		/* and not a anonymous user */
		& p -> ute.person = ute.person	/* and the same personid */
		& p -> ute.project = ute.project	/* and the same project */
	     then do;
		n_processes = n_processes + 1;	/* increment number found */
		if p -> ute.disconnected then do;	/* found a disconnected one */
		     if back_thread = 0 then		/* list is empty */
			cdte.disconnected_ate_index = i; /* thread this ute onto the list header */
		     else addr (anstbl.entry (back_thread)) -> ute.next_disconnected_ate_index = i; /* else thread this ute onto the end of the list */
		     back_thread = i;		/* remember where the end of the list is */
		     cdte.n_disconnected_procs = cdte.n_disconnected_procs + 1; /* count the number of entries on the list */
		end;				/* end found a disconnected one */
	     end;					/* end found an appropriate process */
	end;					/* end scan of answer table */

	if cdte.n_disconnected_procs ^= user.n_disconnected then do; /* these got out of sync somehow */
	     call sys_log_ (SL_LOG, "^a: disconnected count for ^a.^a is ^d in cdte, ^d in pdte, n_processes = ^d.", ME, ute.person, ute.project, cdte.n_disconnected_procs, user.n_disconnected, n_processes);
	     user.n_disconnected = cdte.n_disconnected_procs; /* reset */
	end;
	if cdte.n_disconnected_procs > 1 then		/* we have some */
	     call SORT_DISC_LIST ();			/* sort the list */

	return;
     end BUILD_DISCONNECTED_LIST;
%page;
SORT_DISC_LIST:
     procedure ();

dcl  (lp1, lp2, lpp) ptr;
dcl  (li, ll, lx1, lx2) fixed bin;
dcl  sorted bit (1) aligned;

/* Interchange sort */

	sorted = ""b;				/* get the outer loop started */

	do ll = cdte.n_disconnected_procs to 2 by -1	/* each pass is 1 shorter than previous one */
	     while (^sorted);			/* quit early if we find them in order */

	     sorted = "1"b;				/* assume they're in order; this is turned off if we do an interchange */
	     lpp = null;				/* no previous entry */
	     lx1 = cdte.disconnected_ate_index;		/* index of first entry */

	     do li = 1 to ll - 1;			/* make one pass thru unsorted part of list */

/* Get indices and pointers to the next pair of entries to be compared.
   The list is singly-threaded. A -> B, B -> C, and C -> D. We are going to compare B and C,
   and interchange them if they are out of order. A might be the head of the list, and
   D might not exist. If we interchange, we will want to end up with:
   A -> C, C -> B, B -> D. lpp is ptr to A. lx1, lp1 point to B, lx2, lp2 point to C,
   and lp2 -> ate.next_disconnected_ate_index  points to D. */

		lp1 = addr (anstbl.entry (lx1));	/* pointer to first item */
		lx2 = lp1 -> ute.next_disconnected_ate_index; /* index of second one of this pair */
		lp2 = addr (anstbl.entry (lx2));	/* ptr to it */

/* Compare login times. Interchange if first is younger than second. We want oldest process first in list */

		if lp1 -> ute.login_time > lp2 -> ute.login_time then do;
						/* if time1 is greater, proc1 is younger */
		     if li = 1 then			/* if A is head of list */
			cdte.disconnected_ate_index = lx2; /* make head be C */
		     else lpp -> ute.next_disconnected_ate_index = lx2; /* else make previous entry point at C */
		     lp1 -> ute.next_disconnected_ate_index = lp2 -> ute.next_disconnected_ate_index; /* make B point at D */
		     lp2 -> ute.next_disconnected_ate_index = lx1; /* make C point at B */
		     lpp = lp2;			/* C is now preceding */
						/* lx1 for compare with new next */
		     sorted = ""b;			/* remember that we did an interchange */
		end;				/* end interchange */
		else do;				/* no swap, just advance */
		     lpp = lp1;			/* now we're the previous item */
		     lx1 = lx2;			/* make second of previous pair the first of next pair */
		end;

	     end;					/* end one pass thru list */

	end;					/* end outer loop */

	return;

     end SORT_DISC_LIST;
%page;
WARN_OF_ANOTHER_LOGIN:
     procedure (P_reason, P_message_flag, P_identical_userid);

dcl  P_reason fixed bin (17) parameter;
dcl  P_message_flag bit (1) aligned parameter;
dcl  P_identical_userid bit (1) aligned parameter;
dcl  try_blasting bit (1) aligned;			/* whether to try blasting or not */

	try_blasting = "0"b;			/* not unless the we can't send the message */
	if P_reason = 2 & P_identical_userid
	then mcode = as_error_table_$already_in_warn_msg;
	else mcode = as_error_table_$already_in_notify_msg;

	vlonginfo = convert_message (mcode);
	if vlonginfo ^= "" then do;			/* unless site has disabled this */
	     call ioa_$rs (vlonginfo, answer, l, ute.person, ute.person,
		ute.project, tty_term_type, id_code);

	     if P_message_flag then do;		/* if we're to attempt a message */
		unspec (send_mail_info) = "0"b;
		send_mail_info.version = 1;
		send_mail_info.wakeup = "1"b;
		send_mail_info.always_add = "1"b;
		send_mail_info.sent_from = "answering service";
		call ioa_$rsnnl ("^a.^a", pdt_name, (0), p -> ute.person, p -> ute.project);
		call send_mail_$access_class (pdt_name, substr (answer, 1, l), addr (send_mail_info),
		     p -> ute.process_authorization, code);

		if (code = 0			/* if we succeeded in sending the message */
		     | code = error_table_$wakeup_denied/* or if it got into the mbx ok, but */
		     | code = error_table_$messages_off) then /* the user won't see it until he prints messages */
		     P_message_flag = "0"b;		/* remember not to do it again */
		else try_blasting = "1"b;
	     end;

/**** If we did not succeed in sending the message, try to blast this
      instance of the user.  If we can't a message, we will blast all
      instances of this user. */

	     if try_blasting then do;
		if ^p -> ute.disconnected		/* else if it isn't a disconnected process */
		     & ^p -> ute.at.no_warning	/* and it didn't log in -no_warning */
		then do;				/* then blast the warning on its terminal */
		     tcdtep = p -> ute.channel;
		     if tcdtep ^= null then		/* not MNA user */
		     if tcdtep -> cdte.service_type = FTP_SERVICE
		     then answer = asu_$format_ftp_msg (answer, l, l, 050);
		     call asu_$blast_user (utep, (answer), "", 0);
		end;				/* end not disconnected */
	     end;					/* end blast code */
	end;					/* end of site selectable code */

     end WARN_OF_ANOTHER_LOGIN;
%page;
NOTIFY_USER_OF_LOGIN:
     procedure ();

/**** This procedure is invoked when we have successfully "logged in".
      We notify the user of this (if we haven't already and if we wants
      to know.  */

	if ^ute.at.brief & ute.active < NOW_HAS_PROCESS then do;
						/* Do we print logged-in message? */
	     w_date = date_time_$format ("date_time", anstbl.current_time, "", ""); /* get login time in ASCII */
	     if ute.anonymous = 0 then xlonginfo = convert_message (as_error_table_$login_msg);
	     else xlonginfo = convert_message (as_error_table_$login_anon_msg);
	     call ioa_$rs (xlonginfo, answer, i,	/* Use error explanation as control string. */
		ute.person, ute.project, w_date, tty_term_type, id_code);
	     call astty_$tty_force (cdtep, addr (answer), i, code);

	     if ute.anonymous = 0 then do;		/* Compose last-login message */
		if user.last_login_time ^= 0 then do;	/* If ever logged in before. */
		     w_date = date_time_$format ("date_time", user.last_login_time, "", "");
		     xlonginfo = convert_message (as_error_table_$last_login_msg);
		     if xlonginfo ^= "" then do;	/* If installation wants this. */
						/* Due to an error on my part in the conversion */
						/* from AS 9.1a to AS 9.2, the old term_type */
						/* field is the new line_type field, thus */
						/* the strangeness in the next few lines. - dmw */
			if (user.last_login_type = 0) /* there is no term type 0 */
			then temp_coded_type = user.last_login_line_type; /* thus old form */
			else temp_coded_type = user.last_login_type;
			call ttt_info_$decode_type (temp_coded_type, temp_term_type, code);
			if code ^= 0 then temp_term_type = "";
			if user.last_login_line_type >= LINE_UNKNOWN
			     | user.last_login_type = 0 /* old form, no line type */
			then last_term_type = temp_term_type;
			else call ioa_$rsnnl ("^a ^a", last_term_type, (0),
				line_types (user.last_login_line_type),
				temp_term_type);
			call ioa_$rs (xlonginfo, answer, i, w_date,
			     last_term_type, user.last_login_unit);
			call astty_$tty_force (cdtep, addr (answer), i, code);
		     end;
		end;
	     end;
	end;
	return;
     end NOTIFY_USER_OF_LOGIN;
%page;
VALIDATE_PERSON:
     procedure ();

/**** This procedure validates the value of ute.person.  It checks
      the password for interactive logins and authenticated dial/slave
      use. */

	login_state = ute.login_code;

	rewrite_pnte = "0"b;
	if ute.person = "" then do;			/* It's hopeless. He didn't say who he was */
	     mcode = as_error_table_$no_name;		/* Tell him we need to know */
	     go to login_abort_2;			/* Give another chance. */
	end;
	if ute.anonymous = 1 then do;			/* Anonymous user? */
	     if ute.project = "" then
	          ute.project = substr(ute.person,1,length(ute.project));
						/* Can't have default project here */
	     return;				/* No PNT processing for anonymous users */
	end;

	if ute.login_flags.cpw
	then xpw = ute.old_password;
	else xpw = P_password;

/**** We only check passwords for interactive users, not daemons or
      absentees.  However, if we've already checked the password as
      in the case of connecting to a disconnected process, we don't
      check it again.  This latter condition is signaled by the
      ute.active >= NOW_LOGGED_IN.  In either case, we need the
      pnte entry for the specified user.

      Note that pnt_manager_$login_get_entry checks the supplied password
      while pnt_manager_$admin_get_entry does not. */

	if (process_type = PT_INTERACTIVE & ute.active < NOW_LOGGED_IN)
	     | process_type = PT_DIAL_SLAVE then
	     call pnt_manager_$login_get_entry ((ute.person), xpw, addr (pnte), code);
	else call pnt_manager_$admin_get_entry ((ute.person), addr (pnte), code);

	if code ^= 0 then do;
	     if code = error_table_$id_not_found	/* Invalid user-id */
	     then do;
		mcode = as_error_table_$bad_personid;
		goto login_incorrect;
	     end;
	     else if code = error_table_$checksum_failure /* Damaged PNT entry */
	     then do;
		call sys_log_$error_log (SL_LOG_BEEP, code, ME, "Checksum failure reading PNT entry of ^a.", ute.person);
		mcode = as_error_table_$dialup_error;
		goto login_abort_1;
	     end;
	     else if code = error_table_$bad_password	/* Only for interactive users */
	     then do;
		ute.person = substr (pnte.user_id, 1, length (ute.person)); /* In case alias was used */
		if ute.project = "" then
		     ute.project = substr(pnte.default_project,1,length(ute.project));
		call BAD_PASSWORD ();
		mcode = as_error_table_$bad_password;
		goto login_incorrect;
	     end;
	     else do;				/* Some other error we don't know how to handle */
		call sys_log_$error_log (SL_LOG_BEEP, code, ME, "Error reading PNT entry of ^a.", ute.person);
		mcode = as_error_table_$dialup_error;
		goto login_abort_1;
	     end;
	end;

	old_pnte = pnte;				/* Save copy of pnt entry since we're about to modify it */

	ute.person = substr (pnte.user_id, 1, length (ute.person)); /* Found in PNT. Put real name in case alias. */
	if ute.project = "" then do;
	     ute.project = substr(pnte.default_project,1,length(ute.project));
	end;
     end VALIDATE_PERSON;
%page;
PROCESS_CHANGE_ARGUMENTS:
     procedure ();

/**** This procedure process the -change_default_project, and
      -change_default_authorization control arguments to the login command */

	if ute.anonymous = 1 then			/* anonymous users aren't allowed */
	     return;

	if ute.login_flags.cdp then			/* Default project change requested? */
	     if ^pnte.flags.nochange then do;		/* Ok to do this? */
	          call hash_$search (sat_htp, ute.project, i, code);
		if code = 0 then do;		/* If project alias used, expand it. */
		     satep = addr(sat.project(i));
		     if ute.project ^= project.project_id then
		     if ute.project  = project.alias then
			ute.project = project.project_id;
		     end;
		pnte.default_project = ute.project;	/* Set new value. */
		rewrite_pnte = "1"b;
		if ^ute.at.brief
		then call asu_$write_message (utep, as_error_table_$dft_proj_changed, debg, code);
	     end;
	     else do;
		mcode = as_error_table_$no_change;
		go to login_incorrect;
	     end;

	if ute.login_flags.cda			/* Default authorization change requested? */
	then if ^pnte.flags.nochange			/* OK? */
	     then do;
		pnte.default_person_authorization = ute.process_authorization;
		rewrite_pnte = "1"b;
		if ^ute.at.brief
		then call asu_$write_message (utep, as_error_table_$dft_auth_changed, debg, code);
	     end;
	     else do;				/* Not allowed to change things. */
		mcode = as_error_table_$no_change;
		goto login_incorrect;
	     end;

	if ute.login_flags.cdp & rewrite_pnte then do;
	     call mail_table_initializer_$set_dft_proj (rtrim (pnte.user_id), rtrim (pnte.default_project), code);
	     if code ^= 0 then
		call sys_log_$error_log (SL_LOG_BEEP, code, "lg_ctl_", "Changing Mail Table default project for ^a to ^a",
		     pnte.user_id, pnte.default_project);
	end;
	if rewrite_pnte then call maybe_write_pnte;
	return;

     end PROCESS_CHANGE_ARGUMENTS;
%page;
PERFORM_PASSWORD_CHECKS:
     procedure ();

/**** This procedure performs various checks on the password flags stored
      in the PNT and on the password options specified on the command line. */


	if ute.anonymous = 1 then
	     return;				/* we do not perform these checks for anonymous users */

	if ute.login_flags.cpw & ^ute.login_flags.generate_pw & pnte.flags.generate_pw then do;
	     mcode = as_error_table_$must_use_generate_pw;
	     goto login_incorrect;
	end;

	if ^ute.login_flags.cpw then			/* if he didn't ask to change */
	     do;
	     if pnte.flags.must_change then
		do;
		if ^pnte.flags.generate_pw then
		     mcode = as_error_table_$must_change;
		else mcode = as_error_table_$must_use_generate_pw;
		goto login_incorrect;
	     end;
	     if installation_parms.password_change_interval ^= 0 then
						/* and the site has an enforced interval */
		if (anstbl.current_time - pnte.time_pw_changed) >
		     (installation_parms.password_change_interval *
		     USECS_PER_DAY) then
		     do;
		     vlonginfo = convert_message (
			as_error_table_$password_expired_msg);
		     call ioa_$rs (vlonginfo, answer, i,
			installation_parms.password_change_interval);
		     call astty_$tty_force (cdtep, addr (answer), i, (0));
		     if ^pnte.flags.generate_pw then
			mcode = as_error_table_$must_change;
		     else mcode = as_error_table_$must_use_generate_pw;
		     goto login_incorrect;
		end;
		else ;
	end;

	if installation_parms.password_expiration_interval ^= 0 then
						/* and the site has an enforced interval */
/**** Check to see if last good password given longer ago than the limit */
	     if ((anstbl.current_time - pnte.time_last_good_pw) >
		(installation_parms.password_expiration_interval *
		USECS_PER_DAY)) &
/**** Check to see that an administrator has not yet re-validated the userid */
		((anstbl.current_time - pnte.user_validated_time) >
		(installation_parms.password_expiration_interval *
		USECS_PER_DAY)) then
		do;
		vlonginfo = convert_message (
		     as_error_table_$password_unused_too_long_msg);
		call ioa_$rs (vlonginfo, answer, i,
		     installation_parms.password_expiration_interval);
		call astty_$tty_force (cdtep, addr (answer), i, (0));
		mcode = as_error_table_$password_expired;
		goto login_incorrect;
	     end;
	     else ;

	pnte.n_good_pw = pnte.n_good_pw + 1;
	pnte.time_last_good_pw = anstbl.current_time;
	rewrite_pnte = "1"b;

/**** We used to check pnte.flags.last_bad_pw_reported here to decide
      whether to print the message "Your password was ..." on the terminal
      upon login.  Since it is possible (and likely) that the user logging
      in will have never seen the mail sent telling him that his password
      was used incorrectly, we remove that check and force the message
      on his terminal.  The theory is that if there really is someone trying
      to guess a password, and he does manage to succeed and get in, he
      will most likely delete any mail telling the REAL user that someone
      was hacking. */

	if pnte.n_bad_pw_since_good > 0 then do;	/* Security here */
	     w_date = date_time_$format ("date_time", pnte.time_last_bad_pw, "", "");
	     if pnte.n_bad_pw_since_good = 1
	     then vlonginfo = convert_message (as_error_table_$password_probe1_msg); /* Get singular-plural correct */
	     else vlonginfo = convert_message (as_error_table_$password_probe_msg); /* Tell user he has been tried. */
	     if vlonginfo ^= "" then do;		/* .. if installation wants this feature */
		temp_term_type = pnte.bad_pw_term_type;
		if pnte.bad_pw_line_type >= LINE_UNKNOWN
		then ;
		else call ioa_$rsnnl ("^a ^a", temp_term_type, (0), line_types (pnte.bad_pw_line_type),
			temp_term_type);

		if pnte.n_bad_pw_since_good = 1
		then call ioa_$rs (vlonginfo, answer, i, w_date,
			temp_term_type, pnte.bad_pw_term_id);
		else call ioa_$rs (vlonginfo, answer, i, pnte.n_bad_pw_since_good, w_date,
			temp_term_type, pnte.bad_pw_term_id);
		call astty_$tty_force (cdtep, addr (answer), i, code);
	     end;
	     pnte.last_bad_pw_reported = "1"b;
	     rewrite_pnte = "1"b;
	end;

	if pnte.last_bad_pw_reported
	then pnte.n_bad_pw_since_good = 0;

	if pnte.flags.trap then			/* Are we watching this guy? */
	     call sys_log_ (SL_LOG_BEEP, "lg_ctl_: password used ^a.^a ^a ^a ^a",
		ute.person, ute.project, ute.tty_name, tty_term_type, id_code);

	if (pnte.flags.pw_time_lock & anstbl.current_time < pnte.password_timelock)
	     | pnte.flags.lock then do;		/* is password locked? */
	     mcode = as_error_table_$password_locked;	/* Yes. No login for you. */
	     go to login_incorrect;			/* (but we won't tell you we caught you) */
	end;

	if ute.login_flags.cpw
	then if pnte.flags.nochange
	     then do;
		mcode = as_error_table_$no_change;
		goto login_incorrect;
	     end;
	     else do;
		pnte.password = P_password;
		password_changed_flag = "1"b;
		pnte.time_pw_changed = anstbl.current_time;
		pnte.flags.must_change = "0"b;
		rewrite_pnte = "1"b;
		if ^ute.at.brief
		then call asu_$write_message (utep, as_error_table_$password_changed, debg, code);
	     end;

	return;
     end PERFORM_PASSWORD_CHECKS;
%page;
PROCESS_AUTH_ARGUMENT:
     procedure ();

/**** If the user did not specify an authorization on the login line, then
      if anonymous, default to system_low, otherwise, use PNT default
      authorization */

	if ^ute.login_flags.auth_given then		/* If -auth not specified, use default */
	     if ute.anonymous = 1 then do;
		ute.process_authorization = ""b;
	     end;
	     else do;
		ute.process_authorization = pnte.default_person_authorization;
	     end;
	return;
     end PROCESS_AUTH_ARGUMENT;
%page;
LOOKUP_PROJECT:
     procedure ();

lookup_loop:
	call hash_$search (sat_htp, ute.project, i, code);
	if code ^= 0 then do;
proj_not_there: mcode = as_error_table_$bad_project;	/* Unknown project. */
	     go to login_incorrect;			/* Again, you lose. */
	end;
	satep = addr (sat.project (i));		/* get pointer to SAT entry that project hashes to */
	if ute.project ^= project.project_id then	/* it better be the right project */
	     if ute.project ^= project.alias then do;	/* otherwise the hash table has been clobbered */
		call sys_log_ (SL_LOG_BEEP, "lg_ctl_: sat.ht has ""^a"", SAT has ""^a"" at ^p",
		     ute.project, project.project_id, satep);
		call up_sat_$make_sat_hash (satp, sat.n_projects, sat_htp, ans, code);
		if code ^= 0 then do;
		     call sys_log_$error_log (SL_LOG_BEEP, "lg_ctl_", "unable to rehash sat.ht: ^a", ans);
		     mcode = as_error_table_$dialup_error;
		     goto login_abort_1;
		end;
		else goto lookup_loop;		/* go try the lookup again */
	     end;

	if project.state ^= 1 then do;
	     call sys_log_ (SL_LOG_BEEP, "lg_ctl_: project ^a, state ^d, still in sat.ht", project.project_id, project.state);
	     goto proj_not_there;
	end;


	ute.project = project.project_id;		/* in case alias was used */
	if project.pdt_ptr ^= null then pdtp = project.pdt_ptr; /* May have found PDT already. */
	else do;					/* initiate project's PDT */
	     pdt_name = rtrim (project.project_id) || ".pdt"; /* Stick on suffix */
	     call hcs_$initiate (pdtdir, pdt_name, "", 0, 0, pdtp, code);
	     if pdtp = null then do;			/* If pdt is missing, */
		call sys_log_$error_log (SL_LOG_BEEP, code, "lg_ctl_", "^a>^a", pdtdir, project.project_id);
		mcode = as_error_table_$pdt_missing;	/* Not able to log him in if no pdt */
		go to login_abort_2;		/* but user might have another project to try */
	     end;
	     project.pdt_ptr = pdtp;			/* save ptr in SAT for next time */
	end;
	if project.rs_number < 0 | project.rs_number > whotab.n_rate_structures then do;
	     call sys_log_ (SL_LOG_BEEP, "lg_ctl_: project ^a has invalid rate_structure number ^d. Using rate_structure 0.",
		project.project_id, project.rs_number);
	     ute.rs_number = 0;
	end;
	else ute.rs_number = project.rs_number;		/* plug in the rate_structure */

/* now search project's PDT to locate person's user profile */

	temp_person_name = ute.person;		/* name we are searching for */

	if ute.anonymous ^= 0 then			/* if user logging in is anonymous */
	     if ^project.at.anonymous then		/* but the project is not permitted anonymous users */
		goto not_in_pdt;			/* don't waste time searching */
	     else temp_person_name = "*";		/* search for "*" in pdt */

	pdtep = null ();				/* flag that we haven't found it yet */

/**** Here we test for a PDT with its damage switched turned on.  If the
      PDT is damaged, we refuse the login with our canned message and
      refuse the login. */

	on condition (seg_fault_error)
	     begin;
	     call sys_log_ (SL_LOG_BEEP, "lg_ctl_: PDT for project ^a has its damage switch set.  Login for user ^a refused.", ute.project, ute.person);
	     mcode = as_error_table_$dialup_error;
	     goto login_abort_1;
	end;

	i = pdt.ht_relp;				/* check for seg_fault_error */

	revert seg_fault_error;

	if pdt.ht_relp > 0 then do;			/* if hash table there, use it */
	     pdt_htp = addrel (pdtp, pdt.ht_relp);
	     if pdt_htp -> htable.id ^= "ht01" & pdt_htp -> htable.id ^= "ht02" then do; /* we gotta check at least a little bit */
		call sys_log_ (SL_LOG_BEEP, "lg_ctl_: no hash table at ^o of ^a.pdt", pdt.ht_relp, project.project_id);
	     end;
	     else do;
		call hash_$search (pdt_htp, temp_person_name, i, code);
		if code ^= 0 then goto not_in_pdt;
		pdtep = addr (pdt.user (i));
		if user.state ^= 1 then do;
		     call sys_log_ (SL_LOG_BEEP, "lg_ctl_: user ^a, state ^d, still in hash table of ^a.pdt",
			temp_person_name, user.state, project.project_id);
		     goto not_in_pdt;
		end;

		if user.person_id ^= temp_person_name then do;
		     call sys_log_ (SL_LOG_BEEP, "lg_ctl_: hash table of ^a.pdt has ^a, pdt has ^a, at ^p",
			project.project_id, temp_person_name, user.person_id, pdtep);
		     pdtep = null ();
		end;
	     end;
	end;

	if pdtep = null then			/* not found in hash table or bad hash table */
	     do i = 1 to pdt.current_size while (pdtep = null ()); /* Scan PDT entries. */
	     pdtep = addr (pdt.user (i));		/* Get ptr to entry. */
	     if user.state = 1 then do;		/* if this is an active PDT entry */
		if user.person_id ^= temp_person_name then /* if user name matches */
		     pdtep = null ();
	     end;
	     else pdtep = null ();
	end;

	if pdtep = null () then
not_in_pdt:    do;
	     mcode = as_error_table_$not_in_pdt;	/* Failed to find (regular/anonymous) entry. */
	     go to login_incorrect;
	end;
	ute.pdtep = pdtep;				/* save ptr to PDT entry, where accounting stuff is */
	ute.uprojp = satep;				/* ... and ptr to SAT entry too */
	return;
     end LOOKUP_PROJECT;
%page;
PROCESS_ATTRIBUTES:
     procedure ();

/* now, on with more mundane affairs */

	string (ute.ur_at) = string (ute.ur_at) &
	     ((string (user.at) & string (project.at)) |
	     USER_ATTRIBUTES_always_allowed);		/* Don't let user clear bits he's not allowed to alter */
	string (ute.at) = string (ute.at) | ^
	     USER_ATTRIBUTES_settable_by_user;		/* Turn on those user cannot turn off */
	string (ute.at) = string (ute.at) |
	     (string (user.at) & USER_ATTRIBUTES_default_in_pdt &
	     ^string (ute.ur_at));			/* turn on defaults if user didn't specify */
	string (ute.at) = string (ute.at) &
	     ((string (user.at) & string (project.at)) |
	     USER_ATTRIBUTES_always_allowed);		/* Turn off any user is not allowed to have */
	bstemp = string (ute.at) &
	     (string (ute.ur_at) | USER_ATTRIBUTES_settable_by_user);
						/* remember those that user set */
	string (ute.at) = string (ute.at) &
	     ^USER_ATTRIBUTES_settable_by_user;		/* turn off any bits that user is allowed to control. */
	string (ute.at) = string (ute.at) | bstemp;	/* turn on those that user or default turned on */

	if ute.at.guaranteed_login then ute.at.nobump = "1"b;

/* The process-saving attributes, disconnect_ok and save_on_disconnect, need special handling.
   After the above logic, each is on in ate.at only if it was on in both sate and pdte.
   First we force both on if both were on in sate. */

	if project.at.save_on_disconnect		/* if on in sate, force it on for all users on project */
	     & project.at.disconnect_ok then		/* (if project also has disconnect_ok), avoiding the need to */
	     ute.at.save_on_disconnect, ute.at.disconnect_ok = "1"b; /* install pdt to turn on saving for whole proj */

/* Then we turn on save_on_disconnect if it was on in the pdte, even if it wasn't on in the sate. */
	if user.at.save_on_disconnect then ute.at.save_on_disconnect = "1"b;

	if ute.anonymous = 1 then			/* if user is anonymous */
	     ute.at.save_on_disconnect, ute.at.disconnect_ok = ""b; /* we can't save his process */


/* Now, we look at the resulting attributes, together with the login arguments, and decide what to do. */

	if process_type = PT_INTERACTIVE then do;	/* only for an interactive process */
	     if ^cdte.nosave_arg then			/* user can always say -nosave, and this needs no permission */
						/* but if he didn't say it */
		if ute.at.disconnect_ok then		/* and he has permission to save disconnected processes */
		     if ute.at.save_on_disconnect	/* and he wants them to be saved by default */
			| cdte.save_arg then	/* or he asked for saving via the login argument */
			ute.uflags.save_if_disconnected = "1"b; /* then save this one if it becomes disconnected */

/* Finally, we abort with an error message if user gave -save argument but lacks permission. */

	     if cdte.save_arg & ^ute.at.disconnect_ok then do;
		mcode = as_error_table_$illegal_save_arg;
		goto login_incorrect;
	     end;
	end;
	return;

     end PROCESS_ATTRIBUTES;
%page;
DETERMINE_AUTHORIZATIONS:
     procedure ();

/**** Here we determine the user process authorization and maximum
      authorization.  We also set the audit flags. */

/* Currently, we only allow anonymous users to log in at system_low
   authorization.  To lift this restriction, all that is necessary
   is to delete the following statement. */

	if ute.anonymous = 1 then
	     ute.process_authorization = ""b;

	ute.process_authorization_range (*) = ""b;

/**** Set the process minimum authorization to the maximum of the following */

	authorization (1) = user.user_authorization (1);
	authorization (2) = project.project_authorization (1);
	if ute.anonymous = 1 then			/* anonymous have no pnte */
	     authorization (3) = project.project_authorization (1);
	else authorization (3) = pnte.person_authorization (1);

	call convert_access_class_$maximum (authorization, 3, ute.process_authorization_range (1));

/**** Set the process maximum authorization to the minimum of the following */

	authorization (1) = user.user_authorization (2);
	authorization (2) = project.project_authorization (2);
	if ute.anonymous = 1 then			/* anonymous have no pnte */
	     authorization (3) = project.project_authorization (2);
	else authorization (3) = pnte.person_authorization (2);

	call convert_access_class_$minimum (authorization, 3, ute.process_authorization_range (2));

/**** Merge the audit flags from the SAT and the PNT.  If the user is
      anonymous, there is no PNT entry and we've already set the ute.audit
      flags to the value in the SAT. */

	if ute.anonymous ^= 1			/* user is not anonymous */
	then ute.audit = merge_access_audit_flags_ (project.audit, pnte.audit);
	else ute.audit = project.audit;		/* anonymous users have no PNT entry */

/* Compare the requested or default authorization with the computed
   authorization range and reject the login if this authorization is
   outside the allowed range. */

	if ^aim_check_$in_range (ute.process_authorization /* requested | default */, ute.process_authorization_range)
	then do;
	     if ute.login_flags.auth_given | process_type = PT_ABSENTEE
	     then mcode = as_error_table_$cant_give_that_authorization;
	     else mcode = as_error_table_$cant_give_dft_auth; /* Cannot login at dft authorization */
	     go to login_incorrect;
	end;
	return;

     end DETERMINE_AUTHORIZATIONS;
%page;
CHECK_PROCESS_LIMITS:
     procedure ();

/* Now, check user's limit on foreground or background processes (whichever this is),
   and the user's max cpu time limit on foreground absentee jobs, if this is one. */

	scan_reason = 0;				/* no need to scan answer table yet */
	if ute.queue <= 0 then do;			/* foreground process */

	     if process_type = PT_ABSENTEE then do;	/* foreground absentee job; check cpu time limit */
		i = project.abs_foreground_cpu_limit;	/* pick up project limit */
		if i = 0 then i = user.abs_foreground_cpu_limit; /* zero means no project limit, so pick up user limit */
		else if user.abs_foreground_cpu_limit > 0 then /* nonzero project limit; if user limit nonzero, */
		     i = min (i, user.abs_foreground_cpu_limit); /* get the smaller of the two */
		if i > 0 then			/* if there is a limit */
		     if ute.max_cpu_time > i then do;	/* if limit too high, job is in error */
			mcode = as_error_table_$user_fg_cpu_limit; /* so reject it */
			goto login_abort_1;		/* 1 means fatal error, don't allow a retry */
		     end;
		if ^ute.at.pm_ok & ^ute.uflags.foreground_secondary_ok then do; /* fg job from no_primary user */
		     mcode = as_error_table_$no_primary;/* explain why */
		     goto login_abort_1;		/* and reject the job */
		end;
	     end;

	     i = project.max_foreground;		/* pick up project limit */
	     if i = 0 then i = user.max_foreground;	/* zero means no project limit, so pick up user limit */
	     else if user.max_foreground > 0 then	/* nonzero project limit; if user limit nonzero, */
		i = min (i, user.max_foreground);	/* get the smaller of the two */
	     if i > 0 then				/* if there is a limit */
		if user.n_foreground ^< i then do;	/* if user is at limit, refuse the login */

/* At this point, we must distinguish between a number of cases:
   1) user has one or more disconnected interactive processes, and doesn't want another one:
   - in this case, we want to go build a list of the disconnected processes and return it to dialup_;
   2) user wants another interactive process, but has one and doesn't have multip:
   - in this case, we go print an "already logged in from..." message, and warn
   - the existing process about the attempt;
   3) user wants another foreground process but is at his foreground limit:
   - in this case, we return the foreground limit error code.
*/

		     if process_type = PT_INTERACTIVE then do;
						/* interactive */
			if user.n_disconnected > 0 & cdte.disconnected_proc_command ^= 2 &
			     cdte.service_type ^= FTP_SERVICE then do; /* case 1 */
			     if ute.active < NOW_LOGGED_IN then do;
						/* if we didn't already do this */
				vlonginfo = convert_message (as_error_table_$n_disconnected_procs_msg);
				if (vlonginfo ^= "") & (^ute.at.brief | cdte.disconnected_proc_command = 0)
				then do;		/* if site hasn't turned off the message, say
						   You have N disconnected processes. */
				     call ioa_$rs (vlonginfo, answer, l, user.n_disconnected, (user.n_disconnected > 1));
				     call astty_$tty_force (cdtep, addr (answer), l, (0));
				end;
			     end;
			     call ASSERT_LOGGED_IN_STATE ();
			     call BUILD_DISCONNECTED_LIST (); /* build list of disconnected processes */
			     call ASSERT_INTERACTIVE_LOGIN (); /* record wherever appropriate that we are logged in */
			     login_state = DISC_STATE (cdte.disconnected_proc_command);
			     goto login_returns;
			end;

			if ^ute.at.multip & user.n_interactive > 0 then do; /* case 2 */
			     scan_reason = 2;	/* find the current process, warn it, and say no to this login */
			     call SCAN_ANSWER_TABLE (scan_reason);
			end;
		     end;				/* end interactive */
		     else do;			/* foreground absentee, case 3 */
			mcode = as_error_table_$user_max_fg;
			user_limit = "1"b;		/* remember to allow deferral and retry, if absentee */
			goto login_abort_2;		/* 2 means nonfatal error, allow retry */
		     end;				/* end foreground absentee, case 3 */
		end;
	end;

	else if ^ute.abs_run then do;			/* background absentee, and not abs run command */
	     i = project.max_background;		/* pick up project limit */
	     if i = 0 then i = user.max_background;	/* zero means no project limit, so pick up user limit */
	     else if user.max_background > 0 then	/* nonzero project limit; if user limit nonzero, */
		i = min (i, user.max_background);	/* get the smaller of the two */
	     if i > 0 then				/* if both were zero, there is no limit at all */
		if user.n_background ^< i then do;	/* if user is at limit, refuse the login */
		     mcode = as_error_table_$user_max_bg;
		     user_limit = "1"b;		/* remember to allow deferral and retry, if absentee */
		     goto login_abort_2;		/* 2 means nonfatal error, allow retry */
		end;
	end;

	return;
     end CHECK_PROCESS_LIMITS;
%page;
SET_UP_FOR_PROCESS_CREATION:
     procedure ();

	login_state = "create";			/* we're going to attempt to create a process */
	call act_ctl_$check (utep, satep, debg, errmsg, mcode); /* check for account's validity  */
	if mcode ^= 0 then do;
	     if process_type ^= PT_ABSENTEE then	/* if not absentee */
		ute.login_result = 2;		/* act_ctl_ threw him out; let user try different project */
	     else ute.login_result = 1;		/* but absentee can't try different project */
	     ute.failure_reason = 2;			/* record this fact here */
	     go to login_returns;
	end;

/**** Set up the initial procedure (initproc) and the subsystem (for
      prelinking) */

	call SETUP_INITIAL_PROCEDURE ();
	call SETUP_SUBSYSTEM ();

	call SETUP_LOGIN_RING ();

	if project.pdir_quota > 0			/* there is a limit */
	then do;
	     if user.pdir_quota > project.pdir_quota then
		call sys_log_ (SL_LOG_SILENT, "lg_ctl_: reduced pdir quota for ^a.^a from ^d (in PDTE) to ^d (in SATE)",
		     ute.person, ute.project, user.pdir_quota, project.pdir_quota);
	     ute.pdir_quota = min (project.pdir_quota, user.pdir_quota); /* constrain */
	end;
	else ute.pdir_quota = user.pdir_quota;		/* no limit, PA can ask for the ceiling! */

	ute.lot_size = user.lot_size;			/* Set up size of process tables */
	ute.kst_size = user.kst_size;			/* ... */
	ute.cls_size = user.cls_size;			/* ... */

/* Determine user's load control weight. */

	ute.user_weight = -1;			/* flags not set yet */

	do i = 1 to sat.uwt_size while (ute.user_weight = -1); /* scan User Weight Table to determine user's weight */
	     if ute.init_proc = sat.uwt (i).initproc then
		ute.user_weight = sat.uwt (i).units;	/* Found initproc. Extract weight. */
	end;

	if ute.user_weight = -1 then
	     ute.user_weight = as_data_$default_weight;	/* Unknown initproc. Assign default weight. */

/* Locate user's home directory, using default homedir and possible -hd login argument */

	if ute.home_dir ^= "" then			/* Specifying home dir. */
	     if ^ute.at.vhomedir then do;		/* he is not allowed */
		mcode = as_error_table_$illegal_hd_arg;
		go to login_incorrect;
	     end;
	     else ;				/* if he is allowed to set it, then nothing to do */
	else ute.home_dir = user.home_dir;		/* use PDT default */

/* User is legal for login. Check if he will overload system. */

	call load_ctl_ (utep, satep, pdtep, pntep, process_type, debg, errmsg, mcode);
	if mcode ^= 0 then
	     go to login_returns;			/* load_ctl_ said no go */
	call ASSERT_LOGGED_IN_STATE ();

	call PUBLISH_LOGIN ();

	ute.uflags.proc_create_ok = "1"b;		/* tell dialup_ that we've set the process creation variables */

	return;
     end SET_UP_FOR_PROCESS_CREATION;
%page;
PUBLISH_LOGIN:
     procedure ();

/* Now inform everybody else he's on */

	whotab.n_users = whotab.n_users + 1;		/* Increase user count in public database */
	whotab.n_units = whotab.n_units + ute.user_weight;/* And total weight. */

	if ute.at.nolist then ute.whotabx = 0;		/* Is this user an "unlisted" user? */
	else do;
	     if whotab.freep = 0 then do;		/* Listed user. Find slot in "whotab" */
		whotab.laste = whotab.laste + 1;	/* Grow whotab a little. */

/* The conversion from version 0 to version 1 of whotab requires that we fib about
   laste.  There are actually laste - laste_adjust entries.  See as_init_. */

		userx = whotab.laste - whotab.laste_adjust; /* no free slots. increase table size */
	     end;
	     else do;				/* have a free slot */
		userx = whotab.freep;		/* Take off chain (LIFO) */
		whotab.freep = whotab.e (userx).chain;	/* .. */
	     end;
	     ute.whotabx = userx;			/* Fill in answer_table slot so's we can delete */

	     if ute.anonymous = 1 then		/* Fill in "whotab" entry. */
		whotab.e (userx).person = "anonymous";	/* Anonymous users get no name. (might be obscene) */
	     else whotab.e (userx).person = ute.person;	/* Name of registered user */
	     whotab.e (userx).project = ute.project;	/* Publish project. */
	     whotab.e (userx).units = ute.user_weight;	/* Weight. */
	     whotab.e (userx).timeon = anstbl.current_time; /* Time of login. */
	     whotab.e (userx).anon = ute.anonymous;	/* Anonymous switch. */
	     whotab.e (userx).stby = ute.standby_line;	/* will be dummy for absentee */
	     whotab.e (userx).active = NOW_LOGGED_IN;	/* state. */
	     whotab.e (userx).idcode = id_code;		/* Set up terminal ID */
	     whotab.e (userx).group = ute.group;	/* Load group. */

	     whotab.e (userx).cant_bump_until = ute.cant_bump_until;
	     whotab.e (userx).proc_type = process_type;	/* 1 = interactive, 2 = absentee, 3 = daemon */

	     whotab.e (userx).process_authorization = ute.process_authorization;
	     whotab.e (userx).fg_abs, whotab.e (userx).disconnected, whotab.e (userx).suspended = ""b;
	end;

	if process_type = PT_DAEMON then		/* Daemon? */
	     whotab.n_daemons = whotab.n_daemons + 1;	/* yup, count him */
	else if process_type = PT_ABSENTEE then do;	/* for absentee process */
	     if ute.queue > 0 then do;		/* if not foreground absentee */
		whotab.abs_users = whotab.abs_users + 1;/* increment count of absentee users */
		if ute.whotabx > 0 then
		     whotab.e (userx).fg_abs = ""b;	/* and be sure foreground flag is cleared */
	     end;
	     else do;				/* but if foreground */
		whotab.fg_abs_users = whotab.fg_abs_users + 1; /* increment count of foreground abs users */
		if ute.whotabx > 0 then
		     whotab.e (userx).fg_abs = "1"b;	/* and set foreground flag for this user */
	     end;
	end;
	else
	     call ASSERT_INTERACTIVE_LOGIN ();
	return;

     end PUBLISH_LOGIN;
%page;
ASSERT_LOGGED_IN_STATE:
     procedure ();

	ute.active = NOW_LOGGED_IN;			/* indicate user is logged in */
	ute.login_time = anstbl.current_time;		/* Record time of login too */
	ute.login_result = 0;			/* Set "login succeeded" flag */
	return;

     end ASSERT_LOGGED_IN_STATE;
%page;
CHECK_CHANNEL_ACCESS_CLASS:
     procedure ();

/**** If we haven't learned an access class from config or from
      hardcore, and the user has given us a password, then we
      can make the multi-class to single-class mapping be using
      the process authorization, which is already known to be
      in the range. Since this procedure is only called in cases
      where we have a name and a password, we can establish the
      access class here. */

	if ^cdte.current_access_class_valid
	then do;					/* we are going to use USER auth as channel acc. */
	     if ^aim_check_$in_range (ute.process_authorization,
		cdte.access_class) then go to MAKE_AIM_CODE; /* we should log this, as well */
	     cdte.current_access_class (*) = ute.process_authorization;
	     cdte.current_access_class_valid = "1"b;
	end;

	else
	     if ^aim_check_$equal (cdte.current_access_class (1), ute.process_authorization)
	then
MAKE_AIM_CODE:
	     do;
	     if ute.login_flags.auth_given | process_type = PT_ABSENTEE
	     then mcode = as_error_table_$cant_give_that_authorization;
	     else mcode = as_error_table_$cant_give_dft_auth; /* Cannot login at dft authorization */
	     go to login_incorrect;
	end;
	return;

     end CHECK_CHANNEL_ACCESS_CLASS;
%page;
SET_OUTER_MODULE:
     procedure ();

	if ute.outer_module ^= " "
	then do;					/* Tried to specify DIM? */
	     if ^ute.at.vinitproc then do;		/* Yes. this may or may not be ok */
		mcode = as_error_table_$illegal_om_arg;
		go to login_incorrect;
	     end;
	end;

/**** If the user legally gave -om we have the om in the ute.  Otherwise
      the ute.outer_module is null.  Now figure out what to do for
      defaults.  First try for something useful in the pdte.  If the pdte
      just says "tty_" we calculate the default based on the line type anyway.
      Pdte (user).outer_module is pretty useless as it can't be cased for
      circumstances */

	if ute.outer_module = "" then do;		/* we need a default */
	     ute.outer_module = user.outer_module;	/* PDT value */
	     if ute.outer_module = ""
		| ute.outer_module = as_data_$tty_dim then do;
		ute.outer_module = as_data_$tty_dim;	/* default */

		if cdte.line_type = LINE_MC
		then ute.outer_module = as_data_$mrd_dim;
		else if cdte.line_type = LINE_G115
		then ute.outer_module = as_data_$g115_dim;
		else if cdte.line_type = LINE_BSC
		then ute.outer_module = "tty_";
		if cdte.line_type = LINE_HASP_OPR
		then ute.outer_module = "hasp_stream_";
	     end;					/* the calculation of om */
	end;					/* we need a default */
	return;

     end SET_OUTER_MODULE;
%page;
SETUP:
     procedure (P_process_type);

dcl  P_process_type fixed bin (17) parameter;

	if as_data_$ansp = null then
	     goto MAIN_RETURN;
	ansp = as_data_$ansp;
	if as_procid ^= anstbl.as_procid then
	     goto MAIN_RETURN;
	utep = P_utep;
	P_code = 0;
	process_type = P_process_type;
	if process_type = PT_INTERACTIVE | process_type = PT_DIAL_SLAVE then
	     cdtep = ute.channel;
	else cdtep = null ();

/**** Set the values of tty_term_type and id_code which are used in
      status and log messages */

	if process_type = PT_ABSENTEE then do;
	     tty_term_type = "Absentee";
	     id_code = "";
	end;
	else if process_type = PT_DAEMON then do;
	     tty_term_type = "Daemon";
	     id_code = ute.tty_id_code;
	end;
	else do;					/* Interactive login or dial/slave */
	     if cdte.cur_line_type >= LINE_UNKNOWN	/* check if we should mention line type name */
	     then tty_term_type = cdte.current_terminal_type; /* for pretty error message */
	     else call ioa_$rsnnl ("^a ^a", tty_term_type, (0), line_types (cdte.cur_line_type),
		     cdte.current_terminal_type);

	     call ttt_info_$encode_type (cdte.current_terminal_type, coded_type, code);
	     if code ^= 0 then
		coded_type = 0;
	     id_code = cdte.tty_id_code;
	end;

	first_pass = "1"b;				/* if this is not, we'll reset later */

/**** anstbl.session_uid_counter is a counter, incremented each time we
      attempt to identify and authenticate a user.  It is used to tie
      together various events which pertain to an authenticated "session". */

	anstbl.session_uid_counter = anstbl.session_uid_counter + 1;
	ute.session_uid = anstbl.session_uid_counter;

/**** Clear out the message buffer used to hold messages produced by
      act_ctl_ and load_ctl_. */

	as_data_$ls_message_buffer_cur_lth = 0;

	return;

     end SETUP;
%page;
CHECK_FOR_SECURITY_BREACH:
     procedure ();

/* Check for possible breach of physical security. This is when a user
   somehow gets access to a terminal whose access class is
   higher than his own authorization. (A person at level_1 should not
   normally have access to terminals used at level_2).
   This is only enabled for those communications lines whose access class
   range reflects a physical security policy.  Note that we only check
   a user's maximum authorization against the terminal's minimum
   access class.  For anonymous users, who have no PNT entry, we assume
   the access authorization of system_low */

dcl  max_auth bit (72) aligned;			/* user's maximum authorization */

	if cdte.flags.audit_access_error then do;	/* If we should check */
	     if ute.anonymous = 1 then
		max_auth = ""b;			/* system_low */
	     else max_auth = pnte.person_authorization (2); /* PNT max */

	     if ^aim_check_$greater_or_equal (max_auth, cdte.access_class (1))
	     then do;
		call SECURITY_BREACH ();
		mcode = as_error_table_$breach;
		go to login_incorrect;
	     end;
	end;
	return;

SECURITY_BREACH:
	procedure ();

/**** This procedure handles a physical security breach.  This is when
      a person has managed to gain access to a terminal of higher
      access_class than his/her maximum authorization.  E.g. someone
      with a SECRET clearance gaining access to a terminal in a TOP
      SECRET area. */

	     call sys_log_ (SL_LOG_BEEP,
		"lg_ctl_: breach of physical security by ^a.^a from ^a (^a terminal ""^a"").",
		ute.person, ute.project, ute.tty_name, tty_term_type, id_code);
	     octal_auth_string = display_access_class_ (max_auth);
	     call convert_access_class_$to_string_short (max_auth, authorization_string, code);
	     if code ^= 0
	     then if code = error_table_$smallarg
		then code = 0;
		else authorization_string = "";

	     call sys_log_ (SL_LOG, "lg_ctl_: person authorization is ^a (^a)", octal_auth_string, authorization_string);
	     octal_auth_string = display_access_class_$range (cdte.access_class);
	     call convert_access_class_$to_string_range_short (cdte.access_class, authorization_string, code);
	     if code ^= 0
	     then if code = error_table_$smallarg	/* ignore this one */
		then code = 0;
		else authorization_string = "";	/* punt */

	     call sys_log_ (SL_LOG, "lg_ctl_: terminal access class is ^a (^a)", octal_auth_string, authorization_string);
	     return;
	end SECURITY_BREACH;

     end CHECK_FOR_SECURITY_BREACH;
%page;
SETUP_INITIAL_PROCEDURE:
     procedure ();

/* User may have given initproc (-po) and/or subsystem (-ss) on login line.
   Project administrator may have specified default values for those variables in the pdt.
   In both cases, the initproc and subsystem names are packed together in a single
   char (64) variable, formerly reserved for initproc alone (because of space problems in the tables).
   Further, user must have the vinitproc attribute in order to give either argument on the login line.
   Finally, if user has given one, and the other is in the pdt, we may discover that they will not
   both fit into a 64 character string, and we have to reject the one from the login line.

   While processing the initproc string, we also replace a trailing ",direct" by a switch setting.

*/

	if ute.uflags.ss_given then			/* if user gave subsystem on login line, copy it, to avoid */
	     char64 = substr (ute.init_proc, ute.ip_len + 1, ute.ss_len); /* clobbering it while setting initproc */

/* Process initproc */

	if ute.uflags.ip_given then do;		/* if user gave initproc on login line */
	     if ^ute.at.vinitproc then do;		/* if he is not allowed to do so */
		mcode = as_error_table_$illegal_ip_arg;
		go to login_incorrect;		/* login refused */
	     end;
	end;

	else do;
	     if user.uflags.ip_given then		/* if new style pdt */
		i = user.ip_len;			/* length of initproc string is stored in it */
	     else do;				/* but of old style, we have to compute it */
		i = -1 + index (user.initial_procedure, " "); /* scan for trailing blank */
		if i = -1 then i = 64;		/* if none, it is 64 chars long */
	     end;

	     substr (ute.init_proc, 1, i) = substr (user.initial_procedure, 1, i);
	     ute.ip_len = i;
	     ute.uflags.dont_call_init_admin = user.uflags.dont_call_init_admin; /* copy the ",direct" switch */
	end;

/* If the initproc string ends in ",direct", strip off the ",direct" and turn on the switch */

	if ute.ip_len >= 8 then			/* if there is room for it */
	     if substr (ute.init_proc, ute.ip_len - 6, 7) = ",direct" then do; /* and its there */
		ute.uflags.dont_call_init_admin = "1"b;
		ute.ip_len = ute.ip_len - 7;
	     end;

	return;
     end SETUP_INITIAL_PROCEDURE;
%page;
SETUP_SUBSYSTEM:
     procedure ();

/**** Process the subsystem argument, used for prelinking */

	if ute.uflags.ss_given then do;
	     if ^ute.at.vinitproc then do;		/* if user not allowed to vary initproc OR subsystem */
		mcode = as_error_table_$illegal_ss_arg;
		go to login_incorrect;
	     end;
	     i = ute.ss_len;
	end;
	else
	     if user.uflags.ss_given then do;
	     i = user.ss_len;
	     char64 = substr (user.initial_procedure, user.ip_len + 1, user.ss_len);
	end;
	else i = -1;

	if i ^= -1 then do;				/* if there is a subsystem from anywhere */
	     if i + ute.ip_len > 64 then do;		/* if sum of lengths toolong, refuse login */
		if ute.uflags.ip_given then do;	/* initproc was from login line */
		     mcode = as_error_table_$long_ip_arg;
		     go to login_incorrect;
		end;				/* then fall back thru here, guaranteed to succeed */
		else do;				/* subsystem was from login line */
		     mcode = as_error_table_$long_ss_arg;
		     goto login_incorrect;
		end;
	     end;

	     else do;
		substr (ute.init_proc, ute.ip_len + 1, i) = substr (char64, 1, i);
		ute.ss_len = i;
		ute.uflags.ss_given = "1"b;
	     end;
	end;
	return;
     end SETUP_SUBSYSTEM;
%page;
SETUP_LOGIN_RING:
     procedure ();

/**** Set up the initial, minimum, and maximum ring information */

/* determine user initial ring */

	if user.low_ring < project.min_ring then
	     call sys_log_ (SL_LOG_SILENT, "lg_ctl_: raised initial ring for ^a.^a from ^d (in PDTE) to ^d (in SATE)",
		ute.person, ute.project, user.low_ring, project.min_ring);

	if ute.initial_ring ^= -1 then do;		/* user specified -ring */
	     i = ute.initial_ring;			/* so use that */
	end;
	else i = user.default_ring;			/* default: -1, 0 or # */

	i = max (project.min_ring,			/* SAT: -1 or # */
	     user.low_ring,				/* PDT: 0 or # */
	     i);					/* -ring or default */

	if i <= 0
	then i = as_data_$dft_user_ring;		/* apply defaults */

	if ute.initial_ring ^= -1			/* if -ring was specified */
	then if ute.initial_ring < i			/* and can't go that low */
	     then do;
		mcode = as_error_table_$ring_too_low;
		go to login_incorrect;
	     end;

	if i > as_data_$max_user_ring then i = as_data_$max_user_ring;
	ute.initial_ring = i;			/* Project may raise */

/* determine user max ring */

	if user.high_ring > project.max_ring then
	     call sys_log_ (SL_LOG_SILENT, "lg_ctl_: lowered max ring for ^a.^a from ^d (in PDTE) to ^d (in SATE)",
		ute.person, ute.project, user.high_ring, project.max_ring);

	if project.max_ring <= 0
	then userx = as_data_$dft_user_ring + 1;
	else userx = project.max_ring;

	userx = min (userx,				/* SAT: 0 or # */
	     user.high_ring,			/* PDT: # */
	     as_data_$max_user_ring);			/* # */

	if userx < ute.initial_ring			/* initial must be less than max */
	then do;
	     mcode = as_error_table_$ring_too_high;
	     go to login_incorrect;
	end;

	ute.highest_ring = userx;			/* Put into answer table. */
	ute.lowest_ring = max (project.min_ring,
	     user.low_ring);			/* Put into answer table also. */
	return;
     end SETUP_LOGIN_RING;
%page;
UPDATE_LOGGED_IN_INFO:
     procedure ();

	if ute.anonymous = 0 then do;			/* Anonymous users don't keep this info */
	     user.last_login_time = anstbl.current_time;	/* Update last login stuff. */
	     user.last_login_unit = cdte.tty_id_code;	/* .. */
	     user.last_login_type = coded_type;		/* .. */
	     user.last_login_line_type = cdte.cur_line_type;
	end;
	return;

     end UPDATE_LOGGED_IN_INFO;
%page;
ASSERT_INTERACTIVE_LOGIN:
     procedure ();

	call NOTIFY_USER_OF_LOGIN ();
	call UPDATE_LOGGED_IN_INFO ();
	return;
     end ASSERT_INTERACTIVE_LOGIN;
%page;
AUDIT_LOGIN:
     procedure (P_success_flag);

dcl  P_success_flag bit (1) aligned parameter;

	if ^P_success_flag then 
	     login_state = debg;
	call as_access_audit_$login (utep, login_state);
	return;
     end AUDIT_LOGIN;
%page;
AUDIT_LOGOUT:
     procedure (P_reason);

dcl  P_reason char (*) parameter;			/* reason for logout */

	if P_reason ^= "" then
	     logout_reason = P_reason;
	else
	     logout_reason = ute.logout_type;		/* kind of logout */
	if logout_reason < "" then
	     logout_reason = "hangup";
	else if logout_reason = "alar" then
	     logout_reason = "autologout";

	call as_access_audit_$logout (utep, logout_reason);

	return;
     end AUDIT_LOGOUT;

/* format: off */
%page; %include absentee_user_table;
%page; %include access_mode_values;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include author_dcl;
%page; %include cdt;
%page; %include dialup_values;
%page; %include hashst;
dcl  htp ptr automatic init(null);			/* hastst needs  */
%page; %include installation_parms;
%page; %include line_types;
%page; %include pdt;
%page; %include pnt_entry;
%page; %include sat;
%page; %include sc_stat_;
%page; %include sc_subsystem_info_;
%page; %include send_mail_info;
%page; %include sys_log_constants;
%page; %include ttyp;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;

/* format: on */
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   lg_ctl_: login word is "QQQQ"

   S:	as (severity1)

   T:	$init

   M:	If multics is typed, a random 4-digit login word
   is made up.

   A:	If any system programmers are to be allowed access to the system
   during this special session, inform them of the login word.  To allow
   normal use of Multics, type "word login".  In order to start the absentee
   facility, which special sessions disable, type "abs start".


   Message:
   lg_ctl_: project.n_users = N for PROJECT (login PERSON)

   S:     as (severity0)

   T:	$run

   M:	The value of project.n_users for project PROJECT went negative
   while attempting to login PERSON.  The user was permitted login but
   there may be discrepancies which may affect future operations.

   A:	$contact_sa


   Message:
   lg_ctl_$logout: called with active=N,{^}proc_create_ok for NAME.PROJ TTY ute MM||NN

   S:	as (severity0)

   T:	$run

   M:	At attempt was made to logout a process which was not logged in.
   This is most likely the cause of a login error in the answering service.

   A:     $contact_sa


   Message:
   lg_ctl_: project.n_users = N for PROJ (logout PERSON)

   S:     as (severity0)

   T:	$run

   M:	The count of the active users on a project went negative when 
   attempting to logout PERSON.  This is most likely the result of a logic 
   error in the answering service or a damaged PDT.

   A:	$contact_sa


   Message:
   lg_ctl_: tracing turned on.

   S:	as (severity1)

   T:	$run

   M:	A system administrator has enabled tracing of the module lg_ctl_.
   Debugging information will appear on the console.

   A:	$ignore


   Message:
   lg_ctl_: tracing turned off.

   S:	as (severity1)

   T:	$run

   M:	A system adminstrator has disabled tracing of the module lg_ctl_.

   A:	$ignore


   Message:
   lg_ctl_: ERROR_MESSAGE.  Error updating PNT entry of USER.

   S:	as (severity2)

   T:	$run

   M:	The system was unable to update the PNT for the user.
   Login for the user was refused.

   A:	$contact_sa


   Message:
   lg_ctl_: ERROR_MESSAGE. Unable to check access for channel CHANNEL.

   S:	as (severity 1)

   T:	$run

   M:	The channel CHANNEL has the check_acs attribute set. However,
   it was not possible to examine the Access Control Segment for the
   reason noted in ERROR_MESSAGE.  Login for the user attempting to use this
   channel was refused.

   A:     $inform_sa


   Message:
   lg_ctl_: TYPE access to channel CHANNEL by NAME.PROJ denied by ACS.

   S:	as (severity 0)

   T:	$run

   M:	The user NAME.PROJ attempted to use the TYPE command while
   dialed-up on channel CHANNEL. However, the access to the channel
   is restricted by Access Control Segment, and the user is not permitted
   to use the channel.

   A:     $ignore


   Message:
   lg_ctl_: too many bad passwords for NAME.PROJ from CHANNEL (TYPE terminal "ID").

   S:	as (severity2)

   T:	$run

   M:	The user identified by NAME on the project PROJ has either forgotten
   his password or someone else is trying to guess it.  The system has refused
   the login for an installation-specified number of times before this message
   is printed.  The maximum number of times the password can be used
   incorrectly before this message is printed is stored in the segment
   installation_parms.

   A:	$contact_sa


   Message:
   lg_ctl_: disconnected count for USER is N1 in cdte, N2 in pdte, n_processes=N3.

   S:     as (severity1)

   T:	$run

   M:	The PDT entry for the user indicates that the user has a different
   number of disconnected processes than could actually be found in the
   answer_table.  The PDT count is forced to the count of disconnected
   processes found in the answer_table. If this message occurs repeatedly
   for a given user, notify the system administrator.

   A:	$ignore


   Message:
   lg_ctl_: ERROR_MESSAGE. Checksum failure reading PNT entry of USER.

   S:	as (severity2)

   T:	$run

   M:	The PNT entry for USER is damaged.  It may have to be recreated,
   or the entire PNT may have to be retrieved in special session.  This
   can occur as a result of a damaged PNT, or due to a logic error in the
   answering service.

   A:	$contact_sa


   Message:
   lg_ctl_: ERROR_MESSAGE. Error reading PNT entry of USER.

   S:	as (severity2)

   T:	$run

   M:	This indicates that the system was unable to access the PNT.
   Login for the user was refused.

   A:	$contact_sa
   Some or all users will be unable to log in.


   Message:
   lg_ctl_: ERROR_MESSAGE. Changing Mail Table default project for USER to PROJ

   S:	as (severity2)

   T:	$run

   M:	USER.PROJ logged in with the -change_default_project control
   argument, but it was not possible to change his Mail Table entry
   for the reason noted in ERROR_MESSAGE.  USER's default project was changed,
   though, but the Mail Table and the PNT are now inconsistent.

   A:	$inform_sa


   Message:
   lg_ctl_: password used PERS.PROJ CHANNEL TERM_TYPE ID

   S:	as (severity2)

   T:	$run

   M:	The system administrator has set a password trap on
   the password for the person PERS.  This message is typed when the
   person tries to log in.  The login was attempted from a TERM_TYPE terminal
   with identification code ID, using channel CHANNEL.

   A:	Unless the system administrator has asked you to watch for
   this message, ignore it.  The system administrator can locate this
   message in the log and is presumably watching for it.


   Message:
   lg_ctl_: sat.ht has "WWWW", SAT has "xxxx" at MM|NN.

   S:	as (severity2)

   T:	$run

   M:	The SAT and its hash table are out of step or a storage system
   error has occurred. This could be the result of an incomplete reload.
   The system attempts to rehash the table and continue.

   A:	$notify_sa


   Message:
   lg_ctl_: ERROR_MESSAGE. unable to rehash sat.ht: REASON

   S:	as (severity2)

   T:	$run

   M:	An attempt to recreate the SAT hash table failed.  The user
   attempting to log in was denied login.  In all probably no users will
   be able to log in until the situation is repaired.

   A:	$contact_sa


   Message:
   lg_ctl_: project PROJ, state N, still in sat.ht

   S:	as (severity2)

   T:	$run

   M:	A user on a deleted project attempted to log in, and the supposedly
   deleted project was still in the SAT hash table. The user is refused login.
   The SAT and its hash table are out of step. The system continues operating.

   A:	$inform


   Message:
   lg_ctl_: ERROR_MESSAGE. >sc1>pdt>PROJ.pdt

   S:	as (severity2)

   T:	$run

   M:	All users on project PROJ are unable to log in because
   the project's pdt cannot be accessed for the reason ERROR_MESSAGE.

   A:	$contact_sa
   If the file was lost due to a crash, it may be possible to retrieve it.
   If the file cannot be retrieved, the person in charge of the project or
   the system administrator has to regenerate the file.


   Message:
   lg_ctl_: project PROJECT has invalid rate_structure number N. Using rate_structure 0.

   S:     as (severity2)

   T:	$run

   M:	The SAT entry for the project has an invalid rate_structure number.
   The user is allowed to log in, but is charged at the default rate (i.e.
   according to rate_structure 0)  Notify the system administrator so that
   the SAT entry may be corrected.  This message will occur for each login
   using project PROJECT.

   A:	$contact_sa


   Message:
   lg_ctl_: PDT for project PROJECTID has its damage switch set.
   Login for user PERSONID refused.

   S:     $as2

   T:	$contact

   M:	During a login attempt of user PERSONID on project PROJECTID,
   the system noticed the damage switch set on the PDT for this project.
   The login was denied.  A system administrator should determine whether
   the PDT is in fact damaged.  If not, he/she should turn off the damage
   switch for the PDT (i.e. switch_off damage >sc1>pdt>PROJECTID.pdt)  If
   the PDT appears damaged, then it should be retrieved from backup tape
   or re-installed when the system is in special session.


   Message:
   lg_ctl_: no hash table at WWWWWW of PROJ.pdt

   S:	as (severity2)

   T:	$run

   M:	A user is logging in to project PROJ. The project's pdt does not
   have a hash table, even though the pdt header says it does. The system
   attempts to log the user in anyway. Possibly the PDT has been damaged.

   A:	$inform


   Message:
   lg_ctl_: user PERSON, state N, still in hash table of PROJ.pdt

   S:	as (severity2)

   T:	$run

   M:	A deleted user attempted to log in to project PROJ, and his name was
   still in the hash table of the project's PDT. The user is refused login.
   The PDT has probably been damaged by a software malfunction.

   A:	$inform


   Message:
   lg_ctl_: hash table of PROJ.pdt has PERS, pdt has PERS2, at MM|NN

   S:	as (severity2)

   T:	$run

   M:	The PDT for PROJ is out of step with its hash table.
   The system attempts to log the user in. The PDT must be re-installed
   in order to correct the problem.

   A:	$contact_sa


   Message:
   lg_ctl_: reduced pdir quota for PERSON.PROJECT from N (in PDTE) to M (in SATE)

   S:     as (severity0)

   T:	$run

   M:	The value for process directory quota specified in the PDT entry
   for PERSON on project PROJECT was greater than the maximum allowed process
   directory quota specified in the SAT entry for PROJECT.  The SAT value
   was used for this login.  The project administrator for the project should
   set the value within the limits imposed by the system administrator.

   A:	$ignore


   Message:
   lg_ctl_: breach of physical security by NAME.PROJ from CHANNEL (TYPE terminal "ID").
   .br
   lg_ctl_: person authorization is AUTH_NUM (AUTH_STRING)
   .br
   lg_ctl_: terminal access class is AUTH_NUM (AUTH_STRING)

   S:	as (severity2)

   T:	$run

   M:	The user identified in the first message by NAME on the project
   PROJ has somehow gotten access to a terminal with an access class higher
   than his own authorization.  The next two messages give additional
   information, where AUTH_NUM is an encoding of the authorization or access
   class in numeric form and AUTH_STRING is the mnemonic form.  The login is
   refused and the terminal is hung up.

   A:	Notify the system security administrator.


   Message:
   lg_ctl_: raised initial ring for PERSON.PROJECT from N (in PDTE) to M (in SATE)

   S:	as (severity0)

   T:	$run

   M:	The value for the initial ring specified in the PDT entry for
   PERSON on project PROJECT was lower than than allowed for the project
   in the SAT.  The value in the SAT was used in logging in this user.
   The project adminstrator should change the value in the PDT to
   conform to the limits imposed by the system adminstrator.

   A:	$ignore


   Message:
   lg_ctl_:  lowered max ring for PERSON.PROJECT from N (in PDTE) to M (in SATE)

   S:	as (severity0)

   T:	$run

   M:	The value for the max ring specified in the PDT entry for PERSON
   on project PROJECT was lower than the maximum allowed ring in the SAT
   for the project.  The SAT value was used for this login.  The project
   administrator should change the PDT value to conform to the limits
   imposed by the system administrator.


   Message:
   LOGIN       PERSON.PROJECT PROC_TYPE CHANNEL (STATE)

   S:	as (severity1)

   T:	$run

   M:	The user PERSON.PROJECT was successfully identified and
   authenticated on channel CHANNEL.  The process type, PROC_TYPE,
   indicates the type of login and can be either "int", "dmn", "opr",
   or "Q N".  These correspond to "interactive", "daemon", "operator",
   or "absentee" logins.  "Q N" designates the absentee queue. STATE
   indicates the state of the login.  It can either be "create", indicating
   that a process was created for the user; "connect loop", indicating that
   the user was queried as to what he/she wanted to do with respect to
   disconnected processes; or some other value indicating what was
   done to the user's disconnected processes.


   Message:
   LOGIN DENIED PERSON.PROJECT PROC_TYPE CHANNEL (REASON)

   S:	as (severity1)

   T:	$run

   M:	An operator login was denied for PERSON.PROJECT on channel CHANNEL
   for the reason specified in REASON.  The process type is opr for
   operator login attempts.


   Message:
   LOGOUT      PERSON.PROJECT PROC_TYPE CHANNEL (REASON)

   S:	as (severity1)

   T:	$run

   M:	The user, PERSON.PROJECT, on channel CHANNEL, with process
   type PROC_TYPE either logged out, or was logged out.  The reason
   is specified in REASON.  This user/channel logout did not
   affect a process.  This can occur for slave dialed channels or
   channels dropped from message coordinator service.

   Message:
   lg_ctl_: PDT for project PROJECTID has its damage switch set.
   Login for user PERSONID refused.

   S:     as (severity2)

   T:	$contact

   M:	During a login attempt of user PERSONID on project PROJECTID,
   the system noticed the damage switch set on the PDT for this project.
   The login was denied.  A system administrator should determine whether
   the PDT is in fact damaged.  If not, he/she should turn off the damage
   switch for the PDT (i.e. switch_off damage >sc1>pdt>PROJECTID.pdt)  If
   the PDT appears damaged, then it should be retrieved from backup tape
   or re-installed when the system is in special session.


   END MESSAGE DOCUMENTATION */


     end lg_ctl_;




		    load_ctl_.pl1                   07/13/88  1114.4r w 07/13/88  0938.0      491094



/****^  ***********************************************************
        *                                                         *
        * 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: style4 */
load_ctl_: proc (P_utep, P_satep, P_pdtep, P_unused1, P_unused2, P_debug,
	P_text, P_code);

/* LOAD_CTL_ - procedure to check whether a user may log in.

   This procedure is called by lg_ctl_ in the course of every login.

   Modified 750604 by T. Casey to implement priority scheduler interface.
   Modified May 1976 by T. Casey to allow prio sked to be turned on and off by MGT installations.
   Modified 760819 by Roy Planalp to pass error msg up to lg_ctl_
   Modified October 1976 by T. Casey for version 3 MGT.
   Modified September 1977 by T. Casey to (1) call reassign_work_classes_ even when
   .		maxu auto is off, and (2) not undo an abs stop at shift change.
   Modified May 1978 by T. Casey to execute shift_config_change.ec at appropriate times,
   .		to improve strategy for promoting secondary users (the latter courtesy of James Dougal),
   .		and to log instances of grace time in PDTE exceeding the limit in the SATE.
   Modified November 1978 by T. Casey for MR7.0 absentee load control. Significant change: absentee jobs are no longer
   counted in anstbl.extra_units. They are charged to their load control groups, as primary or secondary users.
   Modified April 1979 by T. Casey for MR7.0a to fix bugs and complete implementation of secondary foreground jobs.
   Modified July 1979 by T. Casey for MR8.0 to fix a design flaw in daemon load control.
   Modified June 1981 by E. N. Kittlitz for MR9.0 to make it compile again.
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified December 1981, E. N. Kittlitz.  whotab copy of autbl control info.
   Modified April 1982, E. N. Kittlitz. New AS initialization. set_maxunits uses biggest config if no match.

*/

/****^  HISTORY COMMENTS:
  1) change(86-06-05,GJohnson), approve(86-06-05,MCR7387),
     audit(86-06-10,Martinson), install(86-07-11,MR12.0-1092):
     Correct error message documentation.
  2) change(86-08-04,Swenson), approve(87-07-13,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Use login server message buffer to return informative messages
         to MNA connections.
  3) change(87-04-27,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Upgraded for change to answer_table.incl.pl1 and
         user_table_entry.incl.pl1.
      B) Fix attempt to set parameter not supplied to
         check_for_process_creation entrypoint.
  4) change(87-07-22,GDixon), approve(87-07-22,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Add operator message document for undocumented sys_log_ calls.
      B) Use constants declared in sys_log_constants.incl.pl1 in sys_log_
         calls.
  5) change(87-10-04,Beattie), approve(87-10-26,MCR7785),
     audit(87-12-04,Parisek), install(87-12-07,MR12.2-1008):
     Accomodate changes in format of date_time strings.
                                                   END HISTORY COMMENTS */

/* Parameters */

dcl  P_code fixed bin (35) parameter;			/* status code */
dcl  P_debug char (8) aligned parameter;		/* unused */
dcl  P_pdtep ptr parameter;				/* pointer to user's PDT entry */
dcl  P_satep ptr parameter;				/* pointer to SAT entry for project */
dcl  P_text char (168) varying parameter;		/* text of error returned */
dcl  P_unused1 ptr parameter;				/* unused */
dcl  P_unused2 fixed bin parameter;			/* unused */
dcl  P_utep ptr parameter;				/* pointer to user's user table entry */

/* Automatic */

dcl (absentee, background, daemon, foreground, foreground_absentee, 
     interactive)bit (1) aligned init (""b),		/* what kind of user do we have? */
     ct1 char (16) aligned,				/* scratch date temp. */
     ec fixed bin,					/* error code */
    (i, j) fixed bin,				/* counters */
     junk char (8) aligned,
     longinfo char (100) aligned,
     maxprim fixed bin,				/* group maximum load units */
     mcode fixed bin (35),				/* remark by load_ctl_ about preemption */
     mesl fixed bin,
     msg3 char (100) aligned,				/* message buffer */
    (ncpu, nkmem, nbulk) fixed bin,			/* configuration variables */
    (pdtep, satep) ptr,				/* ptr to pdt entry and sat entry */
     check_for_process_creation_ep bit(1),		/* off if entered at main ep, */
						/* on if entered at check_for_process_creation ep */
     reject_abs bit (1) aligned init (""b),		/* turned on if abs job can never log in */
     time_now fixed bin (71),				/* current clock reading */
     unitsmax fixed bin;				/* anstbl.max_units - anstbl.extra_units */

dcl  1 wci_area like work_class_info aligned automatic;

/* Static */

dcl  ME char (32) initial ("load_ctl_") internal static options (constant);
dcl  NL char (1) int static init ("
");
dcl  tracing bit (1) aligned init ("0"b) int static;	/* Trace switch. */
dcl  prio_sked bit (1) aligned int static;		/* = true if the priority scheduler is enabled in the mgt */
dcl  first_group fixed bin int static;			/* = 1 for old mgt, 17 for new */

/* External */

dcl  as_error_table_$bumped_in_group fixed bin (35) ext;
dcl  as_error_table_$bumped_secondary fixed bin (35) ext;
dcl  as_error_table_$no_user_to_bump fixed bin (35) ext;
dcl  as_error_table_$groupmax fixed bin (35) ext;
dcl  as_error_table_$gpabsmax fixed bin (35) ext;
dcl  as_error_table_$grp_full fixed bin (35) ext;
dcl  as_error_table_$nf_nosec fixed bin (35) ext;
dcl  as_error_table_$no_group fixed bin (35) ext;
dcl  as_error_table_$not_full fixed bin (35) ext;
dcl  as_error_table_$preempt_emergency fixed bin (35) ext;
dcl  as_error_table_$preempt_emergency_prime fixed bin (35) ext;
dcl  as_error_table_$preempt_group fixed bin (35) ext;
dcl  as_error_table_$preempt_secondary fixed bin (35) ext;
dcl  as_error_table_$proj_max fixed bin (35) ext;
dcl  as_error_table_$protec_msg fixed bin (35) ext;
dcl  as_error_table_$protec_till_msg fixed bin (35) ext;
dcl  as_error_table_$saturate fixed bin (35) ext;
dcl  as_error_table_$subject fixed bin (35) ext;
dcl  as_error_table_$sys_full fixed bin (35) ext;
dcl  as_error_table_$sysgrpfl fixed bin (35) ext;
dcl  error_table_$out_of_sequence fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;

/* Builtins */

dcl  (addr, clock, divide, hbound, length, max, min, null, reverse, rtrim, string, substr, verify) builtin;

/* Entries */

dcl  absentee_user_manager_$update_whotab_abs_control entry;
dcl  absentee_utility_$au_send_wakeup entry;
dcl  admin_$abs entry options (variable);
dcl  as_meter_$read_config entry (fixed bin, fixed bin, fixed bin);
dcl  asu_$bump_code entry (ptr, fixed bin (35), char (8) aligned, fixed bin, fixed bin);
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
dcl  ec_shift_config_change_ entry (char (*), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin);
dcl  hcs_$initiate entry (char (*), char (*) aligned, char (*), fixed bin (1), fixed bin (2), ptr, fixed bin);
dcl  ioa_$rs entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  reassign_work_classes_ entry (fixed bin);
dcl  sub_err_ entry () options (variable);
dcl  sys_log_ entry options (variable);
dcl  sys_log_$error_log entry options (variable);

%page;
/* Program */
/*
   load_ctl_: proc (P_utep, P_satep, P_pdtep, P_unused1, P_unused2,
   P_debug, P_text, P_code);
*/
	utep = P_utep;
	satep = P_satep;
	pdtep = P_pdtep;
	P_debug = "";
	check_for_process_creation_ep = "0"b;
	goto COMMON;

check_for_process_creation:
     entry (P_utep, P_code);

	utep = P_utep;
	satep = ute.uprojp;
	pdtep = ute.pdtep;
	check_for_process_creation_ep = "1"b;

COMMON:
	P_code = 0;
	time_now = clock ();

/* What kind of user are we dealing with? */

	if ute.process_type = PT_DAEMON then daemon = "1"b;
	else if ute.process_type = PT_ABSENTEE then do;	/* absentee */
	     absentee = "1"b;
	     if ute.queue > 0 then			/* if queue number > 0 */
		background = "1"b;			/* it's a background job */
	     else foreground, foreground_absentee = "1"b; /* it's a foreground absentee job */
	end;
	else					/* interactive */
	     foreground, interactive = "1"b;


/* Recompute the load figures for each group */

	ansp = as_data_$ansp;
	autp = as_data_$autp;
	unitsmax = anstbl.max_units - anstbl.extra_units;
	mgt.total_units = 0;			/* will recompute this */
	do i = first_group to mgt.current_size;		/* look at all groups - skip over work classes */
	     mgtep = addr (mgt.entry (i));
	     if group.max_prim >= 0 then do;		/* recalculate maxprim */
		if group.denom = 0 then maxprim = 0;	/* Maxprim may have a fraction of maxunits */
		else maxprim = divide (group.num * unitsmax, group.denom, 17, 0);
		maxprim = maxprim + group.minu;	/* Plus some constant */
		maxprim = 10 * divide (max (maxprim, 0), 10, 17, 0);
						/* make nonnegative and multiple of 10 */
		mgt.total_units = mgt.total_units + maxprim;
		group.max_prim = maxprim;		/* also set into group table */
	     end;
	     if group.denom1 = 0 then maxprim = 0;
	     else maxprim = divide (group.num1 * unitsmax, group.denom1, 17, 0);
	     maxprim = maxprim + group.minamax;		/* Add in constant part */
	     maxprim = 10 * divide (max (maxprim, 0), 10, 17, 0);
	     group.absolute_max = maxprim;

	     group.absentee_limit = min (group.absentee_max, max (group.absentee_min,
		divide (group.absentee_pct * autbl.max_abs_users, 100, 17, 0)));

	     if group.absentee_limit = 0 then		/* if zero, check for these new parameters not being set */
		if group.absentee_min = 0 & group.absentee_pct = 0 then /* if they're unset, behave in pre-MR7.0 way */
		     group.absentee_limit = autbl.max_abs_users; /* which is to have all slots open to each group */

	end;

/* Now, assign a group to this user, checking to make sure it is valid */

	ute.group = project.group;			/* start with default group for project */

	if ute.at.igroup then			/* the pdt and sat attribute bits were anded together
						   in lg_ctl_ */
	     if permitted_proj_group (user.group) then	/* if group ok for project */
		if existing_group ((user.group)) then do; /* and it is in the mgt */
		     ute.group = user.group;
		     goto have_good_group;		/* My apologies to Dijkstra */
		end;

	if existing_group (ute.group) then		/* check existence of project's default group */
	     goto have_good_group;

	if ute.process_type = PT_ABSENTEE then		/* maybe we will have better luck with an absentee group */
	     call set_absentee_group;			/* if there is one */

	if existing_group (ute.group) then		/* if there was */
	     goto have_good_group;

/* If we fall thru, there was absolutely no load control group that we could put the guy in */

	call sys_log_ (SL_LOG_BEEP, "^a: Group ^a missing for ^a.^a", ME,
	     project.group, ute.person, ute.project);

	if absentee then reject_abs = "1"b;		/* no group is fatal */
	mcode = as_error_table_$no_group;		/* There is some difference of opinion about that ... */
	go to nolog;				/* but for now, we refuse to let him log in */

have_good_group:					/* come here from above, when group successfully assigned */

	if daemon then				/* daemons are not subject to load control */
	     goto logon1;				/* so skip over all the checking */

	if absentee then				/* if absentee job */
	     if ute.abs_run then			/* started by abs run command */
		if foreground then goto onprime;	/* skip the checking, but charge the group */
		else goto on_sec;

/* Here begins the load control decision */


	if group.max_prim < 0 then do;		/* Negative is special flag, take all the rest */
	     maxprim = unitsmax - mgt.total_units;
	     if maxprim <= 0 then
		call sys_log_ (SL_LOG_BEEP,
		"load_ctl_: maxu too small (^d), ^d units for group ^a",
		anstbl.max_units, maxprim, group.group_id);
	end;
	else maxprim = group.max_prim;

/* First check if project has maximum users or group is over absolute max.
   Somewhere, in the history of Multics, the value of project.max_users
   became obsolete.  It is set to 32767 in new_proj and is not changeable
   in edit_proj.  The print_sat command displays it as "maxprim".  This
   comment serves to document what I found when I tried to figure out
   what was hapenning in the following code.  -- Eric Swenson. */

	if project.n_users >= project.max_users then do;	/* Project is at maximum. */
	     mcode = as_error_table_$proj_max;
	     if background then goto nolog;		/* background absentee can't bump anybody */
	     if ^(ute.at.pm_ok) then go to nolog;	/* If cannot be primary, forget it. */
	     if ^(ute.at.bumping) then go to nolog;	/* If cannot bump, forget it. */
	     call findsb (2, 0, 1, -1, ec);		/* Try demoting some user on same proj */
	     call findsb (2, 1, 0, 1, ec);		/* Try bumping a secondary now. */
	     if ec > 0 then go to onprime1;		/* whee. */
	     call findsb (2, 0, 1, 2, ec);		/* Try to bump primary on project. Respect grace. */
	     if ec > 0 then go to onprime1;		/* Did we get one? */
	     go to nolog;
	end;

	if group.n_prim + group.n_sec + ute.user_weight > group.absolute_max then do;
	     mcode = as_error_table_$groupmax;
	     if background then goto nolog;
	     if ^ute.at.pm_ok then go to nolog;		/* If cannot be primary, forget it. */
	     if ^ute.at.bumping then go to nolog;	/* If cannot bump, forget it. */
	     call findsb (1, 0, 1, -1, ec);		/* First demote prime if possible. */
	     call findsb (1, 1, 0, 1, ec);		/* Demoting may have made a prime slot. */
	     if ec > 0 then go to onprime1;
	     go to fullup;
	end;

	if background then				/* if background absentee */
	     if group.n_abs >= group.absentee_limit then do; /* and group is at its background limit */
		mcode = as_error_table_$gpabsmax;
		goto nolog;
	     end;

/* Is system full? If not, check group limits here. */

	if anstbl.n_units + ute.user_weight <= anstbl.max_units then
	     if anstbl.max_users > anstbl.n_users then do;
		mcode = as_error_table_$not_full;
		if ute.at.guaranteed_login & foreground then go to onprime;
		if ute.at.pm_ok & foreground then	/* If user may be primary, check group full */
		     if group.n_prim + ute.user_weight <= maxprim then go to onprime;
		     else if ute.at.bumping then do;	/* all primary slots in use. try to demote somebody */
			call findsb (1, 0, 1, -1, ec);/* .. who is now prime but whose grace expired */
			if ec > 0 then go to onprime; /* .. and if so, give new fellow the prime */
			mcode = as_error_table_$grp_full;
		     end;

		if background then goto on_sec;	/* background absentee job is always a secondary user */
		if interactive & ute.at.sb_ok then go to on_sec; /* If cannot make interactive user prime,
						   can he be secondary? */

		if foreground_absentee & ute.uflags.foreground_secondary_ok then do; /* if fg abs job can be secondary */
		     autbl.n_sec_fg = autbl.n_sec_fg + 1; /* count secondary foreground jobs */
		     goto on_sec;
		end;

		mcode = as_error_table_$nf_nosec;	/* Sys not full, grp full, no secondary allowed */
		go to nolog;
	     end;

/* System is full, so we can only log this user in by bumping someone. */

	mcode = as_error_table_$sys_full;
	if ^(ute.at.pm_ok & foreground) then go to nolog; /* If user cannot be prime, forget it */
	if group.n_prim + ute.user_weight <= maxprim then do;
	     mcode = as_error_table_$bumped_secondary;
	     call findsb (0, 1, 0, 1, ec);		/* Must be secondary on system. Bump */
	     if ec = 0 then
		call sys_log_ (SL_LOG_SILENT,
		"^a: Too many primes. ^a.^a (^a) ^d/^d",
		ME, ute.person, ute.project, ute.group,
		anstbl.n_units, anstbl.max_units);
	     if anstbl.max_users > anstbl.n_users then go to onprime;
	     mcode = as_error_table_$saturate;		/* No APT entry available */
	     go to nolog;				/* Our fault. Sorry */
	end;

/* System full, group full. Can we bump some other user in the same group? */

	mcode = as_error_table_$sysgrpfl;

fullup:
	if background then goto nolog;		/* background user can't bump anybody */
	if ute.at.guaranteed_login then go to trybump;	/* guaranteed login will try to bump */
	if ^(ute.at.bumping) then go to nolog;		/* System is full unless someone on group can be bumped */
	if group.n_prim = 0 then go to nolog;		/* If nobody to bump, forget it */
trybump:	call findsb (1, 0, 1, 2, ec);			/* Search for prime in same group (respect grace) to bump */
	if ec = 0 then do;				/* if nobody bumped.. */
	     if ute.at.guaranteed_login then		/* Did we promise a login? */
		if anstbl.n_users < anstbl.max_users then do;
		     mcode = 0;			/* clear out error code */
		     go to onprime;
		end;
		else do;				/* yes, and no room. */
		     call findsb (0, 1, 0, 3, ec);	/* Emergency bump of secondary */
		     if ec = 0 then call findsb (0, -1, 1, 4, ec); /* Uh-oh. No secondaries. Primary? */
		     if ec = 0 then call findsb (0, -1, 0, 4, ec); /* Really in trouble. Anybody at all */
		     if ec > 0 then go to onprime;
		end;
	     mcode = as_error_table_$no_user_to_bump;
	     go to nolog;
	end;
onprime1: mcode = as_error_table_$bumped_in_group;

/* He can be logged in as a primary user */

onprime:	ute.standby_line = 0;			/* Note primary */
	group.n_prim = group.n_prim + ute.user_weight;
	call check_max_grace;			/* set grace time to min of PDTE and SATE values */
	ute.cant_bump_until = time_now + ute.bump_grace;
	if ute.at.brief | absentee then go to logon1;	/* Skip message if brief or absentee */
	call Write_User_Message (mcode, "");
	ct1 = "";
	mcode = as_error_table_$protec_msg;
	if ^ute.at.nobump then
	     if ute.bump_grace < 86400000000 then do;	/* Fix message to say how long he's safe. */
		ct1 = date_time_$format ("time", ute.cant_bump_until, "", "");
		mcode = as_error_table_$protec_till_msg;
	     end;
	call convert_status_code_ (mcode, junk, longinfo);
	if longinfo ^= "" then do;
	     call ioa_$rsnnl (rtrim (longinfo), msg3, mesl, ct1);
	     call Write_User_Message (0, (msg3));
	end;
	go to logon1;

/* He can be logged in as a secondary user */

on_sec:	ute.standby_line = 1;			/* Note secondary */
	group.n_sec = group.n_sec + ute.user_weight;
	ute.cant_bump_until = time_now;		/* true but uninteresting */
	call check_max_grace;			/* set grace time to min of PDTE and SATE values */
	if ute.at.brief | absentee then go to logon1;	/* skip message if brief mode or absentee */
	mcode = as_error_table_$subject;
	call Write_User_Message (mcode, "");
logon1:

/* Now, assign a work class based on the load control group */

	if background then do;			/* if background absentee */
	     autbl.n_background_abs = autbl.n_background_abs + 1; /* /* count total background jobs */
	     autbl.abs_units = autbl.abs_units + ute.user_weight; /* count total background units */
	     group.n_abs = group.n_abs + 1;		/* and count background users per group, before changing group */
	     if ^group.absentee.allowed then		/* if absentees not allowed in his group */
		call set_absentee_group;		/* try to find another group for him */
	     else ute.abs_group = group.group_id;	/* but if we can't, he stays in this group */
	end;

/* See if priority scheduler is supposed to be on or off */

	if ^prio_sked then do;			/* if prio sked was off, see if MGT installation turned it on */
	     if mgt.version_indicator = "VERSION" then	/* if good MGT */
		if mgt.prio_sked_on_tape then		/* and prio sked is on system tape */
		     if mgt.prio_sked_enabled then	/* and MGT says to use it */
			prio_sked = "1"b;		/* do so */
	end;
	else					/* it was on - see if it still is */
	     if ^mgt.prio_sked_enabled then		/* if MGT says to turn it off */
	     prio_sked = ""b;			/* do so */

	if prio_sked then do;			/* if running with priority scheduler enabled */
	     if background then			/* if background absentee */
		ute.work_class = group.abs_wc (anstbl.shift);
	     else ute.work_class = group.int_wc (anstbl.shift);
	end;
	else ute.work_class = 1;			/* it is definitely necessary that this be 1, and not zero or
						   garbage, when running with the priority scheduler disabled */


/* Update various counters of users and units */

	anstbl.n_users = anstbl.n_users + 1;
	anstbl.n_units = anstbl.n_units + ute.user_weight;
	if daemon then				/* if daemon process */
	     anstbl.extra_units = anstbl.extra_units + ute.user_weight; /* incrememnt extra units */
	project.n_users = project.n_users + 1;

	if autbl.abs_maxu_auto then			/* if operator has not set abs maxu manually, then */
	     if installation_parms.max_abs (anstbl.shift) ^= -1 then /* unless dynamic abs maxu is disabled */
		call set_abs_maxu;			/* go set it as function of interactive load */

	return;

/* Insert code for edit-only here if desired */

nolog:	if ^check_for_process_creation_ep then do;
	     call convert_status_code_ (mcode, (""), longinfo);
	     if longinfo ^= ""
		then P_text = substr (longinfo, 1, length (longinfo) + 1 - verify (reverse (longinfo), " ")) || NL;
	     else P_text = NL;
	end;
	P_code = mcode;
	ute.failure_reason = 3;			/* 3 means load_ctl_ said no */
	if reject_abs then				/* if absentee job with serious problem */
	     ute.login_result = 1;			/* don't let it keep trying to log in */
	else ute.login_result = 2;			/* 2 means allow another attempt */
	return;
%page;
/* ************************************************************************* */

/* ADDITIONAL ENTRY POINTS, IN ALPHABETIC ORDER  */

init: entry ();

/**** Entry called during AS initialization to initialize load control */

	if ^sc_stat_$Multics_typed | sc_stat_$Go_typed then
	     call sub_err_ (error_table_$out_of_sequence, "load_ctl_$init",
		ACTION_CANT_RESTART);
	wcip = addr (wci_area);
	string (work_class_info.switches) = ""b;	/* only need to clear the switches,
						   since they control what other variables are looked at */

	ansp = as_data_$ansp;
	autp = as_data_$autp;
	anstbl.extra_units = 0;			/* Clear control variables. */
	call hcs_$initiate (anstbl.sysdir, "mgt", "", 0, 1, mgtp, ec);
	if mgtp = null then
	     call sub_err_ (ec, "load_ctl_$init", ACTION_CANT_RESTART,
		null (), (0), "mgt");

/* The following code decides whether or not to run with the priority scheduler enabled */

	prio_sked = "0"b;				/* static switch - start with it off */
	first_group = 1;				/* static index - start by assuming old format mgt */

	if mgt.version_indicator = "VERSION " then do;	/* new format mgt (version 1 had no version stored in it) */
	     first_group = 17;			/* the first 16 are work classes */

	     if mgt.version = 2 then goto V2_MGT;	/* accept old MGTs for a while */
	     if mgt.version = MGT_version_3 then do;	/* if this is the version that we know about */
V2_MGT:
		mgt.prio_sked_on_tape = "1"b;		/* also tell them if it is there */
		if mgt.prio_sked_enabled then		/* see if administrator turned us off */
		     prio_sked = "1"b;		/* if he didn't, then we run with the priority scheduler */
	     end;					/* end version is ok do group */
	     else do;				/* possible incompatibility, or garbaged mgt */
		call sys_log_ (SL_LOG_BEEP,
		     "^a: Unknown mgt version number: ^d",
		     ME, mgt.version);
		call sub_err_ (error_table_$unimplemented_version,
		     ME, ACTION_CANT_RESTART);
	     end;

	end;					/* end mgt version >= 2 do group */

	maxprim = 0;				/* Check for error in tables. */
	do i = first_group to mgt.current_size;		/* .. and reset the table. */
	     mgtep = addr (mgt.entry (i));
	     if group.max_prim < 0 then
		if maxprim = 0 then maxprim = i;
		else
		     call sys_log_ (SL_LOG_BEEP,
		     "^a: more than one group has -1 max: ^a",
		     ME, group.group_id);
	     group.n_prim, group.n_sec, group.n_eo, group.n_abs = 0; /* Clear group counters. */

	end;


/* after act_ctl_$init has been called, and the shift is defined,
   as_init_ will call reassign_work_classes_, to set up the initial set of
   work classes.  (work class definitions are a function of shift, and the
   shift is not defined at this point in initialization.) */

	return;
%page;
lctraceoff: entry;

	tracing = "0"b;
	return;


lctraceon: entry;

	tracing = "1"b;
	return;
%page;
load_level: entry (resp, idle_pct);

dcl  resp fixed bin,				/* current response estimate */
     idle_pct float bin;				/* percentage idle */

	if as_data_$ansp = null then return;
	ansp = as_data_$ansp;
	autp = as_data_$autp;
	if anstbl.auto_maxu ^= 2 then return;
	if resp < anstbl.response_low then do;
	     anstbl.max_units = max (1.1e0 * anstbl.n_units, anstbl.n_units * (1e0 / (1e0 - idle_pct)));
	end;
	else if resp > anstbl.response_high then do;
	     anstbl.max_units = 0.9e0 * anstbl.n_units;
	end;
	else do;
	     anstbl.max_units = anstbl.n_units;
	end;
	whotab.mxunits = anstbl.max_units;

	return;

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

/* These two entry points have in common that they both read the config deck
   and search the config array for a matching configuration and shift.
   Then they set various shift-and-configuration-dependent parameters.
   The first only sets absentee parameters, and is called whenever the operator
   types "abs KEYWORD auto" where KEYWORD can be one of several.
   The second sets all parameters, including absentee, and starts the absentee
   facility if appropriate. It is called at startup time, and shift change,
   and whenever the operator types "maxu auto".
*/

set_abs_parms: entry;

dcl  abs_only bit (1) aligned;

	abs_only = "1"b;
	goto maxu_common;

set_maxunits: entry (oshf);

dcl  oshf fixed bin;				/* previous shift, if it just changed; else current shift */

	abs_only = ""b;
maxu_common:

	if as_data_$ansp = null then return;		/* if not initialized */
	ansp = as_data_$ansp;
	autp = as_data_$autp;
	if ^abs_only then do;
	     call reassign_work_classes_ (ec);
	     if ec ^= 0 then
		call sys_log_$error_log (SL_LOG_BEEP, ec, "load_ctl_",
		"During work class redefinition.");
	end;

	call as_meter_$read_config (ncpu, nkmem, nbulk);	/* Get current configuration. */

	if ^abs_only then
	     call ec_shift_config_change_ (anstbl.sysdir, oshf, anstbl.shift, anstbl.auto_maxu, ncpu, nkmem, nbulk);

	do i = 1 to installation_parms.ncon;		/* look up current configuration in config deck */
	     if ncpu <= installation_parms.cona (i).cpu then
		if nkmem <= installation_parms.cona (i).kmem then
		     if nbulk <= installation_parms.cona (i).kbulk then
			if anstbl.shift <= installation_parms.cona (i).shift then go to cfnd;
	end;
	i = installation_parms.ncon;			/* last one is used */
	call sys_log_ (SL_LOG_BEEP,
	     "^a: configuration not in tables. ^d cpu, ^d mem, ^d bulk, shift ^d
	using configuaration ^d cpu, ^d mem, ^d bulk, shift ^d",
	     ME, ncpu, nkmem, nbulk, anstbl.shift,
	     installation_parms.cona (i).cpu, installation_parms.cona (i).kmem,
	     installation_parms.cona (i).kbulk, installation_parms.cona (i).shift);

cfnd:
	if anstbl.auto_maxu ^= 0 then do;
	     anstbl.response_low = installation_parms.cona (i).response_low;
	     anstbl.response_high = installation_parms.cona (i).response_high;
	     if anstbl.auto_maxu = 1 then anstbl.max_units = installation_parms.cona (i).maxu_base;
	     whotab.mxunits = anstbl.max_units;
	end;

	if (^autbl.abs_up & ^autbl.abs_stopped) then	/* if abs not up and not stopped by operator, start it */
	     call admin_$abs ("start", "startup");

	if autbl.abs_up then do;			/* if absentee up, set parms not overridden by operator */

	     if autbl.abs_maxu_auto then do;
		if installation_parms.max_abs (anstbl.shift) = -1 then /* if dynamic abs maxu disabled */
		     whotab.max_abs_users, autbl.max_abs_users = installation_parms.cona (i).maxa; /* use per-shift constant */
		else call set_abs_maxu;		/* else go set abs maxu as function of interactive load */
	     end;

	     if autbl.abs_maxq_auto then
		autbl.last_queue_searched = installation_parms.cona (i).maxq;

	     if autbl.abs_qres_auto then
		do j = 1 to 4;
		autbl.qres (j) = min (installation_parms.max_qres (anstbl.shift, j),
		     max (installation_parms.min_qres (anstbl.shift, j),
		     divide (installation_parms.pct_qres (anstbl.shift, j) * autbl.max_abs_users, 100, 9, 0)));
	     end;

	     if autbl.abs_cpu_limit_auto then
		do j = 1 to 4;
		autbl.cpu_limit (j) = installation_parms.abs_cpu_max_limit (anstbl.shift, j);
	     end;

	     call absentee_user_manager_$update_whotab_abs_control; /* update public copy */
	     call absentee_utility_$au_send_wakeup;	/* parms changed, so tell abs to look for newly-eligible job */
	end;
	return;
%page;
unload: entry (P_utep, P_unused2);

          ansp = as_data_$ansp;
	autp = as_data_$autp;
	utep = P_utep;				/* copy arg */
	if ute.queue < 0 then do;			/* if daemon */
	     anstbl.extra_units = anstbl.extra_units - ute.user_weight; /* decrement extra units */
	     goto off1;
	end;
	do i = 1 to mgt.current_size;
	     mgtep = addr (mgt.entry (i));
	     if ute.queue > 0 then do;		/* if background absentee */
		if ute.abs_group = group.group_id then goto gf1;
	     end;
	     else if group.group_id = ute.group then go to gf1;
	end;
	call sys_log_ (SL_LOG_BEEP, "^a: group ^a missing at logout", ME,
	     ute.group);
	go to off1;
gf1:	if ute.standby_line = 0 then do;
	     group.n_prim = group.n_prim - ute.user_weight;
	     if group.n_sec > 0 then			/* If anybody needs promoting, then */
		if group.max_prim < 0 | group.max_prim >= group.n_prim then do;
		     time_now = clock ();		/* ... promote a secondary */
		     call findsb (1, 1, 0, 0, ec);	/* ... if any qualify */
		end;
	end;
	else do;
	     group.n_sec = group.n_sec - ute.user_weight;
	     if ute.foreground_secondary_ok then	/* if foreground secondary job */
		autbl.n_sec_fg = autbl.n_sec_fg - 1;	/* decremnt counter of that kind of job */
	end;
	if ute.queue > 0 then do;			/* if background absentee */
	     group.n_abs = group.n_abs - 1;		/* decrement counter */
	     autbl.abs_units = autbl.abs_units - ute.user_weight;
	     autbl.n_background_abs = autbl.n_background_abs - 1;
	end;

/* promote edit-only users here */

off1:	anstbl.n_users = anstbl.n_users - 1;
	anstbl.n_units = anstbl.n_units - ute.user_weight;
	satep = ute.uprojp;
	project.n_users = project.n_users - 1;

	if autbl.abs_maxu_auto then			/* if operator has not set abs maxu manually, then */
	     if installation_parms.max_abs (anstbl.shift) ^= -1 then /* unless dynamic abs maxu is disabled */
		call set_abs_maxu;			/* go set it as function of interactive load */

	return;


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


/* INTERNAL PROCEDURES, IN ALPHABETIC ORDER  */


check_max_grace: proc;

	if foreground_absentee & ute.standby_line = 0 then/* a primary foreground job has a cpu time limit */
	     ute.bump_grace = 525600;			/* but it is "protected from preemption" in real time terms */
	else do;
	     ute.bump_grace = user.bump_grace;		/* give grace time specified in PDTE */
	     if ute.bump_grace > project.grace_max then do; /* unless it exceeds the limit in the SATE */
		call sys_log_ (SL_LOG_SILENT,
		     "^a: reduced grace for ^a.^a from ^d (in PDTE) to ^d (in SATE)",
		     ME, ute.person, ute.project, ute.bump_grace, project.grace_max);
		ute.bump_grace = project.grace_max;
	     end;
	     ute.bump_grace = ute.bump_grace * 60000000;	/* convert it to microseconds */
	end;

	return;

     end check_max_grace;


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


existing_group: proc (a_group) returns (bit (1) aligned);

dcl  a_group char (8);
dcl  i fixed bin;

	do i = first_group to mgt.current_size;
	     mgtep = addr (mgt.entry (i));
	     if group.group_id = a_group then
		return ("1"b);			/* leaving mgtep set to it */
	end;

	call sys_log_ (SL_LOG_BEEP,
	     "^a: group ^a not found in mgt for ^a.^a",
	     ME, a_group, ute.person, ute.project);
	return ("0"b);

     end existing_group;


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


/* FINDSB - internal procedure to scan answer table.

   Can bump a user, promote a user, or demote a user.

   returns number of load units bumped (or promoted) in last arg

*/

findsb: proc (grpmatch, pmsc, respect_grace, action, n_preempted);

dcl  grpmatch fixed bin,				/* 1 = groups must match, 2 = projects, 0 = dnc */
     pmsc fixed bin,				/* 1 = secondary, 0 = prime, -1 = dnc */
     respect_grace fixed bin,				/* 1 = yes, 0 = no */
     action fixed bin,				/* >0 = bump, 0 = promote, -1 = demote */
     n_preempted fixed bin;

dcl  oldest_atep ptr,
     oldest_time fixed bin (71),
     i fixed bin,
     xgp ptr,
     bumpx fixed bin (35),
     why char (8) aligned,
     p ptr;

	n_preempted = 0;				/* initialize preemption counter */
bump_loop: if n_preempted >= ute.user_weight then return;
	oldest_time = time_now;			/* put highest-possible value in "oldest-time" */
	oldest_atep = null;				/* initialize pointer */

/* Got to search abs_user_tab for secondary foreground jobs, too */

	do i = 1 to anstbl.current_size;
	     p = addr (anstbl.entry (i));		/* get pointer to answer table entry */
	     call see_if_oldest;
	end;
	if autbl.n_sec_fg > 0 then			/* if secondary foreground absentees are logged in */
	     do i = 1 to autbl.current_size;
	     p = addr (autbl.entry (i));
	     if p -> ute.foreground_secondary_ok then
		call see_if_oldest;
	end;

	if oldest_atep = null then return;

	xgp = mgtep;				/* Special case if group already known. */
	if ute.group = oldest_atep -> ute.group then go to gf2;
	do i = 1 to mgt.current_size;			/* Not same group. must locate group of other guy */
	     xgp = addr (mgt.entry (i));
	     if xgp -> group.group_id = oldest_atep -> ute.group then go to gf2;
	end;
	call sys_log_ (SL_LOG_BEEP, "^a: group ^a missing at preempt", ME,
	     oldest_atep -> ute.group);
	return;

/* Found oldest guy. Do we promote or bump? */

gf2:	if action = 0 then do;			/* Promote the fellow to primary */
	     if tracing then
		call sys_log_ (SL_LOG_SILENT, "^a: promote ^a.^a.^a ^d",
		     ME, oldest_atep -> ute.person,
		     oldest_atep -> ute.project, xgp -> group.group_id,
		     xgp -> group.n_prim);
	     oldest_atep -> ute.standby_line = 0;
	     xgp -> group.n_prim = xgp -> group.n_prim + oldest_atep -> ute.user_weight;
	     xgp -> group.n_sec = xgp -> group.n_sec - oldest_atep -> ute.user_weight;
	     oldest_atep -> ute.cant_bump_until = oldest_atep -> ute.bump_grace /* give only enough grace time so */
		+ oldest_atep -> ute.login_time;	/* it expires when it would have if he had logged in as primary */
	     i = oldest_atep -> ute.whotabx;		/* Fix whotab too */
	     if i ^= 0 then do;			/* .. if he is a listed user */
		whotab.e (i).stby = 0;		/* Mark now primary */
		whotab.e (i).cant_bump_until = oldest_atep -> ute.cant_bump_until;
	     end;
	end;
	else if action = -1 then do;			/* Demote the user to secondary */
	     if ^oldest_atep -> ute.at.sb_ok then do;	/* .. oops, can't demote this guy */
		bumpx = as_error_table_$preempt_group;
		go to xbmp;
	     end;
maksb:	     oldest_atep -> ute.standby_line = 1;
	     if tracing then
		call sys_log_ (SL_LOG_SILENT, "^a: demote ^a.^a.^a ^d", ME,
		     oldest_atep -> ute.person,
		     oldest_atep -> ute.project, xgp -> group.group_id,
		     xgp -> group.n_prim);
	     xgp -> group.n_prim = xgp -> group.n_prim - oldest_atep -> ute.user_weight;
	     xgp -> group.n_sec = xgp -> group.n_sec + oldest_atep -> ute.user_weight;
	     i = oldest_atep -> ute.whotabx;
	     if i ^= 0 then whotab.e (i).stby = 1;
	end;
	else do;					/* Bump the user */
	     if action = 1 then bumpx = as_error_table_$preempt_secondary;
	     else if action = 2 then bumpx = as_error_table_$preempt_group;
	     else if action = 3 then bumpx = as_error_table_$preempt_emergency;
	     else bumpx = as_error_table_$preempt_emergency_prime;
xbmp:	     oldest_atep -> ute.preempted = 1;		/* indicate that user has been preempted */
	     call asu_$bump_code (oldest_atep, bumpx, why, j, installation_parms.warning_time);
	     call sys_log_ (SL_LOG, "^a: bumping ^a.^a for ^a.^a: ^a", ME,
		oldest_atep -> ute.person, oldest_atep -> ute.project,
		ute.person, ute.project, why);
	     if oldest_atep -> ute.standby_line = 0 then go to maksb;
	end;

	n_preempted = n_preempted + oldest_atep -> ute.user_weight;
	go to bump_loop;				/* Keep trying */


see_if_oldest: proc;

	     if p -> ute.active >= NOW_LOGGED_IN then	/* if this is a logged-in user */
		if p -> ute.preempted = 0 then do;	/* .. and hasn't been previously bumped, THEN */
		     if grpmatch = 1 then		/* if want groups to match, check */
			if ute.group ^= p -> ute.group then go to nope;
		     if grpmatch = 2 then		/* If projects must match, check. */
			if ute.project ^= p -> ute.project then go to nope;
		     if pmsc ^= -1 then		/* if care about prime/secondary */
			if pmsc ^= p -> ute.standby_line then go to nope;
		     if action = 0 then		/* Promoting? See if promotable. */
			if ^(p -> ute.at.pm_ok) then go to nope;
			else ;
		     else if p -> ute.at.nobump then go to nope;
		     if respect_grace = 1 then	/* does grace matter? */
			if (p -> ute.cant_bump_until) > time_now then go to nope;
		     if p -> ute.login_time < oldest_time then do; /* is this the oldest user? */
			if action = 0 then		/* if we are promoting, see if user has already been logged in
						   for a time >= his grace time */
			     if p -> ute.login_time + p -> ute.bump_grace <= time_now
			     then goto nope;	/* and if so, don't promote him */
			oldest_time = p -> ute.login_time;
			oldest_atep = p;
		     end;
		end;

nope:	     return;

	end see_if_oldest;

     end findsb;


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


permitted_proj_group: proc (a_group) returns (bit (1) aligned);

dcl  (a_group, t_group) char (8) aligned;
dcl  i fixed bin;

/* see if this group is legal for this project */
	do i = 0 to 2;
	     if i = 0 then t_group = project.group;
	     else t_group = project.groups (i);
	     if t_group = "*" then goto ok_for_pj;
	     if t_group = a_group then goto ok_for_pj;
	end;

	call sys_log_ (SL_LOG_BEEP,
	     "^a: group ^a not authorized for project ^a", ME,
	     a_group, ute.project);
	return ("0"b);

ok_for_pj:
	return ("1"b);

     end permitted_proj_group;


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


set_abs_maxu: proc;					/* set abs maxu from moving average of idle units */

dcl  current_idle_units fixed bin;			/* units not in use by interactives or daemons */
dcl  n_idle_units fixed bin;				/* number of samples in average */
dcl  sum_of_idle_units fixed bin;			/* for taking the average */
dcl  time_in_seconds fixed bin;			/* for keeping track of how old the samples are */
dcl  i fixed bin;					/* for do loops */

/* STATIC VARIABLES USED FOR KEEPING MOVING AVERAGE */

dcl  average_idle_units fixed bin int static;
dcl  first_idle_unit fixed bin int static init (1);	/* first valid sample in array */
dcl  last_idle_unit fixed bin int static init (0);	/* last valid sample in array */
dcl  prev_idle_units (25) fixed bin int static init ((25) 0); /* samples of idle units over specified time period */
dcl  sample_times (0:25) fixed bin (35) int static init ((26) 0); /* times the samples were taken */
						/* sample_times (0) is needed to get it started */

/* Compute current idle units. */

	current_idle_units = anstbl.max_units		/* start with total units available on the system */
	     - anstbl.n_units			/* deduct units currently in use */
	     + autbl.abs_units;			/* add back units used by absentees */

/* See if it is time to sample idle units again and recompute the average. */

	time_in_seconds = divide (anstbl.current_time, 1000000, 35, 0);

	if time_in_seconds - sample_times (last_idle_unit) >
						/* if time since we last sampled idle units is greater than */
	     divide (installation_parms.idle_time_constant_seconds, hbound (prev_idle_units, 1), 17, 0)
						/* desired sample interval */
	then do;					/* then take another sample and recompute the average */

/* Store the current sample */

	     last_idle_unit = last_idle_unit + 1;	/* use next array entry */
	     if last_idle_unit > hbound (prev_idle_units, 1) then /* wrap around if necessary */
		last_idle_unit = 1;
	     prev_idle_units (last_idle_unit) = current_idle_units; /* save the sample */
	     sample_times (last_idle_unit) = time_in_seconds; /* and the time it was taken */

/* Eliminate samples that are older than we want to include in the average. */

	     do while (sample_times (first_idle_unit) <
		time_in_seconds - installation_parms.idle_time_constant_seconds);
		prev_idle_units (first_idle_unit) = 0;	/* zero old sample */
		first_idle_unit = first_idle_unit + 1;	/* go to next sample */
		if first_idle_unit > hbound (prev_idle_units, 1) then /* wrap around if necessary */
		     first_idle_unit = 1;
	     end;

/* Add up the samples */

	     sum_of_idle_units = 0;
	     if last_idle_unit >= first_idle_unit then
		n_idle_units = last_idle_unit - first_idle_unit + 1;
	     else n_idle_units = hbound (prev_idle_units, 1) - (first_idle_unit - last_idle_unit - 1);

	     do i = 1 to hbound (prev_idle_units, 1);	/* old ones have been zeroed */
		sum_of_idle_units = sum_of_idle_units + prev_idle_units (i);
	     end;

/* Get the average */

	     average_idle_units = divide (sum_of_idle_units, n_idle_units, 17, 0);

	end;					/* end take sample and recompute average */

/* Use the smaller of the average and current value, for absentee load control */

	autbl.idle_units = min (current_idle_units, average_idle_units);

	autbl.max_abs_users = min (installation_parms.max_abs (anstbl.shift),
	     max (installation_parms.min_abs (anstbl.shift),
	     divide (installation_parms.pct_abs (anstbl.shift) * autbl.idle_units, 1000, 17, 0)));

	whotab.max_abs_users = autbl.max_abs_users;

	return;

     end set_abs_maxu;


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


set_absentee_group: proc;

dcl  i fixed bin;
dcl  save_mgtep ptr;

	save_mgtep = mgtep;				/* in case we can't find another group for him */
	ute.abs_group = group.group_id;		/* in either case, remember the original group */

	do i = first_group to mgt.current_size;
	     mgtep = addr (mgt.entry (i));

	     if group.absentee.default_group then
		if group.absentee.default_queue (ute.queue) then do;
		     ute.group = group.group_id;
		     return;			/* leaving mgtep pointing at the new group */
		end;

	end;					/* if we fall thru */
						/* we could not find another group to put him in */
	mgtep = save_mgtep;				/* so leave him in the one he's in now */

	return;

     end set_absentee_group;
%page;
Write_User_Message:
     procedure (P_code, P_message);

dcl  P_code fixed bin (35) parameter;
dcl  P_message char (*) parameter;

dcl  message char (512) automatic;
dcl  message_lth fixed bin automatic;
dcl  message_buffer_cur_lth fixed bin automatic;
dcl  message_buffer_max_lth fixed bin automatic;
dcl  message_buffer_ptr ptr automatic;
dcl  new_message_buffer_max_lth fixed bin automatic;
dcl  new_message_buffer_ptr ptr automatic;
dcl  system_area_ptr ptr automatic;

dcl  status_code_string char (100) aligned automatic;

dcl  message_buffer char (message_buffer_max_lth)
	based (message_buffer_ptr);
dcl  new_message_buffer char (new_message_buffer_max_lth)
	based (new_message_buffer_ptr);
dcl  system_area area based (system_area_ptr);

dcl  astty_$tty_force entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  get_system_free_area_ entry () returns (ptr);

	if P_code ^= 0 then
	     call convert_status_code_ (P_code, (""), status_code_string);
	else status_code_string = "";

/**** Handle the case were the as_error_table_ entry specifies a null message.
      Only skip the message if both the code string and message string are
      null. */

	if (status_code_string = "") & (P_message = "") then
	     return;

	call ioa_$rs ("^[^a ^;^s^]^a", message, message_lth,
	     (status_code_string ^= ""), status_code_string,
	     rtrim (P_message));

	if ute.channel ^= null () then		/* user has a MCS channel */
	     call astty_$tty_force ((ute.channel), addr (message),
		message_lth, (0));
	else do;
	     message_buffer_ptr = as_data_$ls_message_buffer_ptr;
	     message_buffer_max_lth = as_data_$ls_message_buffer_max_lth;
	     message_buffer_cur_lth = as_data_$ls_message_buffer_cur_lth;

	     if message_buffer_cur_lth + message_lth > message_buffer_max_lth then do;
		new_message_buffer_max_lth = message_buffer_max_lth +
		     min (512, message_buffer_cur_lth + message_lth);
		system_area_ptr = get_system_free_area_ ();
		allocate new_message_buffer in (system_area)
		     set (new_message_buffer_ptr);
		substr (new_message_buffer, 1, message_buffer_cur_lth) =
		     substr (message_buffer, 1, message_buffer_cur_lth);
		free message_buffer;
		as_data_$ls_message_buffer_ptr,
		     message_buffer_ptr = new_message_buffer_ptr;
		as_data_$ls_message_buffer_max_lth,
		     message_buffer_max_lth = new_message_buffer_max_lth;
	     end;

	     substr (message_buffer, message_buffer_cur_lth + 1,
		message_lth) = message;
	     as_data_$ls_message_buffer_cur_lth = message_buffer_cur_lth +
		message_lth;
	end;
	return;
     end Write_User_Message;
%page;

/* format: off */
%page; %include absentee_user_table;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include dialup_values;
%page; %include installation_parms;
%page; %include mgt;
%page; %include pdt;

dcl  pdtp ptr automatic init (null);			/* pdt needs it  */
%page; %include sat;
%page; %include sc_stat_;
%page; %include sub_err_flags;
%page; %include sys_log_constants;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include whotab;
%page; %include work_class_info;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   load_ctl_: reduced grace for PERSON.PROJECT from MINUTES1 (in PDTE) to MINUTES2 (in SATE)

   S:	$as0

   T:	$run

   M:	The Project Definition Table (PDT) entry for PERSON.PROJECT specifies
   a larger grace time (time during which a process is protected from
   preemption) than does the System Administrator's Table (SAT) entry for the
   project.  The time given in the SAT entry is used.

   A:	$ignore


   Message:
   load_ctl_: bumping NAME1.PROJ for NAME2.PROJ: REASON

   S:	as (severity1)

   T:	$run

   M:	This message is typed out when a user is bumped.  A
   user may be bumped by another member of his load control
   group, in which case REASON is pr_grp, which
   means group preemption. If a secondary user is bumped
   by a primary user, either from the same group or from
   another group, REASON is pr_sec, meaning secondary
   user preemption. If REASON is pr_emrg, meaning
   emergency preemption, a system programmer was logging
   in and had to bump some user.  A user is usually given
   three minutes after this message to clean up
   and log out before being automatically logged out.

   A:	$ignore


   Message:
   load_ctl_: configuration not in tables.  X cpu, Y mem, W bulk, shift Z
	using configuartion XX cpu, YY mem, WW bulk, shift ZZ

   S:	as (severity2)

   T:	May occur at any time.

   M:	The automatic setting of maxunits by the load control
   facility was attempted, but the configuration tables did not have
   a configuration defined that matched the current configuration.  No
   change was made to the system parameters.  The system continues
   operation, selecting the last entry in the config tables (which should
   correspond to the largest system described by the system administrator.)
   The values assumed by automatic load control are given in the second line
   of the message.

   A:	Set maxunits and the absentee max manually.  Inform
   the system administrator so that he can update the load control
   tables.


   Message:
   load_ctl_: demote NAME.PROJ GROUP NNN

   S:	as (severity1)

   T:	$run

   M:	This is trace output.  This user has been demoted to
   secondary status.

   A:	$ignore
   To turn off this
   output, type load_ctl_$lctraceoff from admin mode.


   Message:
   load_ctl_: Entry not found. master_group_table

   S:	as (severity2)

   T:	$init

   M:	load_ctl_ cannot find the master_group_table.  The
   system will probably not be able to perform the bootload operation.

   A:	$inform


   Message:
   load_ctl_: group GRPID missing at preempt

   S:	as (severity2)

   T:	$run

   M:	The master_group_table entry for GRPID has vanished.
   The system is attempting to preempt a user from that group but
   cannot find the table entry for the group.  The system will attempt to
   continue.

   A:	$inform_sa


   Message:
   load_ctl_: group GRPID missing at logout

   S:	as (severity2)

   T:	$run

   M:	The master_group_table entry for GRPID has vanished.
   The system is attempting to logout a user from that group but
   cannot find the table entry for the group.  The system will attempt to
   continue.

   A:	$inform_sa


   Message:
   load_ctl_: Group GRPID missing for NAME.PROJ

   S:	as (severity2)

   T:	$run

   M:	The system administrator has designated that the project PROJ
   should be in the load control group GRPID but the entry in the
   master_group_table for that load control group is missing.  The
   user cannot log in.  This may be an indication that the segment
   master_group_table has been damaged.

   A:	$inform_sa


   Message:
   load_ctl_: group GRPID not found in mgt for NAME.PROJ

   S:	as (severity2)

   T:	$run

   M:	A system or project administrator has designated that the user
   NAME.PROJ should be in the load control group GRPID, but the master_group_table
   (mgt) has no entry for that group.  An attempt will be made to log the user in,
   using the default group for his project.  Subsequent messages will indicate
   the success or failure of this attempt.

   A:	$inform_sa


   Message:
   load_ctl_: group GRPID not authorized for project PROJ

   S:	as (severity2)

   T:	$run

   M:	A project administrator has designated that one of the users
   in project PROJ should be in the load control group GRPID, but the system
   administrator has not authorized that project to be in that group.  An attempt
   will be made to log the user in, using the default group for his project.
   Subsequent messages will indicate the success or failure of this attempt.

   A:	$inform_sa


   Message:
   load_ctl_: ERROR_MESSAGE  During work class redefinition

   S:	as (severity2)

   T:	While the system is running or during system startup.

   M:	Either some system table has been damaged or a system administrator
   was changing work class definitions at the time of a shift change, or when
   a "maxu auto" command was issued.  Error messages immediately preceding this one
   contain more information about the exact nature of the problem.

   A:	$contact_sa
   He may want you to type the
   "maxu auto" command to retry the operation that failed.  If that command
   produces no error messages, the problem has been eliminated.


   Message:
   load_ctl_: Unknown mgt version number:  NUMBER

   S:	as (severity2)

   T:	$init

   M:	Either the master_group_table (mgt) has been damaged,
   or its format is incompatible with the current Answering Service.
   The system cannot be brought up until a correct mgt is provided.

   A:	$contact_sa


   Message:
   load_ctl_: maxu too small (XX), YY units for group GRPID

   S:	as (severity2)

   T:	$run

   M:	The system administrator has specified that the load control
   group GRPID is to have "all the rest" of the primary load units
   after all other groups have taken their allocations from maxunits.
   However, maxunits is less than the sum of the primary allocations,
   giving the group GRPID the negative allocation of YY units.  The
   system proceeds, attempting to log the user in anyway.  Of course,
   the user is allowed secondary status only if he is allowed to log
   in at all.  This is often the result of the operator typing maxu 30
   instead of maxu 300, or some similar error.

   A:	Check the value of maxunits and, if a mistake was made,
   correct it.  If the maxunits value is correct, note this situation for
   the system administrator.


   Message:
   load_ctl_: more than one group has -1 max: GRPID

   S:	as (severity2)

   T:	$init

   M:	The system administrator has accidentally given more
   than one group a "take all the rest" maximum primary unit
   allocation.  The user control package cannot handle this situation.
   The second group with a -1 maxprim is listed.  The system completes
   startup and users can log in but maxunits may not be obeyed.

   A:	$contact_sa


   Message:
   load_ctl_: promote NAME.PROJ GROUP NNN

   S:	as (severity1)

   T:	$run

   M:	This is trace output.  This user has been promoted to
   primary status.

   A:	$ignore
   To turn off this
   output, type load_ctl_$lctraceoff from admin mode.


   Message:
   load_ctl_: Too many primes. NAME.PROJ (GROUP) MM/NN

   S:	as (severity0)

   T:	$run

   M:	This is trace output.  The system has been committed
   to allow a certain number of users from group GROUP
   to be logged in at one time.  In order to log this
   user in, some other user must be bumped, but all users
   have primary status and cannot be bumped.  This situation
   may be a consequence of system programmers with the
   overloading privilege logging in when the system is
   full.  The user is allowed to log in anyway.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end load_ctl_;




		    login_parse_.pl1                10/27/83  1613.0rew 10/27/83  1441.4       54378



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


/* format: style4 */
login_parse_: proc (a_lp, a_ll, a_arg, a_lng, a_used, a_code);

/* LOGIN_PARSE_ - this parsing routine is used by parse_login_line_ and
   several other Answering Service programs.  It returns the first argument
   from the line, and tells how many characters were used up.
   Repeated calls should trim off a_used characters from the front of the line. */

/* rewritten 12/28/81 E. N. Kittlitz. added support for quoted arguments, $password entry. */

dcl  a_lp ptr;					/* ptr to input line */
dcl  a_ll fixed bin;				/* length of input line */
dcl  a_arg char (*);				/* output argument */
dcl  a_lng fixed bin;				/* length of output argument */
dcl  a_used fixed bin;				/* number of characters eaten */
dcl  a_code fixed bin (35);				/* error code */


dcl  argp fixed bin;				/* position in output argument */
dcl  arg_rm fixed bin;				/* amount of space left in a_arg */
dcl  cursor fixed bin;				/* logical start of line */
dcl  had_quote bit (1) aligned;			/* ever see a quotation mark? */
dcl  have_quote bit (1) aligned;			/* looking at a quoted string, even as we speak */
dcl  ll fixed bin;					/* line length */
dcl  lp ptr;					/* pointer to input line */
dcl  scan_inc fixed bin;				/* used to delete illegal characters */
dcl  scan_ln fixed bin;				/* used to delete illegal characters */

dcl  line char (ll) based (lp);

dcl  LEGAL char (93) int static options (constant) init	/* Printables except blank, PAD, quote, semicolon, but with BS */
	("!#$%&'()*+,-./0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");
dcl  PW_LEGAL char (94) int static options (constant) init	/* Printables except blank, PAD, semicolon, but with BS */
	("!#$%&'()*+,-./0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~""");
dcl  PW_LEGAL_TRAIL char (3) int static options (constant) init  /* space, NL, CR */
	(" 
");
dcl  NL char (1) int static options (constant) init ("
");

dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$unbalanced_quotes fixed bin (35) ext static;
%page;
	a_lng = 0;				/* initialize length */
	a_arg = "";				/* initialize output argument */
	a_used = 0;				/* initialize characters used count */
	a_code = 0;				/* no errors */

	lp = a_lp;				/* local copy of parameter */
	ll = a_ll;				/* local copy of parameter */
	arg_rm = length (a_arg);			/* number of output characters allowed */

	had_quote, have_quote = ""b;			/* never had a quotation mark */
	argp = 1;
	cursor = 1;				/* position in line */

	if ll <= 0 then do;
	     a_code = error_table_$noarg;
	     return;
	end;

	cursor = verify (line, "	 ");		/* space and TAB */
	if cursor = 0 then do;
	     a_used = ll;
	     a_code = error_table_$noarg;
	     return;
	end;

	if substr (line, cursor, 1) = ";" |		/* first thing we get is the end */
	     substr (line, cursor, 1) = NL then do;
	     a_used = cursor;
	     a_code = error_table_$noarg;
	end;

loop:	if have_quote then do;
	     scan_ln = search (substr (line, cursor, ll - cursor + 1), """") - 1;
	     if scan_ln < 0 then do;			/* unbalanced quotation marks */
unbalanced_quotes:	a_code = error_table_$unbalanced_quotes;
		a_arg = "";
		a_used = ll;
		return;
	     end;
	end;
	else do;
	     scan_ln = verify (substr (line, cursor, ll - cursor + 1), LEGAL) - 1;
	     if scan_ln < 0 then scan_ln = ll - cursor + 1;
	end;
	substr (a_arg, argp, min (arg_rm, scan_ln)) = substr (line, cursor, scan_ln); /* copy to output argument */
	argp = argp + scan_ln;			/* bump output index */
	arg_rm = max (0, arg_rm - scan_ln);		/* decrement output space left */
	cursor = cursor + scan_ln;			/* skip over those characters */
	if cursor > ll then go to done;
	if substr (line, cursor, 1) = """" then do;
	     cursor = cursor + 1;
	     if ^have_quote then had_quote, have_quote = "1"b;
	     else if cursor > ll then have_quote = ""b;	/* end of string */
	     else if substr (line, cursor, 1) = """" then do;
		cursor = cursor + 1;
		substr (a_arg, argp, min (arg_rm, 1)) = """"; /* put a quote into the output */
		argp = argp + 1;
	     end;
	     else have_quote = ""b;			/* end of quoted string */
	end;
	if cursor <= ll then
	     if have_quote then go to loop;
	     else if index (LEGAL, substr (line, cursor, 1)) > 0 |
		     substr (line, cursor, 1) = """" then go to loop;

done:
	if have_quote then go to unbalanced_quotes;

	if argp = 1 then
	     if had_quote then a_lng = 0;
	     else
		a_code = error_table_$noarg;
	else a_lng = argp - 1;
	a_used = min (cursor, ll);

	return;


password: entry (a_lp, a_ll, a_arg, a_lng, a_used, a_code);

	a_lng = 0;				/* setup output args */
	a_arg = "";
	a_used = 0;
	a_code = 0;

	lp = a_lp;				/* initialize */
	ll = a_ll;

	if ll <= 0 then do;
	     a_code = error_table_$noarg;
	     return;
	end;

	cursor = verify (line, " 	");		/* space and TAB */
	if cursor = 0 then do;
	     a_used = ll;
	     a_code = error_table_$noarg;
	     return;
	end;

	scan_ln = verify (substr (line, cursor, ll - cursor + 1), PW_LEGAL) - 1;
	if scan_ln < 0 then scan_ln = ll - cursor + 1;
	else if scan_ln = 0 then do;
	     a_code = error_table_$noarg;
	     a_used = cursor;
	     return;
	end;
	substr (a_arg, 1, min (length (a_arg), scan_ln)) = substr (line, cursor, scan_ln);
	a_used = cursor + scan_ln;
	a_lng = scan_ln;
	cursor = cursor + scan_ln;
	if verify (substr (line, cursor, ll - cursor + 1), PW_LEGAL_TRAIL) > 0 then
	     a_code = error_table_$bad_arg;


     end login_parse_;




		    parse_answerback_.pl1           10/27/83  1613.0rew 10/27/83  1441.4       40887



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


/* PARSE_ANSWERBACK_ - Program to determine Multics terminal type
   from baud rate and answerback code.

   Written 750211 by PG
   Modified 750228 by PG to fix bug missing 1050 and 2741 answerbacks.
   Modified 750307 by PG to look for 110 baud input in lower case.
   Modified 750922 by PG to handle Correspondence 2741s.
   Modified 760601 by PG to redefine NL to mean "default" instead of "ASCII".
*/

parse_answerback_:
     procedure (bv_input, bv_baud_rate, bv_terminal_type, bv_terminal_id);

/* parameters */

dcl (bv_input char (*),				/* (Input) String to be parsed */
     bv_baud_rate fixed bin,				/* (Input) Baud rate of terminal */
     bv_terminal_type fixed bin,			/* (Input/Output) Computed terminal type */
     bv_terminal_id char (*)) parameter;		/* (Output) ID from answerback */

/* automatic */

dcl  temp char (4),
    (idx, jumpx, terminal_type) fixed bin,
     answerback char (32);

/* internal static initial */

dcl  baud_array (11) fixed bin internal static options (constant) initial (
     110, 133, 150, 300, 600, 1200, 1800, 2400, 4800, 7200, 9600);

/* builtins */

dcl (hbound, index, lbound, length, substr) builtin;

/* include files */

%include tty_types;

/* program */

	answerback = bv_input;			/* copy input, padding to char (32) if necessary */
	terminal_type = bv_terminal_type;

	do jumpx = lbound (baud_array, 1) to hbound (baud_array, 1)
		while (bv_baud_rate ^= baud_array (jumpx));
	end;

	if jumpx > hbound (baud_array, 1)		/* Strange... */
	then go to none;

	go to baud (jumpx);				/* Dispatch on baud rate */

baud (1):						/* 110 BAUD */
	terminal_type = TYPE_TTY38;
	idx = index (answerback, " j") + 2;		/* (ttydim translates all input to lower case at 110) */
	if idx ^= 2 then go to found;

	terminal_type = TYPE_TN300;
	idx = index (answerback, " e") + 2;
	if idx ^= 2 then go to found;

	terminal_type = TYPE_ASCII;
	idx = index (answerback, " t") + 2;
	if idx ^= 2 then go to found;

	terminal_type = TYPE_TTY33;
	go to none;				/* default is TTY33 */

baud (2):						/* 133 BAUD */
	if (terminal_type = TYPE_2741) | (terminal_type = TYPE_CORR) then do;
	     idx = index (answerback, "0") + 1;
	     if idx ^= 1 then go to found;

	     go to none;
	end;

	idx = 1;					/* use whatever we got */
	substr (answerback, 2, 2) = "  ";		/* but clear out junk */
	go to found;				/* a 1050 */

baud (3):						/* 150 BAUD */
	terminal_type = TYPE_ASCII;
	idx = index (answerback, " T") + 2;
	if idx ^= 2 then go to found;

	terminal_type = TYPE_TN300;
	idx = index (answerback, " E") + 2;
	if idx ^= 2 then go to found;

	terminal_type = TYPE_TTY37;
	idx = index (answerback, " B") + 2;
	if idx ^= 2 then go to found;

	go to none;				/* default is TTY37 */

baud (4):						/* 300 BAUD */
	terminal_type = TYPE_TN300;
	idx = index (answerback, " E") + 2;
	if idx ^= 2 then go to found;

	terminal_type = TYPE_ASCII;
	idx = index (answerback, " T") + 2;
	if idx ^= 2 then go to found;

	go to none;				/* default is ASCII */

baud (6):						/* 1200 BAUD */
	if terminal_type = TYPE_ARDS
	then go to none;				/* 202C6 protocol has no answerbacks */

	terminal_type = TYPE_TN300;			/* if we get here it must be Vadic protocol */
	idx = index (answerback, " E") + 2;
	if idx ^= 2 then go to found;

	terminal_type = TYPE_ASCII;
	idx = index (answerback, " T") + 2;
	if idx ^= 2 then go to found;

	go to none;				/* default is ASCII */

found:						/* come here if find an answerback string */
	if idx + 2 <= length (answerback)		/* if we can get 3 chars from string */
	then temp = substr (answerback, idx, 3);
	else temp = "none";				/* false alarm */

	bv_terminal_id = temp;			/* Convert to char (4) */
	bv_terminal_type = terminal_type;
	return;

baud (5):						/* 600 BAUD */
baud (7):						/* 1800 BAUD */
baud (8):						/* 2400 BAUD */
baud (9):						/* 4800 BAUD */
baud (10):					/* 7200 BAUD */
baud (11):					/* 9600 BAUD */
none:						/* come here if don't find answerback string */
	bv_terminal_id = "none";
	bv_terminal_type = terminal_type;
	return;

     end;




		    parse_login_line_.pl1           07/20/88  1307.0r w 07/19/88  1536.7      211554



/****^  ***********************************************************
        *                                                         *
        * 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: style4 */
parse_login_line_: proc (lp, ll, a_utep, modestring, errarg, code);

/* PARSE_LOGIN_LINE_ - handle optional arguments on login command line.

   Modified 740807 by PG for -authorization and -change_default_authorization
   Modified 740913 by PG for -generate_password
   Modified 750429 by PG for new dial facility
   Modified 750714 by THVV for -modes and -terminal_type
   Modified 751024 by T. Casey for -subsystem.
   Modified 760601 by PG to handle pw masks properly.
   Modified 770613 by RSC for variable terminal types
   Modified July 1979 by T. Casey for MR8.0 to add new login args for process preservation.
   Modified December 1980 by E. N. Kittlitz for Person.Project.
   Modified April 1981 by E. N. Kittlitz to zero code at check_for_ctl_arg
   Modified July 1981 by E. N. Kittlitz
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified January 1982, E. N. Kittlitz.  login arguments, as_data_ conversion.
   Modified July 1982, E. N. Kittlitz. Detect -po being too long for ute field.
   Modified December 1983, C. Marker.  Added -terminal_id (-tid).
   Modified 84-04-03 BIM for -auth on dial or slave.
   Modified 85-01-11 by E. Swenson for new A.S. logging
*/


/****^  HISTORY COMMENTS:
  1) change(87-04-14,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-21,Brunelle), install(87-08-04,MR12.1-1055):
     Correct coding standard violations.  Remove reference
     answer_table.incl.pl1 and user_table_entry.incl.pl1
                                                   END HISTORY COMMENTS */


/* Parameters */

dcl  lp ptr,					/* Pointer to input line buffer. */
     ll fixed bin,					/* Length of line. */
     a_utep ptr,					/* Pointer to user table entry. */
     modestring char (*),				/* New mode string */
     errarg char (*) aligned,				/* If an error occurs aligned, what went wrong. */
     code fixed bin (35);				/* Error code. */

/* Automatic */

dcl  arg char (32);					/* Single argument to login. */
dcl  argstringx fixed bin;				/* temporary for -arguments */
dcl  authorization bit (72) aligned;			/* binary authorization */
dcl  authorization_string char (150);			/* character representation of auth. */
dcl  char64 char (64);				/* temporary */
dcl  device char (32);				/* for -ttp */
dcl  entry_sw fixed bin;
dcl  i fixed bin;					/* temporary */
dcl  j fixed bin;					/* Return from login_parse_: relative cursor */
dcl  jj fixed bin;					/* Absolute cursor */
dcl  k fixed bin;					/* Length of argument. */
dcl  prev_arg char (32);
dcl  save_jj fixed bin;				/* temp copy of j */
dcl  specified_type char (32);
dcl  terminal_id char (4);				/* for -terminal_id */

/* Based */

dcl  argstring char (ute.ln_args) based (ute.args_ptr);
dcl  ch (ll) char (1) unal based (lp);			/* Image of buffer */
dcl  lengths (ute.arg_count) based (ute.arg_lengths_ptr) fixed bin;
dcl  system_area area based (system_area_ptr);

/* Internal Static */

dcl  system_area_ptr ptr int static init(null);

/* Constants */

dcl  NORMAL fixed bin init (1) static options (constant);
dcl  DIAL fixed bin init (2) static options (constant);
dcl  SLAVE fixed bin init (3) static options (constant);
dcl  ds_valid_option bit (57) static options (constant)
     init ("110000111100000000000000001100000000000000000000000001101"b);
						/* -bf, -npf, -pf, -lg, -auth, -authorization, -user */
dcl  (false bit (1) aligned init ("0"b),
     lower_case char (26) init ("abcdefghijklmnopqrstuvwxyz"),
     true bit (1) aligned init ("1"b),
     upper_case char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     ) internal static options (constant);

/* Entries */

dcl  convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  get_system_free_area_ entry() returns(ptr);
dcl  login_parse_ entry (ptr, fixed bin, char (*), fixed bin, fixed bin, fixed bin (35));
dcl  ttt_info_$terminal_data entry (char (*), fixed bin, fixed bin, ptr, fixed bin (35));

/* External Static */

dcl  as_error_table_$bad_login_arg_msg fixed bin (35) ext static;
dcl  as_error_table_$bad_terminal_id fixed bin (35) ext static;
dcl  as_error_table_$dial_request_error fixed bin (35) ext static;
dcl  as_error_table_$need_project_for_cdp fixed bin (35) ext static;
dcl  as_error_table_$long_ip_ss_args fixed bin (35) ext static;
dcl  as_error_table_$only_one_save_nosave fixed bin (35) ext static;
dcl  as_error_table_$only_one_connect_etc fixed bin (35) ext static;
dcl  as_error_table_$only_one_hold_no_hold fixed bin (35) ext static;
dcl  as_error_table_$no_login_arg_msg fixed bin (35) ext static;
dcl  as_error_table_$bad_login_arguments_string fixed bin (35) ext static;
dcl  as_error_table_$need_authorization_for_cda fixed bin (35) external;
dcl  error_table_$noarg fixed bin (35) ext static;

dcl  1 as_data_$login_args ext aligned,
       2 n_login_args fixed bin (35),
       2 pad fixed bin (35),
       2 login_args (56) char (24);			/* 56 control arguments at last count */

dcl  as_data_$max_user_ring fixed bin (35) ext;

/* Builtins */

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

%page;
/* ================================================== */

	entry_sw = NORMAL;
	code = 0;					/* Assume no error will happen. */
	jj = 1;					/* starting cursor */
	modestring = "";
	utep = a_utep;				/* Copy argument */
	ute.mask_ctl = DERIVE_MASK;			/* Default is to let TTYDIM tell us whether to mask */
	ute.login_flags.auth_given = "0"b;		/* whether -auth was specified */
	ute.at.bumping = "1"b;			/* Default is bumping ON, unless -np */
	cdtep = ute.channel;
	if cdtep ^= null then do;
	     cdte.disconnected_proc_command, cdte.disconnected_proc_number = 0;
	     cdte.save_arg, cdte.nosave_arg, cdte.hold_arg,
		cdte.no_hold_arg, cdte.immediate_arg = ""b;
	end;

	call login_parse_ (lp, ll, arg, k, j, code);	/* Get person ID */
	if code ^= 0 then				/* Personid must be given */
	     return;
	if index (arg, ".") ^= 0 then do;		/* Person.Project */
	     ute.person = before (arg, ".");		/* just the person id */
	     ute.project = after (arg, ".");
	     if ute.project = "" then go to badarg;	/* Person. */
	end;
	else ute.person = substr(arg,1,length(ute.person));
						/* just specified Person */

	jj = jj + j;				/* Advance cursor. */
	call login_parse_ (addr (ch (jj)), ll - jj + 1, arg, k, j, code); /* Get 2nd argument */
	if code = error_table_$noarg then do;
	     code = 0;
	     go to exit;
	end;
	else if code ^= 0 then do;
	     errarg = arg;				/* probably all blanks */
	     return;
	end;
	if substr (arg, 1, 1) = "-"
	then go to arglp;				/* is control arg...go process it */
	else if ute.project ^= "" then go to badarg;	/* already have a project */

	ute.project = substr(arg,1,length(ute.project));	/* is project */

nxarg:	jj = jj + j;				/* Advance cursor. */
	call login_parse_ (addr (ch (jj)), ll - jj + 1, arg, k, j, code); /* Pick off next argument. */
	if code = error_table_$noarg then do;
	     code = 0;
	     go to exit;
	end;
	else if code ^= 0 then return;
check_for_ctl_arg:
	if substr (arg, 1, 1) ^= "-" then go to badarg;	/* Not a control arg */
arglp:	prev_arg = arg;				/* save arg for possible later printing in error message */
	do k = 1 to as_data_$login_args.n_login_args while
	     (arg ^= as_data_$login_args.login_args (k)); end; /* Look up argument in table. */
	if k > as_data_$login_args.n_login_args then do;	/* Fuss if unknown argument. */
badarg:	     errarg = arg;				/* Tell user what we barf on */
badarg2:	     code = as_error_table_$bad_login_arg_msg;	/* Return error to dialup_ */
	     return;
	end;
	code = 0;					/* might be residue from goto check_for_ctl_arg */

	if k > hbound (arg_handler, 1) then go to badarg; /* as_data_ is newer than we are! */
	if entry_sw ^= NORMAL then
	     if k > length (ds_valid_option) then go to badarg; /* no good for dial/slave */
	     else if ^substr (ds_valid_option, k, 1) then go to badarg; /* no good for dial/slave */
	go to arg_handler (k);			/* Dispatch on argument. */

arg_handler (1):					/* -bf */
arg_handler (2):					/* -brief */
	ute.at.brief = true;			/* Set appropriate attribute flag. */
	ute.ur_at.brief = true;
	go to nxarg;

arg_handler (3):					/* -hd */
arg_handler (4):					/* -home_dir */
	jj = jj + j;				/* Advance parse pointer. */
	call login_parse_ (addr (ch (jj)), ll - jj + 1, ute.home_dir, k, j, code);
lp_error: if code = error_table_$noarg then do;
noarg:	     code = as_error_table_$no_login_arg_msg;
	     errarg = prev_arg;			/* arg that it was supposed to be after */
	     return;
	end;
	else if code ^= 0 then return;
	if substr (ute.home_dir, 1, 1) ^= ">" then do;
	     errarg = ute.home_dir;
	     go to badarg2;				/* Must be absolute path. */
	end;
	go to nxarg;

arg_handler (5):					/* -po */
arg_handler (6):					/* -process_overseer */
	jj = jj + j;
	call login_parse_ (addr (ch (jj)), ll - jj + 1, char64, i, j, code);
	if code ^= 0 then go to lp_error;
	if substr (char64, 1, 1) = "-" then go to noarg;	/* missing operand */
	if i + ute.ss_len > 64 then do;		/* if sum of both strings too long */
	     code = as_error_table_$long_ip_ss_args;
	     errarg = char64;
	     return;				/* let user try again */
	end;
	if ute.uflags.ss_given then do;		/* if -subsystem given already, save it */
	     authorization_string = substr (ute.init_proc, ute.ip_len + 1, ute.ss_len); /* borrow a vacant string */

	end;

	substr (ute.init_proc, 1, i) = substr (char64, 1, i);
	ute.ip_len = i;
	ute.uflags.ip_given = "1"b;
	if ute.uflags.ss_given then			/* if -ss was already given, put it back at end of string */
	     substr (ute.init_proc, i + 1, ute.ss_len) = substr (authorization_string, 1, ute.ss_len);
	go to nxarg;

arg_handler (7):					/* -npf */
arg_handler (8):					/* -no_print_off */
	ute.mask_ctl = DO_MASK;			/* User wants a pw mask */
	go to nxarg;

arg_handler (9):					/* -pf */
arg_handler (10):					/* -print_off */
	ute.mask_ctl = DONT_MASK;			/* User does not want a pw mask */
	go to nxarg;

arg_handler (11):					/* -nw */
arg_handler (12):					/* -no_warning */
	ute.at.no_warning = true;
	ute.ur_at.no_warning = true;
	go to nxarg;

arg_handler (13):					/* -np */
arg_handler (14):					/* -no_preempt */
	ute.at.bumping = false;
	ute.ur_at.bumping = true;
	go to nxarg;

arg_handler (15):					/* -force */
	ute.at.guaranteed_login = true;
	ute.ur_at.guaranteed_login = true;
	go to nxarg;

arg_handler (16):					/* -md */
arg_handler (17):					/* -mode */
arg_handler (18):					/* -modes */
	jj = jj + j;
	call login_parse_ (addr (ch (jj)), ll - jj + 1, modestring, k, j, code);
	if code ^= 0 then go to lp_error;
	if substr (modestring, 1, 1) = "-" then go to noarg; /* missing operand */
	go to nxarg;

arg_handler (19):					/* -ns */
arg_handler (20):					/* -no_start_up */
	ute.at.nostartup = true;
	ute.ur_at.nostartup = true;
	go to nxarg;

arg_handler (21):					/* -cpw */
arg_handler (22):					/* -change_password */
	ute.login_flags.cpw = true;
	go to nxarg;

arg_handler (23):					/* -cdp */
arg_handler (24):					/* -change_default_project */
	ute.login_flags.cdp = true;
	go to nxarg;

arg_handler (25):					/* -om */
arg_handler (26):					/* -outer_module */
	jj = jj + j;
	call login_parse_ (addr (ch (jj)), ll - jj + 1, char64, k, j, code);
	if code ^= 0 then go to lp_error;
	if substr (char64, 1, 1) = "-" then go to noarg;
	ute.outer_module = substr(char64,1,length(ute.outer_module));
	go to nxarg;

arg_handler (27):					/* -auth */
arg_handler (28):					/* -authorization */
	jj = jj + j;
	call login_parse_ (addr (ch (jj)), ll - jj + 1, authorization_string, k, j, code);
	if code ^= 0 then go to lp_error;
	if substr (authorization_string, 1, 1) = "-" then go to noarg; /* missing operand */
	call convert_authorization_$from_string (authorization, (authorization_string), code);
	if code ^= 0
	then do;
	     errarg = "";
	     return;
	end;

	ute.login_flags.auth_given = true;
	ute.process_authorization = authorization;
	go to nxarg;

arg_handler (29):					/* -cda */
arg_handler (30):					/* -change_default_auth */
	ute.login_flags.cda = true;
	go to nxarg;

arg_handler (31):					/* -gpw */
arg_handler (32):					/* -generate_password */
	ute.login_flags.generate_pw = true;
	go to arg_handler (22);			/* -gpw implies -cpw */

arg_handler (33):					/* -ttp */
arg_handler (34):					/* -terminal_type */
	if cdtep = null then goto badarg;		/* this arg only legal for interactive logins */
	jj = jj + j;
	call login_parse_ (addr (ch (jj)), ll - jj + 1, device, k, j, code);
	if code ^= 0 then go to lp_error;
	specified_type = translate (device, upper_case, lower_case); /* get terminal type in all caps */
	call ttt_info_$terminal_data (specified_type, (cdte.cur_line_type), (cdte.baud_rate), null, code);

	if code = 0				/* type is valid */
	then do;
	     cdte.current_terminal_type = specified_type; /* so dialup_ will know */
	     ute.uflags.send_initial_string = "1"b;	/* even if type didn't change */
	     go to nxarg;
	end;

	errarg = device;
	return;

arg_handler (58):					/* -tid */
arg_handler (59):					/* -terminal_id */
	if cdtep = null then goto badarg;
	if cdte.flags.ck_answerback then do;		/* Can't set terminal_id in */
	     code = as_error_table_$bad_terminal_id;	/* check_answerback mode */
	     errarg = arg;
	     return;
	end;
	jj = jj + j;
	call login_parse_ (addr (ch (jj)), ll - jj + 1, terminal_id, k, j, code);
	if code ^= 0 then go to lp_error;
	if substr (terminal_id, 1, 1) = "-" then go to noarg; /* missing operand */
	cdte.tty_id_code, ute.tty_id_code = terminal_id;
	go to nxarg;

arg_handler (37):					/* -rg */
arg_handler (38):					/* -ring */
	jj = jj + j;
	call login_parse_ (addr (ch (jj)), ll - jj + 1, arg, k, j, code);
	if code ^= 0 then go to lp_error;
	ute.initial_ring = cv_dec_check_ (arg, code);	/* Convert ring to integer. */
	if code ^= 0 then go to badarg;		/* Check value. */
	if ute.initial_ring <= 0 then go to badarg;	/* Aw, c'mon. */
	if ute.initial_ring > as_data_$max_user_ring then go to badarg;
	go to nxarg;

arg_handler (35):					/* -ss */
arg_handler (36):					/* -subsystem */
	jj = jj + j;
	call login_parse_ (addr (ch (jj)), ll - jj + 1, char64, i, j, code);
	if code ^= 0 then go to lp_error;
	if substr (char64, 1, 1) = "-" then go to noarg;	/* missing operand */
	if i + ute.ip_len > 64 then do;		/* -ss arg and -po arg add up to > 64 chars */
	     code = as_error_table_$long_ip_ss_args;
	     errarg = char64;
	     return;				/* let user try again */
	end;
	substr (ute.init_proc, ute.ip_len + 1, i) = substr (char64, 1, i); /* copy subsystem in after initproc */
	ute.ss_len = i;				/* remember its length */
	ute.uflags.ss_given = "1"b;			/* and remember that it was given */
	goto nxarg;

arg_handler (39):					/* -save_on_disconnect */
arg_handler (40):					/* -save */
	if cdtep = null then goto badarg;		/* this arg only legal for interactive logins */
	if cdte.nosave_arg then do;
only_one_save_nosave:				/* complain that both -save and -nosave args were given */
	     code = as_error_table_$only_one_save_nosave;
	     errarg = arg;				/* return the offending argument */
	     return;
	end;
	cdte.save_arg = "1"b;
	goto nxarg;

arg_handler (41):					/* -no_save_on_disconnect */
arg_handler (42):					/* -nosave */
	if cdtep = null then goto badarg;		/* this arg only legal for interactive logins */
	if cdte.save_arg then goto only_one_save_nosave;
	cdte.nosave_arg = "1"b;
	goto nxarg;

arg_handler (43):					/* -list */
arg_handler (44):					/* -create */
arg_handler (45):					/* -connect */
arg_handler (46):					/* -new_proc */
arg_handler (47):					/* -destroy */
	if cdtep = null then goto badarg;		/* this arg only legal for interactive logins */
	if cdte.disconnected_proc_command > 0 then do;	/* if one of these args already given, complain */
	     code = as_error_table_$only_one_connect_etc;
	     errarg = arg;
	     return;
	end;
	cdte.disconnected_proc_command = k - 42;	/* 43 thru 47 -> 1 thru 5 */
	if k > 44 then do;				/* if -connect, -new_proc, or -destroy, check for {N} */
	     jj = jj + j;				/* advance cursor */
	     call login_parse_ (addr (ch (jj)), ll - jj + 1, arg, k, j, code); /* pick off next arg */
	     if code = error_table_$noarg then do;
		code = 0;
		goto exit;			/* if no arg there, we're all done */
	     end;
	     else if code ^= 0 then go to lp_error;
	     cdte.disconnected_proc_number = cv_dec_check_ (arg, code);
	     if code ^= 0 then goto check_for_ctl_arg;	/* if not a number, go see if it's a ctl arg */
	end;
	goto nxarg;

arg_handler (48):					/* -hold */
arg_handler (49):					/* -no_hold */
	if cdtep = null then goto badarg;		/* only legal for interactive logins */
	if (cdte.hold_arg & k = 49) | (cdte.no_hold_arg & k = 48) then do;
	     code = as_error_table_$only_one_hold_no_hold;
	     errarg = arg;
	     return;
	end;
	if k = 48 then cdte.hold_arg = "1"b;
	else cdte.no_hold_arg = "1"b;
	go to nxarg;

arg_handler (50):					/* -im */
arg_handler (51):					/* -immediate */
	if cdtep = null then goto badarg;		/* only valid for interactive logins */
	cdte.immediate_arg = "1"b;
	go to nxarg;

arg_handler (52):					/* -ag */
arg_handler (53):					/* -arguments */

	save_jj, jj = jj + j;			/* Advance cursor. */
	ute.arg_count = 0;				/* set up to count remaining args */
	ute.ln_args = 0;				/* total lengths of arguments */
	do while ("1"b);				/* first pass - how many are there? */
	     call login_parse_ (addr (ch (jj)), ll - jj + 1, arg, k, j, code);
	     if code = error_table_$noarg then go to got_all_args;
	     else if code ^= 0 then go to lp_error;
	     ute.ln_args = ute.ln_args + k;
	     ute.arg_count = ute.arg_count + 1;
	     jj = jj + j;
	end;

got_all_args:
          if system_area_ptr = null then
	   system_area_ptr = get_system_free_area_ ();
	allocate lengths in (system_area);		/* array of lengths */
	allocate argstring in (system_area);		/* string of all arguments */
	if ute.ln_args <= 0 then do;			/* All args were "" */
	     lengths (*) = 0;
	     return;
	end;
	jj = save_jj;				/* back to where we were */
	argstringx = 1;				/* how many characters so far, this time */
	do i = 1 to ute.arg_count;
	     begin;
dcl  ARG char (ute.ln_args - argstringx + 1) based (addr (substr (argstring, argstringx)));
		call login_parse_ (addr (ch (jj)), ll - jj + 1, ARG, k, j, code);
		if code ^= 0 then do;		/* impossible! */
bad_ag_string:	     code = as_error_table_$bad_login_arguments_string;
		     errarg = "";
		     return;
		end;
		lengths (i) = k;			/* remember how long it was */
		jj = jj + j;			/* Advance cursor. */
		argstringx = argstringx + k;		/* Diminish argstring */
		if argstringx > ute.ln_args + 1 then	/* impossible! */
		     go to bad_ag_string;
	     end;
	end;
	go to exit;

arg_handler (54):					/* -lg */
arg_handler (55):					/* -long */
	ute.at.brief = false;			/* Set appropriate attribute flag */
	ute.ur_at.brief = true;
	go to nxarg;

arg_handler (56):					/* -warning */
	ute.at.no_warning = false;
	ute.ur_at.no_warning = true;
	go to nxarg;

arg_handler (57):					/* -user */
	if entry_sw = NORMAL then go to badarg;		/* only slave and dial */
	jj = jj + j;
	call login_parse_ (addr (ch (jj)), ll - jj + 1, arg, i, j, code);
	if code ^= 0 then go to lp_error;
	if substr (arg, 1, 1) = "-" then go to noarg;	/* missing operand */
	if index (arg, ".") ^= 0 then do;		/* Person.Project */
	     ute.person = before (arg, ".");		/* just the person id */
	     ute.project = after (arg, ".");
	     if ute.project = "" then go to badarg;	/* Person. */
	end;
	else ute.person = substr(arg,1,length(ute.person));
						/* just specified Person */
	go to nxarg;

/* Come here when we run out of arguments. */

exit:
	if entry_sw = NORMAL then do;
	     if ute.login_flags.cdp then
		if ute.project = "" then do;		/* if changing dft proj, must specify */
		     code = as_error_table_$need_project_for_cdp; /* Mistake. */
		     errarg = "";
		     return;
		end;

	     if ute.login_flags.cda
	     then if ^ute.login_flags.auth_given
		then do;
		     code = as_error_table_$need_authorization_for_cda;
		     errarg = "";
		     return;
		end;

	     if cdtep ^= null then
		if cdte.immediate_arg then
		     if cdte.disconnected_proc_command ^= 4 & /* -new_proc */
			cdte.disconnected_proc_command ^= 5 /* -destroy */
		     then do;
			errarg = "-immediate";
			go to badarg2;
		     end;
	end;					/* entry_sw = NORMAL */
	return;

%page;
dial_line: entry (lp, ll, a_utep, errarg, code);

	entry_sw = DIAL;
	code = 0;					/* Assume no error will happen. */
	arg, prev_arg, errarg = "";
	utep = a_utep;
	cdtep = ute.channel;
	if cdtep ^= null then do;
	     cdte.disconnected_proc_command, cdte.disconnected_proc_number = 0;
	     cdte.save_arg, cdte.nosave_arg, cdte.hold_arg,
		cdte.no_hold_arg, cdte.immediate_arg = ""b;
	end;
	jj = 1;					/* start cursor */
	ute.login_flags.dial_pw = "1"b;		/* dial, and nothing else */
	ute.login_code = "dial";			/* for messages which use this */
	ute.mask_ctl = DERIVE_MASK;			/* Default is to let TTYDIM tell us whether to mask */
	call login_parse_ (lp, ll, ute.dial_qualifier, k, j, code); /* read the dial qualifier */
	if code ^= 0 then				/* dial name must be given */
	     return;
	if index (ute.dial_qualifier, "-") = 1 then do;
	     code = as_error_table_$dial_request_error;	/* what about that dial name? */
	     errarg = "dial qualifier must precede any control arguments.";
	     return;
	end;
	jj = jj + j;				/* Advance cursor. */
	call login_parse_ (addr (ch (jj)), ll - jj + 1, arg, k, j, code); /* Get 2nd argument */
	if code ^= 0 then do;
	     if code = error_table_$noarg then		/* just a registered server name */
		code = 0;
	     else errarg = arg;			/* some other error */
	     return;
	end;
	if index (arg, "-") ^= 1 then do;		/* not a control arg */
	     ute.sender = arg;			/* otherwise, its "dial x Person.Project" */
	     go to nxarg;				/* now, any control args */
	end;
	else go to arglp;				/* start on control args */


slave_line: entry (lp, ll, a_utep, errarg, code);

	entry_sw = SLAVE;
	code = 0;					/* Assume no error will happen. */
	utep = a_utep;
	cdtep = ute.channel;
	if cdtep ^= null then do;
	     cdte.disconnected_proc_command, cdte.disconnected_proc_number = 0;
	     cdte.save_arg, cdte.nosave_arg, cdte.hold_arg,
		cdte.no_hold_arg, cdte.immediate_arg = ""b;
	end;
	errarg, prev_arg, arg = "";
	ute.login_flags.slave_pw = "1"b;		/* slave, and nothing else */
	ute.login_code = "slave";			/* for messages which use this */
	ute.mask_ctl = DERIVE_MASK;			/* Default is to let TTYDIM tell us whether to mask */
	j = 0;
	jj = 1;
	go to nxarg;
%page; %include author_dcl;
%page; %include cdt;
%page; %include user_attributes;
%page; %include user_table_entry;


     end parse_login_line_;




		    pdir_volume_manager_.pl1        12/12/91  2152.8r w 12/12/91  1645.0      329796



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1991   *
        *                                                         *
        * 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: style4 */
pdir_volume_manager_: proc;

/* This procedure manages the placement of process directories on logical volumes.
   It also manages the quota on >pdd, to prevent it from running out or overflowing.

   PDIR VOLUME MANAGEMENT:

   The intention is to spread the space requirements and paging load for process
   directory segments among several logical volumes, to increase system performance
   and to eliminate the need for a site to have one logical volume large enough to
   accomodate all process directory segments.

   The segments of a process directory are placed on a particular logical volume
   by setting the sons volume of >pdd to that volume just before creating
   the process directory. It takes its sons volume from its parent (>pdd) and
   retains that sons volume even when the sons volume of >pdd is changed at the
   time of the next process creation. Thus all the segments in a process directory
   reside on the same logical volume. The directories themselves are on the root
   logical volume, as are all directories. We will speak of a process directory
   being on a volume, for brevity, when we really mean that the segments of the
   process directory are on that volume.

   The placement algorithm could be arbitrarily complex, taking into account
   the size and current space available of each logical volume, the current
   distribution of process directories among logical volumes, and even the amount
   of recent paging activity on each volume. Different groups of users could
   be restricted to having their process directory segments on certain logical
   volumes only. It is unclear which, if any, of these criteria would lead to the
   best improvement in system performance. Therefore the algorithm used in this
   initial implementation is the simplest possible one. It is expected to result
   in a measurable performance improvement. Refinements to the placement algorithm
   can be made later if they are found to be necessary and effective.

   A list of logical volumes available for process directory segments is kept by
   using a bit in the disk table. Thus only mounted logical volumes can be in
   the list, and the list must be initialized at each bootload. Process directories
   are placed on the volumes in this list in proportion to the number of physical
   volumes in each logical volume. The proportion is observed only in the creation
   of process directories. It is assumed that process destructions will be
   spread evenly over the entire set of processes, and so the proportion of
   process directories on each logical volume will remain as desired even though the
   deletion of process directories is not recorded and used by the placement algorithm.

   The desired proportion is achieved by going through the physical volume entries
   in the disk table, in rotation, and if a pv is part of an lv available for
   pdirs, choosing that lv. A static variable remembers the last pv entry used,
   so that the rotation can be resumed with that entry at the next process creation.

   The index in the disk table of the logical volume on which a user's process
   directory is placed is recorded in the process's user table entry, so that it
   is possible to determine where all the process directories are (as_who will
   print this information if requested), but searching all 3 user tables at each
   process creation to count the process directories on each volume would be impractical.

   Volumes can be added to or deleted from the list of process directory volumes
   during system operation. To demount a volume containing process directory
   segments, it is necessary to remove it from the list, thus halting the placing
   of new process directories on it, and then wait for processes whose process
   directories are already on it to be destroyed (by logout, new_proc, or bump).
   The pdir volume indices in the user tables are the means by which these
   processes can be identified.

   Alternately, the process directories may be force evacuated to another
   logical volume via the vacate_pdir_volume operator command entry. This
   command takes any number of specified logical volumes, suspending further
   process directory creation on them and then calling a routine which will
   find users with process directories on the volumes and walk their process
   directories, force moving the segments contained therein. It should be
   noted that this operation may cause an imbalance as established in the
   normal process directory allocation scheme.

   The system administrator must ensure that volumes placed in the pdir
   volume list have enough space available on them to accomodate the expected
   number of process directories. We do not monitor space available in this
   initial implementation.

   PDD QUOTA MANAGEMENT:

   The problem is that quota is a fixed bin (17) unaligned variable in the ASTE, limiting it to 131,071 (2**17-1).
   With large numbers of processes, or larger than normal quotas on some pdirs, >pdd could easily
   run out of quota. This procedure is called just before each process creation and destruction.
   It keeps track of the quota on >pdd, and sets it higher or lower if it is in danger of running out or overflowing
   because of the process directory that is about to be created or deleted. Whenever the quota on
   >pdd must be changed, it is set to half the maximum quota, to attempt to minimize the
   number of times it has to be set.

   USER RING DISK TABLE MANAGEMENT:

   There is a little magic that goes on here that one should be aware of.
   The disk_table resides in ring 1 and this procedure works with a copy of
   it, residing in our process directory, as provided by disk_table_$get_dtp.
   Those entries contained herin that modify the disk_table do so by calling
   the disk_table_ procedure.  That procedure, after modifying the disk_table_
   calls the appropriate routine, (mdx$...) to update our copy.

   ENTRYPOINTS:

   This procedure contains 10 entry points:

   $init		    called by as_init_ at startup time
   $select_pdir_volume  called by cpg_ before a process directory is created; sets sons volume of >pdd to the selected volume,
   .		    updates pdd quota records, and sets >pdd quota if necessary
   $set_pdir_volumes    operator command; replaces the list of pdir volumes
   $add_pdir_volume     operator command; adds a pdir volume to the list
   $del_pdir_volume     operator command; deletes a pdir volume from the list
   $note_pdir_deletion  called by dpg_ at process destruction time; updates pdd quota records; sets >pdd quota if necessary
   $print_pdq	    operator command; prints internal variables, for debugging
   $shared_spindle_on   operator command; turns on optimization for shared-spindle
   devices (this is the default)
   $shared_spindle_off  operator command; turns off optimization for shared-spindle
   devices (emergency bypass)

   $vacate_pdir_volume  operator command; suspends creation of pdirs on the specified
   volumes and then moves perprocess segments off of those volumes.

   Modification history:

   Initial coding by T. Casey, August 1977

   Modified by T. Casey, October 1977 to put while clause on both sections of disk table search, in select_pdir_volume
   Modified by T. Casey, January 1978 to check used bit before turning off pdirs_ok, in set_pdir_volumes
   Modified by T. Casey, May 1978, to add >pdd quota management.
   Modified by J. Bongiovanni, April 1981, for shared spindle devices
   Modified by J. Bongiovanni, September 1981, for emergency bypass of shared
   spindle optimization
   Modified November 1981, E. N. Kittlitz.  user_table_entry conversion.
   Modified March 1982, E. N. Kittlitz. added xxx_pdv as synonyms for xxx_pdir_volume.
   Modified April 1982, E. N. Kittlitz. New AS initialization.
   Modified 831122 for PDIR vacating... -E. A. Ranzenbach
   <<< NOTE >>> THIS PROCEDURE CONTAINS QUESTIONABLE PROGRAMMING TECHNIQUES AND
   SHOULD BE REWRITTEN AS TIME PERMITS... -ear

   Modified 83-12-06 BIM to check AIM for LV.
   Modified 84-12-27 Keith Loepere for pdir dir_quota.
   Modified 85-01-17 E. A. Ranzenbach to change vac_pdv to ignore lve.pdirs_ok
     and to only print one message per directory...
*/

/****^  HISTORY COMMENTS:
  1) change(86-05-12,Fawcett), approve(86-05-12,MCR7383),
     audit(86-05-21,Coppola), install(86-07-18,MR12.0-1098):
     Changed because of a compiler warning found during recompile.
  2) change(87-04-26,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-27,Hartogs), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
  3) change(88-04-27,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-03,Lippard), install(88-08-29,MR12.2-1093):
      A) Set ename identifier variable at print_pdq ep to avoid garbage in
         error messages. (phx17303)
  4) change(91-03-11,Vu), approve(91-03-11,MCR8243), audit(91-12-09,Zimmerman),
     install(91-12-12,MR12.5-1009):
     Bad argument list for call to sys_log_.
                                                   END HISTORY COMMENTS */


/* DECLARATIONS */

/* Parameters */

dcl  a_atep ptr;
dcl  a_code fixed bin (35);

/* Constants */

dcl  HALF_MAXQ fixed bin int static options (constant) init (65535); /* half of largest possible quota */
dcl  MAXQ fixed bin int static options (constant) init (131071); /* largest possible quota */
dcl  SAFETY_MARGIN fixed bin int static options (constant) init (1024); /* let >pdd's quota get only this close to limits */
dcl  zzBB char (20) int static options (constant) init (">pdd>!zzzzzzzbBBBBBB"); /* pathname of initializer's pdir */

/* Internal Static Variables */

dcl  already_init bit (1) aligned int static init (""b);
dcl  (cur_lvix, cur_pvix, n_pdir_volumes) fixed bin int static;
dcl  static_dtp ptr int static init (null);
dcl  shared_spindle_hack bit (1) aligned int static init ("1"b);

dcl  default_pddir_q fixed bin int static;		/* default pdir dir_quota */
dcl  default_pdq fixed bin int static;			/* the default pdir quota that we think hardcore is using */
dcl  npd fixed bin int static;			/* number of pdirs we know about */
dcl  pdddir_q fixed bin int static;			/* current dir_quota on >pdd (we think) */
dcl  pddq fixed bin int static;			/* current quota on >pdd (we think) */
dcl  pddir_q fixed bin int static;			/* sum of dir_quotas on all pdirs */
dcl  pdq fixed bin int static;			/* sum of quotas on all pdirs */
dcl  pddq_known bit (1) aligned int static init (""b);	/* "1"b if we think we know >pdd's quota */
dcl  more_than_one_pdir_vol bit (1);			/* true until we run out...		*/

/* External Static */

dcl  error_table_$action_not_performed ext fixed bin (35);
dcl  error_table_$out_of_sequence fixed bin (35) ext static;
dcl  error_table_$badopt fixed bin (35) ext static;

/* External Entries */

dcl  absolute_pathname_ 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  disk_table_$get_dtp entry (ptr);
dcl  disk_table_$set_lv_pdir_bit entry (char (*), bit (1) aligned, fixed bin (35));
dcl  disk_table_$set_vacate_pdirs_bit entry (char (*), bit (1) aligned, 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  hcs_$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_set entry (char (*), fixed bin, fixed bin (35));
dcl  hphcs_$quota_set entry (char (*), fixed bin, fixed bin (35));
dcl  hphcs_$pv_move_file entry (char (*), char (*), fixed bin (35));
dcl  hphcs_$set_sons_lvid entry (char (*), char (*), bit (36), fixed bin (35));
dcl  hphcs_$set_pdir_sons_lvid entry (char (*), char (*), bit (36), fixed bin (35));
dcl  read_allowed_ entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  sub_err_ entry () options (variable);
dcl  (sys_log_, sys_log_$error_log) entry options (variable);
dcl  unique_chars_ entry (bit (*)) returns (char (15));
dcl  sweep_disk_$dir_list entry (char (168) aligned, entry);
dcl  write_allowed_ entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

/* Automatic */

dcl  ename char (32);
dcl  loud fixed bin;				/* sys_log_ severity... */
dcl  code fixed bin (35);
dcl  i fixed bin;
dcl  n_new_pdir_volumes fixed bin;
dcl  pvix fixed bin;
dcl  idx fixed bin (17);				/* miscellaneous index...		*/
dcl  pdir char (168) aligned;
dcl  pdir_to_move char (168);
dcl  pdir_vol_name char (32);
dcl  pdir_lvid bit (36);
dcl  proc_lvix fixed bin (17);

dcl  (argl, argno, nargs) fixed bin;
dcl  argp ptr;
dcl  dir_discrepancy fixed bin;
dcl  discrepancy fixed bin;
dcl  pass_number fixed bin;
dcl  pddq_was_known bit (1) aligned;
dcl  just_got_quota bit (1) aligned init (""b);
dcl  long_sw bit (1);
dcl  (dir_quota, quota, qused) fixed bin, tpp fixed bin (71), uptime fixed bin (35),
     slvid bit (36), qswitch fixed bin (1);		/* args for quota_read call */

/* Based */

dcl  arg char (argl) based (argp);

/* Builtin */

dcl  (addr, index, max, min, null, rtrim) builtin;
%page;

/* PROCEDURE */

init: entry;

	ename = "pdir_volume_manager_$init";
	if ^sc_stat_$Multics_typed | sc_stat_$Go_typed then
	     call sub_err_ (error_table_$out_of_sequence, ename, "s");

	already_init = "0"b;			/* indicate that we are initializing */

	call disk_table_$get_dtp (static_dtp);		/* and disk table ptr */
	cur_pvix = 1;				/* start with first pv in disk table */
	cur_lvix = 0;				/* most recently selected lv; none right now */

	dtp = static_dtp;				/* we are about to reference disk_table */
	n_pdir_volumes = count_pdir_volumes ();		/* to count pdir volumes left from last bootload */

	npd = 1;					/* zzBB (initializer's pdir) */
	call get_pdd_quota;				/* initialize our copy of >pdd's quota, and get zzBB's quota */

	already_init = "1"b;
	return;					/* all done */


select_pdir_volume: entry (a_atep, a_code);

	ename = "select_pdir_volume";
	if ^valid_call () then return;		/* check for init and copy static ptrs */
	utep = a_atep;
	a_code = 0;
	code = 0;

	if ^pddq_known then call get_pdd_quota;		/* if we have lost track of >pdd's quota, go read it */

	if (pddq - ute.pdir_quota - SAFETY_MARGIN < 0)	/* if >pdd's quota is in danger of going negative */
	     | (pdddir_q - ute.pdir_dir_quota - SAFETY_MARGIN < 0) then 
	     call set_pdd_quota;			/* set it higher */

	if ute.pdir_quota > 0 then do;		/* if we know the quota of the pdir about to be created */
	     pddq = pddq - ute.pdir_quota;		/* update our records */
	     pdq = pdq + ute.pdir_quota;
	end;
	else do;					/* if not, */
	     pddq_known = ""b;			/* we may have just lost track of >pdd's quota */
	     pddq = pddq - default_pdq;		/* but we can make a good guess */
	     pdq = pdq + default_pdq;
	end;
	if ute.pdir_dir_quota > 0 then do;		/* if we know the dir quota of the new pdir */
	     pdddir_q = pdddir_q - ute.pdir_dir_quota;	/* update our records */
	     pddir_q = pddir_q + ute.pdir_dir_quota;
	end;
	else do;
	     pddq_known = ""b;			/* we may have lost track */
	     pdddir_q = pdddir_q - default_pddir_q;	/* pdir dir_quota */
	     pddir_q = pddir_q + default_pddir_q;
	end;

	npd = npd + 1;				/* count pdirs */

	if n_pdir_volumes = 0 then do;		/* if none, avoid time-wasting search of all pvs */
	     ute.pdir_lvix = 0;			/* we don't know the sons volume of >pdd */
	     return;				/* but it's probably ok the way it is */
	end;

	call select_pdir_vol (pdir_vol_name, proc_lvix, pdir_lvid, code);
	if code ^= 0 then do;
	     a_code = code;
	     return;
	end;
	if cur_lvix ^= proc_lvix then do;
	     call hphcs_$set_sons_lvid (">", "pdd", pdir_lvid, code); /* set sons lvid for the new one...	*/
	     if code ^= 0 then do;
		a_code = code;
		return;
	     end;
	     cur_lvix = proc_lvix;
	end;

	ute.pdir_lvix = proc_lvix;			/* note PDIR LV for the process...	*/

	return;


note_pdir_deletion: entry (a_atep);

	ename = "note_pdir_deletion";
	if ^valid_call () then return;		/* check that we are initialized, and copy static pointers */
	utep = a_atep;

	if ^pddq_known then call get_pdd_quota;		/* if we lost track of >pdd's quota, go read it */

	if (pddq + ute.pdir_quota + SAFETY_MARGIN > MAXQ)	/* if >pdd's quota is in danger of overflowing */
	     | (pdddir_q + ute.pdir_dir_quota + SAFETY_MARGIN > MAXQ) then
	     call set_pdd_quota;			/* set it lower */

	if ute.pdir_quota > 0 then do;		/* if we know the quota of the pdir that is about to be deleted */
	     pddq = pddq + ute.pdir_quota;		/* update our records */
	     pdq = pdq - ute.pdir_quota;
	end;
	else do;					/* if not, */
	     pddq_known = ""b;			/* we may have just lost track of >pdd's quota */
	     pddq = pddq + default_pdq;		/* but we can make a good guess */
	     pdq = pdq - default_pdq;
	end;
	if ute.pdir_dir_quota > 0 then do;		/* if we know how much is being deleted */
	     pdddir_q = pdddir_q + ute.pdir_dir_quota;	/* update ourt records */
	     pddir_q = pddir_q - ute.pdir_dir_quota;
	end;
	else do;
	     pddq_known = ""b;			/* we may have lost track */
	     pdddir_q = pdddir_q + default_pddir_q;	/* dir_quota */
	     pddir_q = pddir_q - default_pddir_q;
	end;

	npd = npd - 1;				/* count pdirs */

	return;


print_pdq: entry;					/* operator command, for debugging */

	ename = "pdir_volume_manager_$print_pdq";
	pddq_was_known = pddq_known;			/* remember if it was known */
	call get_pdd_quota;				/* be sure we have correct value */
	call sys_log_ (-1, "pddq = ^d, pdq = ^d, npd = ^d,^[ ^[un^]expected discrepancy was ^d^;^s^s^]^/pdddir_q = ^d, pddir_q = ^d,^[ ^[un^]expected discrepancy was ^d^]",
	     pddq, pdq, npd, (discrepancy ^= 0), pddq_was_known, discrepancy,
	     pdddir_q, pddir_q, (dir_discrepancy ^= 0), pddq_was_known, dir_discrepancy);
	call sys_log_ (-1, "lvix = ^d, pvix = ^d, npdv = ^d", cur_lvix, cur_pvix, n_pdir_volumes);
	return;


add_pdir_volume: entry;
add_pdv: entry;

	ename = "add_pdir_volume";

	if ^valid_call () then return;

	call cu_$arg_count (nargs);
	if nargs ^= 1 then do;
one_arg_wanted: call sys_log_ (2, "^a: one argument required: logical volume name", ename);
	     return;
	end;

	call cu_$arg_ptr (1, argp, argl, code);
	if code ^= 0 then do;
err_log_no_msg: call sys_log_$error_log (2, code, "^a", ename);
	     return;
	end;

	if ^find_lve (arg) then do;
vol_not_found: call sys_log_ (2, "^a: volume ""^a"" not in disk table", ename, arg);
	     return;
	end;

	if ^lve.hv_mounted | ^lve.public then do;
	     call sys_log_ (2, "^a: volume ""^a"" must be mounted and public to be used for pdirs", ename, arg);
	     return;
	end;

	call disk_table_$set_lv_pdir_bit (arg, ("1"b), code);
	if code ^= 0 then goto err_log_no_msg;

	n_pdir_volumes = count_pdir_volumes ();		/* update static pdir volume count */

	return;


del_pdir_volume: entry;
del_pdv: entry;

	ename = "del_pdir_volume";

	if ^valid_call () then return;

	call cu_$arg_count (nargs);
	if nargs ^= 1 then goto one_arg_wanted;

	call cu_$arg_ptr (1, argp, argl, code);
	if code ^= 0 then goto err_log_no_msg;

	if ^find_lve (arg) then goto vol_not_found;

	if ^lve.pdirs_ok then do;
	     call sys_log_ (2, "^a: volume ""^a"" is not a pdir volume", ename, arg);
	     return;
	end;

	if count_pdir_volumes () ^> 1 then do;		/* if there is only one pdir volume */
	     call sys_log_ (2, "^a: deleting volume ""^a"" would leave no pdir volumes", ename, arg);
	     return;
	end;

	call disk_table_$set_lv_pdir_bit (arg, (""b), code);
	if code ^= 0 then goto err_log_no_msg;

	n_pdir_volumes = count_pdir_volumes ();
	return;


set_pdir_volumes: entry;
set_pdv: entry;

	ename = "set_pdir_volumes";
	if ^valid_call () then return;

	call cu_$arg_count (nargs);
	if nargs ^> 0 then do;
	     call sys_log_ (2, "^a: names of pdir volumes must be given", ename);
	     return;
	end;

/* Check the specified volumes for suitability */

	n_new_pdir_volumes = 0;
	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 then goto err_log_no_msg;
	     if ^find_lve (arg) then
		call sys_log_ (2, "^a: volume ""^a"" not in disk table", ename, arg);
	     else if ^lve.hv_mounted | ^lve.public then
		call sys_log_ (2, "^a: volume ""^a"" must be mounted and public to be used for pdirs", ename, arg);
	     else n_new_pdir_volumes = n_new_pdir_volumes + 1;
	end;

	if n_new_pdir_volumes = 0 then return;
	if n_new_pdir_volumes < nargs then
	     call sys_log_ (2, "^a: ^d of ^d specified volumes unusable for pdirs; the others will be used",
		ename, nargs - n_new_pdir_volumes, nargs);

/* Clear current pdir volumes */

	do i = 1 to dt.n_lv_entries;
	     if dt.lv_array (i).used & dt.lv_array (i).pdirs_ok then do;
		call disk_table_$set_lv_pdir_bit ((dt.lv_array (i).lvname), (""b), code);
		if code ^= 0 then
		     call sys_log_$error_log (2, code, ename, dt.lv_array (i).lvname);
	     end;
	end;

/* Set new pdir volumes */

	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 then goto err_log_no_msg;
	     if find_lve (arg) then do;
		if lve.hv_mounted & lve.public then do;
		     call disk_table_$set_lv_pdir_bit (arg, ("1"b), code);
		     if code ^= 0 then
			call sys_log_$error_log (2, code, ename, arg);
		end;
	     end;
	end;

	n_pdir_volumes = count_pdir_volumes ();

	return;

vacate_pdir_volume:
     entry;
vac_pdv: entry;

	ename = "vacate_pdir_volume";
	if ^valid_call () then return;

	call cu_$arg_count (nargs);
	if nargs < 1 then do;
	     call sys_log_ (2, "^a: At least one logical volume must be specified.", ename);
	     return;
	end;

	more_than_one_pdir_vol = "1"b;
	long_sw = "0"b;

	loud = 0;					/* log only...			*/

	do argno = 1 to nargs while (more_than_one_pdir_vol);
	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 then go to err_log_no_msg;
	     if index (arg, "-") = 1 then do;
		if arg = "-long" | arg = "-lg" then loud = 2;
		else do;
		     call sys_log_$error_log (2, error_table_$badopt,"^a",  arg);
		     return;
		end;
	     end;
	     else do;
		if ^find_lve (arg) then call sys_log_ (2, "^a: ^a is not a logical volume and will not be processed.", ename, arg);
		else do;
		     if lve.pdirs_ok & (count_pdir_volumes () ^>1) then do;
			call sys_log_ (2, "^a: Deleting volume ^a would leave no pdir volumes.^/Further volume processing suspended.", ename, arg);
			more_than_one_pdir_vol = "0"b;
		     end;
		     else do;
			call disk_table_$set_vacate_pdirs_bit (arg, ("1"b), code);
			if code ^= 0 then call sys_log_$error_log (2, code, "^a: Processing of this volume suspended.",
			     ename);
		     end;
		end;
	     end;
	end;

	do i = 1 to dt.n_lv_entries;			/* do each lv that needs vacating...	*/
	     if dt.lv_array (i).used & dt.lv_array (i).vacate_pdirs then do; /* this one needs working...		*/
		lvep = addr (dt.lv_array (i));
		call find_user_move_pdir (i);		/* move the user's pdir...		*/
		call disk_table_$set_vacate_pdirs_bit ((dt.lv_array (i).lvname), "0"b, code);
		if code ^= 0 then call sys_log_ (2, "^a: Unable to clear vacate_pdirs switch for logical volume ^a.",
			ename, dt.lv_array (i).lvname);
	     end;
	end;

	return;

shared_spindle_on: entry;

	ename = "pdir_volume_manager_";
	call set_shared_spindle ("1"b);
	return;

shared_spindle_off: entry;

	ename = "pdir_volume_manager_";
	call set_shared_spindle ("0"b);
	return;

count_pdir_volumes: proc returns (fixed bin);

dcl  nvol fixed bin;
dcl  i fixed bin;

	nvol = 0;
	do i = 1 to dt.n_lv_entries;
	     if dt.lv_array (i).used & dt.lv_array (i).public & dt.lv_array (i).hv_mounted
		& dt.lv_array (i).pdirs_ok then nvol = nvol + 1;
	end;
	return (nvol);

     end count_pdir_volumes;

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

find_lve: proc (a_lvname) returns (bit (1) aligned);

dcl  a_lvname char (*);
dcl  i fixed bin;

	do i = 1 to dt.n_lv_entries;
	     if dt.lv_array (i).used & dt.lv_array (i).lvname = a_lvname then do;
		lvep = addr (dt.lv_array (i));
		return ("1"b);
	     end;
	end;

	return (""b);

     end find_lve;

find_user_move_pdir:
     proc (lv_idx);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*										*/
/* Internal procedure to walk the answer_table looking for users whose process directory is on the	*/
/* logical volume specified by lv_idx. These users process directories are then seg_moved to a	*/
/* different logical volume.								*/
/*										*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

dcl  lv_idx fixed bin (17) parameter;			/* index of the LV to vacate...	*/

/* START_find_user_move_pdir: */
          ansp = as_data_$ansp;
	do idx = 1 to anstbl.current_size;		/* search the answer_table...		*/
	     utep = addr (anstbl.entry (idx));		/* -> user_table_entry...		*/
	     if ute.active = NOW_HAS_PROCESS & ute.pdir_lvix = lv_idx then do; /* this one must be moved...		*/
		pdir = ">pdd>" || unique_chars_ ((ute.proc_id));
		call sys_log_ (loud, "vacate_pdir_volume:  Processing ^a (^a.^a) on ^a.",
		     pdir, ute.person, ute.project, lve.lvname);
		call select_pdir_vol (pdir_vol_name, proc_lvix, pdir_lvid, code);
		if code ^= 0 then return;
		call hphcs_$set_pdir_sons_lvid (">pdd", unique_chars_ ((ute.proc_id)), pdir_lvid, code);
		if code ^= 0 then do;
		     call sys_log_$error_log (2, code, "Unable to set sons lvid for ^a.", pdir);
		     return;
		end;
		call sweep_disk_$dir_list ((pdir), move_pdir_segs);
		ute.pdir_lvix = proc_lvix;
	     end;
	end;

          autp = as_data_$autp;
	do idx = 1 to autbl.current_size;		/* search the absentee_user_table...	*/
	     utep = addr (autbl.entry (idx));		/* -> user_table_entry...		*/
	     if ute.active = NOW_HAS_PROCESS & ute.pdir_lvix = lv_idx then do; /* this one must be moved...		*/
		pdir = ">pdd>" || unique_chars_ ((ute.proc_id));
		call sys_log_ (loud, "vacate_pdir_volume:  Processing ^a (^a.^a) on ^a.",
		     pdir, ute.person, ute.project, lve.lvname);
		call select_pdir_vol (pdir_vol_name, proc_lvix, pdir_lvid, code);
		if code ^= 0 then return;
		call hphcs_$set_pdir_sons_lvid (">pdd", unique_chars_ ((ute.proc_id)), pdir_lvid, code);
		if code ^= 0 then do;
		     call sys_log_$error_log (2, code, "Unable to set sons lvid for ^a.", pdir);
		     return;
		end;
		call sweep_disk_$dir_list ((pdir), move_pdir_segs);
		ute.pdir_lvix = proc_lvix;
	     end;
	end;

          dutp = as_data_$dutp;
	do idx = 1 to dutbl.current_size;		/* search the daemon_user_table...	*/
	     utep = addr (dutbl.entry (idx));		/* -> user_table_entry...		*/
	     if ute.active = NOW_HAS_PROCESS & ute.pdir_lvix = lv_idx then do; /* this one must be moved...		*/
		pdir = ">pdd>" || unique_chars_ ((ute.proc_id));
		call sys_log_ (loud, "vacate_pdir_volume:  Processing ^a (^a.^a) on ^a.",
		     pdir, ute.person, ute.project, lve.lvname);
		call select_pdir_vol (pdir_vol_name, proc_lvix, pdir_lvid, code);
		if code ^= 0 then return;
		call hphcs_$set_pdir_sons_lvid (">pdd", unique_chars_ ((ute.proc_id)), pdir_lvid, code);
		if code ^= 0 then do;
		     call sys_log_$error_log (2, code, "Unable to set sons lvid for ^a.", pdir);
		     return;
		end;
		call sweep_disk_$dir_list ((pdir), move_pdir_segs);
		ute.pdir_lvix = proc_lvix;
	     end;
	end;

	return;

     end find_user_move_pdir;

move_pdir_segs:
     proc (containing_dir, dir, level, entry, branch_ptr, names_ptr);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*										*/
/* Internal procedure to demand segment move all of the segments in the current directory.	*/
/*										*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

dcl  containing_dir char (32) aligned parameter;		/* containing directory...		*/
dcl  dir char (32) aligned parameter;			/* directory we're in...		*/
dcl  entry char (32) aligned parameter;			/* entry that we will examine...	*/
dcl  level fixed bin (17) parameter;			/* directory depth...		*/
dcl  branch_ptr ptr parameter;			/* -> star_dir_list_branch...		*/
dcl  names_ptr ptr parameter;				/* -> star_list_names...		*/

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


/* START_move_pdir_segs: */

	star_list_branch_ptr = branch_ptr;

/* Only interseted in the first branch entry type,
  and the next two statments keep the compiler happy */
          star_branch_count = 1;
          star_link_count = 0;

	if star_list_branch.type (star_branch_count) ^= star_SEGMENT then return; /* ignore all but segments...		*/

	call absolute_pathname_ (rtrim (containing_dir) || ">" || rtrim (dir),
	     pdir_to_move, code);
	if code ^= 0 then do;
	     call sys_log_$error_log (2, code, "^a", rtrim (containing_dir) || ">" || rtrim (dir));
	     return;
	end;

	call hphcs_$pv_move_file (pdir_to_move, (entry), code);
	if code ^= 0 then call sys_log_$error_log (2, code, "vacate_pdir_volume: Unable to move ^a.",
		rtrim (pdir_to_move) || ">" || rtrim (entry));

	return;

     end move_pdir_segs;

select_pdir_vol:
     proc (lvol_name, lvol_idx, lvol_id, code);

dcl  lvol_name char (32) parameter;
dcl  lvol_idx fixed bin (17) parameter;
dcl  lvol_id bit (36) parameter;
dcl  code fixed bin (35) parameter;

/* go through mounted physical volumes in rotation, using shared_spindle_flip
   to hit shared spindle devices half as often as others, since they use
   two physical devices for a single actuator.  Two passes are necessary,
   to cover the case where all pdir volumes are shared spindle type					*/

	code = 0;
	do pass_number = 1 to 2;			/* rotate thru all physical volumes..	*/
	     do pvix = cur_pvix + 1 to dt.n_entries, 1 to cur_pvix; /* until we have selected a pdir volume */
		dtep = addr (dt.array (pvix));	/* get ptr to pv entry */
		if dte.device_type > 0 & dte.device_type <= maxdevt
		     & shared_spindle (dte.device_type) /* shared spindle device			*/
		     & shared_spindle_hack		/* and we're optimizing */
		then dte.shared_spindle_flip = ^dte.shared_spindle_flip; /* hit half as often	*/
		else dte.shared_spindle_flip = "1"b;	/* not shared spindle - hit every time		*/

		if dte.used & dte.storage_system	/* see if it is ok */
		     & dte.shared_spindle_flip
		     & dte.lvx >= 1 & dte.lvx <= dt.n_lv_entries then do; /* be absolutely sure */
		     lvep = addr (dt.lv_array (dte.lvx)); /* get ptr to its lv entry */
		     if lve.used & lve.hv_mounted & lve.public & lve.pdirs_ok & read_allowed_ (ute.process_authorization, lve.min_access_class) &
			write_allowed_ (ute.process_authorization, lve.max_access_class) then do; /* if it is usable for pdirs */
			cur_pvix = pvix;		/* remember index of pv that we stopped on */
			lvol_idx = dte.lvx;
			lvol_name = lve.lvname;
			lvol_id = lve.lvid;
			return;
		     end;				/* end lv selected */
		end;				/* end pv in a pdir volume */
	     end;					/* end rotation thru pvs */
	end;

	call sys_log_ (2, "^a: Unable to select volume for pdir of ^a.^a", ename, ute.person, ute.project);
	code = error_table_$action_not_performed;

     end select_pdir_vol;

/* ---------- */

get_pdd_quota: proc;

	call gq (">pdd");
	if code ^= 0 then do;
	     call sys_log_ (2, code, ename, "reading quota of >pdd");
	     return;
	end;

	discrepancy = pddq - quota;			/* positive if there was a pdir creation we did not record */
	dir_discrepancy = pdddir_q - dir_quota;
	if already_init & discrepancy ^= 0 then do;	/* log discrepancy unless we are just initializing */
	     call sys_log_ (0, "^a: ^[un^]expected discrepancy of ^d in >pdd quota: actual = ^d, recorded = ^d",
		ename, pddq_known, discrepancy, quota, pddq);
	     if ^pddq_known then			/* if previous call had ute.pdir_quota = 0, update our records */
		pdq = pdq + discrepancy;
	end;
	if already_init & dir_discrepancy ^= 0 then do;	/* log discrepancy unless we are just initializing */
	     call sys_log_ (0, "^a: ^[un^]expected discrepancy of ^d in >pdd dir_quota: actual = ^d, recorded = ^d",
		ename, pddq_known, dir_discrepancy, dir_quota, pdddir_q);
	     if ^pddq_known then			/* update our records */
		pddir_q = pddir_q + dir_discrepancy;
	end;

	pddq = quota;
	pdddir_q = dir_quota;
	pddq_known = "1"b;
	just_got_quota = "1"b;			/* for the benefit of set_pdd_quota */

	if ^already_init then do;			/* if we are initializing */
	     call gq (zzBB);			/* get quota of initializer's pdir */
	     if code ^= 0 then do;
		call sys_log_$error_log (2, code, ename, "reading quota of ^a", zzBB);
		return;
	     end;
	     default_pdq = quota;			/* sneaky way of copying out active_hardcore_data$pdir_quota */
	     default_pddir_q = dir_quota;
	     pdq = quota;				/* initialize sum of all pdir quotas */
	     pddir_q = dir_quota;
	end;

	return;

     end get_pdd_quota;

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

gq:  proc (dir);

dcl  dir char (*);

	call hcs_$quota_read (dir, quota, tpp, uptime, slvid, qswitch, qused, code);
	call hcs_$dir_quota_read (dir, dir_quota, tpp, uptime, slvid, qswitch, qused, code);
	return;

     end gq;

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

set_pdd_quota: proc;

	if ^just_got_quota then call get_pdd_quota;	/* might as well look before we change it */

	if ename = "note_pdir_deletion" then do;
	     quota = max (0,			/* avoid going negative */
		min (HALF_MAXQ,			/* set quota to HALF_MAXQ */
		MAXQ - ute.pdir_quota - SAFETY_MARGIN));/* unless we are about to delete a very large pdir */
	     dir_quota = max (0,			/* avoid going negative */
		min (HALF_MAXQ,			/* set quota to HALF_MAXQ */
		MAXQ - ute.pdir_dir_quota - SAFETY_MARGIN));/* unless we are about to delete a very large pdir */
	end;
	else do;
	     quota = min (MAXQ,			/* avoid overflowing the quota cell */
		max (HALF_MAXQ,			/* set quota to HALF_MAXQ */
		ute.pdir_quota + SAFETY_MARGIN));	/* unless we are about to create a very large pdir */
	     dir_quota = min (MAXQ,			/* avoid overflowing the quota cell */
		max (HALF_MAXQ,			/* set quota to HALF_MAXQ */
		ute.pdir_dir_quota + SAFETY_MARGIN));	/* unless we are about to create a very large pdir */
	end;
	call hphcs_$quota_set (">pdd", quota, code);
	if code ^= 0 then do;
	     call sys_log_$error_log (2, code, ename, "setting >pdd quota to ^d", quota);
	     return;
	end;
	call hphcs_$dir_quota_set (">pdd", dir_quota, code);
	if code ^= 0 then do;
	     call sys_log_$error_log (2, code, ename, "setting >pdd dir_quota to ^d", dir_quota);
	     return;
	end;

	call sys_log_ (0, "^a: changed >pdd quota from ^d to ^d", ename, pddq, quota);
	pddq = quota;
	call sys_log_ (0, "^a: changed >pdd dir_quota from ^d to ^d", ename, pdddir_q, dir_quota);
	pdddir_q = dir_quota;

	return;
     end set_pdd_quota;

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

set_shared_spindle: proc (on_or_off);

dcl  on_or_off bit (1);

	call sys_log_ (2, "^a: Shared-spindle optimization changed from ^[on^;off^] to ^[on^;off]",
	     ename, shared_spindle_hack, on_or_off);
	shared_spindle_hack = on_or_off;



     end set_shared_spindle;


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

valid_call: proc returns (bit (1) aligned);

	if ^already_init then do;
	     call sys_log_ (2, "^a: Called before answering service initialization", ename);
	     return (""b);
	end;

	dtp = static_dtp;
	return ("1"b);

     end valid_call;

%page; %include absentee_user_table;
%page; %include answer_table;
%page; %include as_data_;
%page; %include as_data_definitions_;
%page; %include daemon_user_table;
%page; %include dialup_values;
%page; %include disk_table;
%page; %include fs_dev_types;
%page; %include sc_stat_;
%page; %include star_structures;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

     end pdir_volume_manager_;




		    scramble_.pl1                   10/27/83  1613.0rew 10/27/83  1441.4       26091



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


/* format: style4 */
scramble_: proc (arg) returns (char (8));

/* SCRAMBLE_ - Scramble a char (8) string.

   This procedure, given a password as input, returns an 8-character output string which:
   1. bears some relationship to the input
   2. loses some information - some passwords may scramble to the same value
   3. has no obvious relation to the input ("aaaaaaaa" and "aaaaaaab"
   .  scramble to noticeably different values.)

   Passwords stored in system files are scrambled, so that if anyone gets a dump
   of the password file by accident, it won't do him much good.

   The transform is supposed to be non-invertible.

   A previous version of this program had two defects:
   1) It was invertible, as Steve Lipner demonstrated.
   2) It depended on double-precision MOD and MULTIPLY. These turned out
   .  to have been incorrectly implemented by PL/I and so the scramble,
   .  while good, would have given different values if the bugs were fixed.

   Method:
   1. strip the two high-order bits of each ASCII character, packing to the right.
   2. treat the resulting 56-bit quantity as both key and cipher text for
   .  the system enciphering program.
   3. destroy selected bits of the resulting cipher.

   Revised 5/21/73, THVV, for new algorithm.
   THVV 10/30/71
*/

dcl  arg char (8);

dcl  temp char (8),
     temp1 (1) fixed bin (71),
     temp2 (1) fixed bin (71),
     (p1, p2, p3) ptr,				/* ptrs to based overlays */
     (i, k) fixed bin;

dcl  bbt bit (72) aligned based (p1),
     b72 bit (72) aligned based (p3),
     bc8 char (8) aligned based (p3);

dcl  1 tsx based (p2) aligned,
       2 pad bit (16) unal,
       2 z (8) bit (7) unal;

dcl  encipher_ entry (fixed bin (71), dim (*) fixed bin (71), dim (*) fixed bin (71), fixed bin);

dcl  (addr, fixed, mod, substr) builtin;

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

	temp = arg;				/* copy argument */
	p1 = addr (temp);
	p2 = addr (temp1 (1));
	p3 = addr (temp2 (1));
	temp1 (1) = 0;
	k = 1;
	do i = 3 to 72 by 9;
	     z (k) = substr (bbt, i, 7);		/* squeeze out always-zero bits */
	     k = k + 1;
	end;
	temp = "";				/* Erase temporary copy */
	call encipher_ (temp1 (1), temp1, temp2, 1);	/* Encipher the password. */
	temp1 (1) = 0;				/* Tidy up */
	b72 = b72 & "111111110111111110111111110111111110111111110111111110111111110111111110"b;
	return (bc8);

     end;




		    send_system_message_.pl1        09/16/88  1309.4rew 09/16/88  1308.2       45423



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/* format: style4,^indattr */

/****^  HISTORY COMMENTS:
  1) change(85-11-27,Herbst), approve(87-07-13,MCR7697),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
     New program.
  2) change(86-01-29,Herbst), approve(87-07-13,MCR7697),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
     Changed to accept initial ring number as argument.
  3) change(87-04-01,Brunelle), approve(87-07-13,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Add inactivity system message to those allowed.
  4) change(87-05-31,GDixon), approve(87-07-13,MCR7697),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
     Set group_id to null string rather than *.*.*, because the message really
     is not directed to all users.
  5) change(88-07-15,Brunelle), approve(88-09-13,MCR7980),
     audit(88-09-13,Beattie), install(88-09-16,MR12.2-1112):
     Change calling sequence to take ptr to UTE instead of individual values.
     Use users process authorization not Initiailizer's when adding message to
     the mailbox.  This way an upgraded user can delete the message when it is
     received.
                                                   END HISTORY COMMENTS */

send_system_message_: proc (P_utep, P_message_ptr, P_code);

/* Sends a message to a specified process_id accompanied by a system_message_
   IPS signal. The receiving process has a static handler,
   system_message_handler_, which responds to this signal by reading all the
   outstanding system messages for that recipient. The message sent by this
   program must be of one of the types listed in system_message.incl.pl1.
   The only types currently implemented are
   .  SYSTEM_MESSAGE_TYPE_AS_WARN, which the Answering Service uses to
   implement the operator "warn" command; and
   .  SYSTEM_MESSAGE_TYPE_AS_INACTIVITY, which the Answering Service uses to
   implement the inactivity mechanism.
*/

/* Parameters */

dcl  P_utep ptr parameter;				/* UTE ptr for user to warn */
dcl  P_message_ptr ptr parameter;			/* ptr to message (Input) */
dcl  P_code fixed bin (35) parameter;

/* Automatic */

dcl  1 auto_asum_add_info aligned like as_user_message_add_info;
dcl  message_len fixed bin (18);

/* External */

dcl  error_table_$bad_version fixed bin (35) ext;
dcl  error_table_$badcall fixed bin (35) ext;

/* Entries */

dcl  as_user_message_$priv_add_message entry (ptr, fixed bin (35));
dcl  hphcs_$ips_wakeup entry (bit (36) aligned, char (*));

/* Builtins */

dcl  (addr, currentsize, null, unspec) builtin;
%page;
	if P_message_ptr = null | P_utep = null then do;
BAD_CALL:
	     P_code = error_table_$badcall;
	     return;
	end;

	utep = P_utep;
	P_code = 0;

	system_message_ptr = P_message_ptr;

	if system_message.version ^= SYSTEM_MESSAGE_VERSION_1 then do;
BAD_VERSION:
	     P_code = error_table_$bad_version;
	     return;
	end;

	if system_message.type = SYSTEM_MESSAGE_TYPE_AS_WARN then do;
	     if system_message.type_version ^= SYSTEM_MESSAGE_AS_WARN_V1 then go to BAD_VERSION;
	     message_len = currentsize (warn_system_message);
	end;
	else if system_message.type = SYSTEM_MESSAGE_TYPE_AS_INACTIVITY then do;
	     if system_message.type_version ^= SYSTEM_MESSAGE_AS_INACTIVITY_V1 then go to BAD_VERSION;
	     message_len = currentsize (inactivity_system_message);
	end;
	else if system_message.type = SYSTEM_MESSAGE_TYPE_DM_SHUT then do;
	     if system_message.type_version ^= SYSTEM_MESSAGE_DM_SHUT_V1 then go to BAD_VERSION;
	     message_len = currentsize (dm_shut_system_message);
	end;
	else go to BAD_CALL;

	unspec (auto_asum_add_info) = "0"b;
	auto_asum_add_info.version = AS_USER_MESSAGE_ADD_INFO_VERSION_1;
	auto_asum_add_info.message_ptr = system_message_ptr;
	auto_asum_add_info.message_length = message_len;
	auto_asum_add_info.message_access_class = ute.process_authorization;
	auto_asum_add_info.destination_info.group_id = "";
						/* process id is used instead. */
	auto_asum_add_info.destination_info.process_id = ute.proc_id;
	auto_asum_add_info.destination_info.handle = SYSTEM_MESSAGE_HANDLE;
	auto_asum_add_info.destination_info.ring = ute.initial_ring;
	auto_asum_add_info.reader_deletes = "1"b;

	call as_user_message_$priv_add_message (addr (auto_asum_add_info), P_code);

	call hphcs_$ips_wakeup (ute.proc_id, "system_message_");

	return;

/* format: off */
%page; %include as_user_message_add;
%page; %include system_message;
%page; %include user_attributes;
%page; %include user_message_handles;
%page; %include user_table_entry;			        

end send_system_message_;


	     




		    user_table_mgr_.pl1             07/13/88  1114.4rew 07/13/88  0905.0      152100



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1987 *
        *                                          *
        ******************************************** */

/****  TBS:  sys_log_ message documentation */

/****^  HISTORY COMMENTS:
  1) change(86-04-01,Swenson), approve(87-07-13,MCR7737),
     audit(87-04-19,GDixon), install(87-08-04,MR12.1-1055):
     Initial coding.
  2) change(87-04-19,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Replace calls to freen_ with free statements, following coding
         standards.
      B) Improve error logging.
      C) Support absentee and daemon user tables.
  3) change(87-05-11,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Decrement user_table.in_use, whether UTE is put on free list or
         table size is reduced.
  4) change(87-05-14,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
     Take asdump when user_table_mgr_$free is given UTE which has invalid
     process_type.  Continue execution if utep identifies a valid user table
     entry; stop execution if it does not.
  5) change(87-05-24,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Make user_table_mgr_$reset reuse the same UTE, rather than freeing
         the UTE and allocating a (perhaps different) UTE.
      B) This is done by splitting the Allocate and Free internal procedures
         into 4 pieces: Allocate_UTE, Fill_UTE, Empty_UTE and Free_UTE.
  6) change(87-05-27,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Increment user_table.in_use in Allocate_UTE rather than in Fill_UTE.
         Otherwise, user_table_mgr_$reset causes a steady incrementing of
         user_table.in_use with no equivalent decrementing.
  7) change(87-07-21,GDixon), approve(87-07-21,MCR7741),
     audit(87-07-23,Brunelle), install(87-08-04,MR12.1-1055):
      A) Change Free_UTE to use its P_ute_index parameter, instead of
         incorrectly referencing the ute_index variable declared in the main
         procedure.
  8) change(88-03-18,Parisek), approve(88-03-18,MCR7849),
     audit(88-03-22,Lippard), install(88-07-13,MR12.2-1047):
     Set ute.lowest_ring.
                                                   END HISTORY COMMENTS */

/* format: style4 */

user_table_mgr_:
     procedure;

/* Parameters */

dcl  P_process_type fixed bin parameter;
dcl  P_uc_ls_handle bit (72) aligned parameter;
dcl  P_utep ptr parameter;

/* Automatic */

dcl  ME char(36) varying automatic;
dcl  abort_label label variable;
dcl  1 auto_uc_ls_handle structure aligned like uc_ls_handle automatic;
dcl  code fixed bin (35) automatic;
dcl  process_type fixed bin automatic;
dcl  user_table_ptr ptr automatic;
dcl  ute_index fixed bin (17) automatic;

/* Based */

dcl  argstring char (ute.ln_args) based (ute.args_ptr);
dcl  lengths (ute.arg_count) based (ute.arg_lengths_ptr) fixed bin;
dcl  system_area area based (system_area_ptr);
dcl  1 user_table aligned based (user_table_ptr),
       2 header like ut_header,
       2 in_use fixed bin,
       2 entry_pad (128-size(ut_header)-1) fixed bin,
       2 entry (0 refer (user_table.header.current_size)) like ute;

/* Entries */

dcl  as_dump_ entry (char(*));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));

/* Internal */

dcl  system_area_ptr ptr int static init (null);

/* External */

dcl  as_data_$ansp ptr external;
dcl  as_data_$autp ptr external;
dcl  as_data_$dutp ptr external;

/* Builtins */

dcl  (addr, baseno, hbound, lbound, null, size, unspec) builtin;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


/* Program */

allocate:
     entry (P_process_type) returns (ptr);

	ME = "user_table_mgr_$allocate";

	utep = null ();
	abort_label = ALLOCATE_ABORT;

	if P_process_type = PT_INTERACTIVE then
	   user_table_ptr = as_data_$ansp;
	else if P_process_type = PT_ABSENTEE then
	   user_table_ptr = as_data_$autp;
	else if P_process_type = PT_DAEMON then
	   user_table_ptr = as_data_$dutp;
	else call Abort (SL_LOG, -1,
	   "Process type (^d) not allowed.", P_process_type);

	call Allocate_UTE (ute_index);
	if ute_index ^= 0 then do;
	     call Reset_UTE();
	     call Fill_UTE (ute_index, P_process_type);
	end;

ALLOCATE_ABORT:
	return (utep);

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

free: entry (P_utep);

	ME = "user_table_mgr_$free";
	go to FREE_JOIN;

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

reset:	entry (P_utep);

	ME = "user_table_mgr_$reset";

FREE_JOIN:
	abort_label = FREE_ABORT;
	utep = P_utep;
	process_type = ute.process_type;

	if process_type = PT_INTERACTIVE then
	   user_table_ptr = as_data_$ansp;
	else if process_type = PT_ABSENTEE then
	   user_table_ptr = as_data_$autp;
	else if process_type = PT_DAEMON then
	   user_table_ptr = as_data_$dutp;

	else do;					/* invalid type  */
						/* find table    */
	   if baseno (as_data_$ansp) = baseno (utep) then do;
	        user_table_ptr = as_data_$ansp;
	        process_type = PT_INTERACTIVE;
	   end;
	   else if baseno (as_data_$autp) = baseno (utep) then do;
	        user_table_ptr = as_data_$autp;
	        process_type = PT_ABSENTEE;
	   end;
	   else if baseno (as_data_$dutp) = baseno (utep) then do;
	        user_table_ptr = as_data_$dutp;
	        process_type = PT_DAEMON;
	   end;
	   else
	      user_table_ptr = null;

	   if user_table_ptr = null then
	      call Abort (SL_LOG_BEEP, -1,
	      "UTE pointer (^p) does not point in one of the 3 user tables.",
	      utep);
	   else do;
	      do ute_index = hbound(user_table.entry,1) to
	         lbound(user_table.entry,1) by -1
	         while (utep ^= addr(user_table.entry(ute_index)));
	         end;
	      if ute_index = 0 then
	         call Abort (SL_LOG_BEEP, -1,
	         "UTE pointer (^p) does not point at an entry in ^a.",
	         utep, TABLE_NAMES(user_table.user_table_type));
	      else do;
	         call Warning (SL_LOG_BEEP, 
		    "UTE (^d, ^p in ^a) has invalid process type (^d).",
		    ute_index, utep,
		    TABLE_NAMES(user_table.user_table_type),
		    ute.process_type);
	         call as_dump_ ((sl_info.ioa_msg));
	         ute.process_type = process_type;
	      end;
	   end;
	end;

	if lbound(ACTIVE_VALUES,1) < ute.active &
	     ute.active <= hbound(ACTIVE_VALUES,1) then;
	else if ute.active = NOW_FREE then
	     call Abort (SL_LOG_BEEP, -1,
	     "UTE (^d, ^p in ^a) already free; ute.active: ^d (^a)",
	     ute.ute_index, utep, TABLE_NAMES(user_table.user_table_type),
	     ute.active, ACTIVE_VALUES(ute.active));
	else call Abort (SL_LOG_BEEP, -1,
	     "UTE (^d, ^p in ^a) invalid; ute.active: ^d",
	     ute.ute_index, utep, TABLE_NAMES(user_table.user_table_type),
	     ute.active);

	if addr(user_table.entry(ute.ute_index)) ^= utep then do;
	     do ute_index = hbound(user_table.entry,1) to
		lbound(user_table.entry,1) by -1
		while (addr(user_table.entry(ute_index)) ^= utep);
		end;
	     call Warning (SL_LOG_BEEP,
		"UTE (^d, ^p in ^a) invalid: ute.ute_index: ^d",
		ute_index, utep, TABLE_NAMES(user_table.user_table_type),
		ute.ute_index);
	     ute.ute_index = ute_index;
	end;

	if ME = "user_table_mgr_$free" then do;
	     ute_index = ute.ute_index;
	     call Empty_UTE();
	     call Reset_UTE();
	     call Free_UTE (ute_index);
	     P_utep = null;
	     return;
	end;
	else if ME = "user_table_mgr_$reset" then do;
	     ute_index = ute.ute_index;
	     call Empty_UTE();
	     call Reset_UTE();
	     call Fill_UTE (ute_index, process_type);
	     return;
	end;

FREE_ABORT:
	P_utep = null ();				/* so no one will use it */
	return;

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


utep_from_handle:
     entry (P_uc_ls_handle) returns (ptr);

/**** This entry takes a handle supplied by a login server and determines
      the associated utep. */

	ME = "user_table_mgr_$utep_from_handle";

	utep = null ();
	abort_label = UTEP_FROM_HANDLE_ABORT;

	uc_ls_handle_ptr = addr (P_uc_ls_handle);
	auto_uc_ls_handle = uc_ls_handle;
	uc_ls_handle_ptr = addr (auto_uc_ls_handle);

	if uc_ls_handle.process_type = PT_INTERACTIVE then
	   user_table_ptr = as_data_$ansp;
	else if uc_ls_handle.process_type = PT_ABSENTEE then
	   user_table_ptr = as_data_$autp;
	else if uc_ls_handle.process_type = PT_DAEMON then
	   user_table_ptr = as_data_$dutp;
	else call Abort (SL_LOG, -1,
	     "Handle (^24.3b) has unsupported process type (^d).",
	     P_uc_ls_handle, uc_ls_handle.process_type);

	utep = addr (user_table.entry (uc_ls_handle.ute_index));
	if ute.active = NOW_FREE then 
	     call Abort (SL_LOG, -1,
	     "Handle (^24.3b) identifies free UTE (^d, ^p in ^a).",
	     P_uc_ls_handle, ute.ute_index, utep,
	     TABLE_NAMES(user_table.user_table_type));
	if ute.login_server_info.our_handle ^= unspec (uc_ls_handle) then 
	     call Abort (SL_LOG, -1,
	     "Handle (^24.3b) identifies UTE (^d, ^p in ^a) with different handle (^24.3b).",
	     P_uc_ls_handle, ute.ute_index, utep,
	     TABLE_NAMES(user_table.user_table_type),
	     ute.login_server_info.our_handle);

UTEP_FROM_HANDLE_ABORT:
	return (utep);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Abort: Report fatal error in AS log and abort execution.		       */
/*							       */
/* Syntax:  call Abort (severity, code, ioa_ctl, args);		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Abort:
     procedure options (variable);

dcl  cu_$arg_list_ptr entry () returns (ptr);
dcl  sys_log_$general entry (ptr);

          sl_info = sl_info_sev_code_msg;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));
	if sl_info.code ^= 0 then do;
	     utep = null;
	     go to abort_label;
	end;

     end Abort;

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


Allocate_UTE:
     procedure (P_ute_index);

dcl  P_ute_index fixed bin;
dcl  ute_index fixed bin;

REALLOCATE:
     	utep = null;

	if user_table.number_free > 0 then do;
	     ute_index = user_table.first_free;
	     utep = addr (user_table.entry (ute_index));
	     if ute.active = NOW_FREE then do;
		user_table.first_free = ute.next_free;
		user_table.number_free = user_table.number_free - 1;
	     end;
	     else do;
		call Warning (SL_LOG_BEEP,
		"UTE (^d, ^p in ^a) at head of free list is not free; ute.active: ^d (^a)",
		ute_index, utep, TABLE_NAMES(user_table.user_table_type),
		ute.active, ACTIVE_VALUES(ute.active));
		call Reconstruct_free_list ();
		go to REALLOCATE;
	     end;
	end;
	else if user_table.current_size < user_table.max_size then do;
	     ute_index,
		user_table.current_size = user_table.current_size + 1;
	     utep = addr (user_table.entry (ute_index));
	end;
	else do;
	     ute_index = 0;
	     utep = null ();
	end;

          if ute_index ^= 0 then
	     user_table.in_use = user_table.in_use + 1;

	P_ute_index = ute_index;

     end Allocate_UTE;

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


Empty_UTE:
	procedure ();

/**** Get rid of event channel we may or may not have set up. */
	if ute.event ^= 0 then do;
	     call ipc_$delete_ev_chn (ute.event, (0));
	     ute.event = 0;
	end;

/**** Free the argument structures */
	if system_area_ptr = null then
	     system_area_ptr = get_system_free_area_ ();
	if ute.arg_lengths_ptr ^= null () then do;
	     free lengths in (system_area);
	     ute.arg_lengths_ptr = null ();
	     ute.arg_count = 0;
	end;
	if ute.args_ptr ^= null () then do;
	     free argstring in (system_area);
	     ute.args_ptr = null ();
	     ute.ln_args = 0;
	end;

     end Empty_UTE;

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


Fill_UTE:	procedure (P_ute_index, P_process_type);

dcl  P_ute_index fixed bin;
dcl  P_process_type fixed bin;

	if utep ^= null () then do;
	     call ipc_$create_ev_chn (ute.event, code);
	     if code ^= 0 then 
		call Abort (SL_LOG_BEEP, code,
		"Creating event channel for UTE (^d, ^p in ^a).",
		ute_index, utep, TABLE_NAMES(P_process_type));
	     ute.active = NOW_DIALED;
	     ute.ute_index = P_ute_index;
	     ute.process_type = P_process_type;
	end;

     end Fill_UTE;

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


Free_UTE:	procedure (P_ute_index);

dcl  P_ute_index fixed bin;

	ute.active = NOW_FREE;
	ute.ute_index = P_ute_index;
	
	if P_ute_index = user_table.current_size then 
	     user_table.current_size = user_table.current_size - 1;
	else do;
	     ute.next_free = user_table.first_free;
	     user_table.first_free = P_ute_index;
	     user_table.number_free = user_table.number_free + 1;
	end;
          user_table.in_use = user_table.in_use - 1;
	utep = null;

     end Free_UTE;

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


Reconstruct_free_list:
     procedure;

dcl  ute_index fixed bin;

          user_table.number_free, user_table.first_free = 0;
     	do ute_index = hbound(user_table.entry,1) to
	     lbound(user_table.entry,1) by -1;
	     utep = addr(user_table.entry(ute_index));
	     if ute.active = NOW_FREE then do;
		ute.next_free = user_table.first_free;
		user_table.first_free = ute_index;
		user_table.number_free = user_table.number_free + 1;
	     end;
	end;
     end Reconstruct_free_list;

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


Reset_UTE:
     procedure ();

	unspec (ute) = ""b;
	ute.tty_name,
	     ute.tty_id_code,
	     ute.dial_qualifier,
	     ute.generated_pw,
	     ute.outer_module,
	     ute.old_password,
	     ute.logout_type,
	     ute.login_code,
	     ute.person,
	     ute.project,
	     ute.home_dir,
	     ute.init_proc,
	     ute.group,
	     ute.tag,
	     ute.input_seg,
	     ute.output_seg,
	     ute.sender,
	     ute.proxy_person,
	     ute.proxy_project,
	     ute.abs_group,
	     ute.terminal_type = "";

/**** The follow variables allow a legal 0 value, so we use -1. */

	ute.work_class,
	     ute.initial_ring,
	     ute.lowest_ring,
	     ute.highest_ring = -1;

	ute.uprojp = null;
	ute.pdtep = null;
	ute.channel = null;
	ute.arg_lengths_ptr = null;
	ute.args_ptr = null;

	ute.real_queue = -9;
	return;

     end Reset_UTE;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Warning: report warning in AS log, and continue execution.	       */
/*							       */
/* Syntax:  call Warning (severity, ioa_ctl, args);		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

Warning:
     procedure options (variable);

dcl  cu_$arg_list_ptr entry () returns (ptr);
dcl  sys_log_$general entry (ptr);

          sl_info = sl_info_sev_msg;
	sl_info.arg_list_ptr = cu_$arg_list_ptr ();
	sl_info.caller = ME;
	call sys_log_$general (addr (sl_info));

     end Warning;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* format: off */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* The following three include files are not used, but are overlaid by the   */
/* user_table structure declared at the start of this program.  They are     */
/* included here for ease of reference.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

     %include absentee_user_table;
 %include answer_table;
 %include daemon_user_table;
 %include dialup_values;
 %include sys_log_constants;
 %include uc_ls_handle;
 %include user_attributes;
 %include user_table_entry;
 %include user_table_header;

end user_table_mgr_;



		    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
