



		    adjust_mrds_db.pl1              10/23/86  1024.2r w 10/23/86  1009.0      221598



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

adjust_mrds_db: amdb: proc;

/* DESCRIPTION:

   This routine is the  command  interface  which  will  adjust  the
   specified data base.

   If the -reset option is specified, then the dbc is  examined.  If
   any  active  users  are discovered, the requestor is asked if she
   really wishes to reset the dbc. If so, then the  dbc  segment  is
   truncated and reinitialized.

   The  requestor  should realize that the -reset option will remove
   ALL  users from the data base, so care should be taken to execute
   this command only when the data base is not being used by anyone.
   Amdb  will  check to see if there are active or open users of the
   database and will warn the requestor if this is the case.

   The -trouble_switch control arg can be used with both  -reset  or
   -dpr,  or  alone.  The -trouble_switch off option will cause only
   the trouble_switch and possibly the scope_lock (both of the  dbc)
   to   be  reset.  The  -trouble_switch  on  option  will  set  the
   trouble_switch to ON.

   The -dead_processs option will allow for removal  of  all  'dead'
   users  from  the  dbc  and  can be invoked while the data base is
   being used by others.

   If the database is marked as being inconsistent, The requestor is
   warned  about  this  and  given the reason stored in the database
   before the amdb request is completed.

*/

/* HISTORY:

   Originally written by Oris D. Friesen in August 1977

   Modified by Al Kepner, March 12, 1979, to work with MR7.0 version
   data bases.

   Modified by M. Pierret, 5 December, 1979, to :  make  -reset  the
   default  operation;  restructure the program; require the user to
   have sma access on database directory.

   Modified  by  M.  Pierret  April  1980  to:  add  -dead_procs   ,
   -trouble_switch on/off options; change use of locks.

   Modified by Jim Gray - - May 1980, to handle case of only -tsw on
   being given as the control argument.

   Modified by Jim Gray - - June 1980, to fix logic that makes  user
   have sma on the database directory(not the db containing dir).

   Modified by Jim Gray - - 21-June-80, to report no model,  not  no
   model/submodel err mesg

   80-12-09  Jim  Gray : took truncation task out of AMDB and put in
   common module mu_concurrency_control$reset_control_segment.  Also
   made  getting  of  the  dbc_ptr  able  to  find either a "dbc" or
   "db.control"  named  segment  for  hanlding either version 4 or 5
   dbcs.             This           was           done           via
   mu_concurrency_control$get_control_segment.

   80-12-12 Jim Gray : Updated usage message to include  -dead_procs
   and -trouble_switch.

   80-12-24 Jim Gray : improved error messages for  null  or  r-only
   access on database control segment.

   81-01-27 Jim Gray : added usage of dsl_$get_path_info to  correct
   problems   with   dsl_$get_db_version,   and   added   usage   of
   dmd_$get_authorization as part of dba proposal implementation.

   81-04-27 Jim Gray : added -force and -no_force control  arguments
   for  optionally  over-riding  the  query, when active users exist
   These  controls  imply  -reset.  Changed   to   allow   duplicate
   -reset/-force/-no_force  control  arguments  for  over-riding  in
   ec's, and for force option to make sense.

   82-04-30  Mike  Kubicar  : amdb now checks the consistency bit in
   the db_model segment and prints a warning message if the database
   is  inconsistent.   Included in the message is the message placed
   in  the  database  describing  the  reason for the inconsistency.
   After  the  warning message is printed, the command completes its
   function normally.

   82-05-10  Mike Kubicar : Also changed to check the user list on a
   reset  to  determine  more  presicely  what type of users will be
   affected.  A distinction is made between dead and living users.

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.

   83-06-21 Davids: Removed check for old version database and the call
   to v1 code if it was an old version db (old version dbs can no longer
   be opened)

   84-09-05 Thanh Nguyen: Modified code not to restrict to the position
   of path name. 

   84-09-14 Paul Benjamin: Further modification to make sure that only one
   pathname is accepted.
*/

/* Check number of arguments. There must be from 1 to 5 arguments, like so:
   *     amdb <db_path> [ -reset (,-rs) -trouble_switch (,-tsw) on/off
   *                    | -dead_procs (,-dpr) -tsw on/off
   *		 | -trouble_switch (,-tsw) on/off  | -force | -no_force */


	call cu_$arg_count (n_args);
	if n_args < 1				/* must be at least 2 args: db_path and a control arg */
	then call error (0,
		"Usage:  amdb db_path {{-dead_procs|-reset{-force}}{-trouble_switch on/off}}");

	if n_args > 5
	then call error (error_table_$too_many_args, "");

	db_dir = copy (" ", 168);
	code = 0;
	path_name_sw = "0"b;
	do idx = 1 to n_args while (code = 0);
	     call cu_$arg_ptr (idx, arg_ptr, arg_len, code);
	     if code ^= 0 then call error (code, "control argument");
	     if index (arg, "-") = 1 then do;
		if arg = "-reset" | arg = "-rs"
		then if dead_process_sw
		     then call error (error_table_$inconsistent, arg);
		     else reset_sw = ON;

		else if arg = "-dead_procs" | arg = "-dpr"
		     then if reset_sw
			then call error (error_table_$inconsistent, arg);
			else dead_process_sw = ON;


		     else if arg = "-trouble_switch" | arg = "-tsw"
			then do;
			     if idx < n_args
			     then idx = idx + 1;
			     else call error (error_table_$badopt, "");

			     call cu_$arg_ptr (idx, arg_ptr, arg_len, code);
			     if code ^= 0
			     then call error (code, "control argument");

			     if arg = "on"
			     then trouble_sw_on = ON;
			     else if arg ^= "off"
				then call error (error_table_$badopt, arg);
			          else ;
			end;

/* BEGIN CHANGE 81-04-27 *************************************** */

		     else if arg = "-force" | arg = "-fc" then do;
			     reset_sw, force_option = ON;
			     if dead_process_sw then
				call error (error_table_$inconsistent, arg);
			end;

		     else if arg = "-no_force" | arg = "-nfc" then do;
			     force_option = OFF;
			     reset_sw = ON;
			     if dead_process_sw then
				call error (error_table_$inconsistent, arg);
			end;

/* END CHANGE 81-04-27 ********************************************** */

		     else call error (error_table_$badopt, arg);

	     end;
	     else do;
		if path_name_sw			/* pathname already given */
		     then call error (error_table_$bad_arg, arg);
		path_name_sw = "1"b;
		dbp_ptr = arg_ptr;
		dbp_len = arg_len;
		in_path = dbp;

		/* check mrds version and path type */
		call mrds_dsl_get_version$get_path_info (in_path, addr (local_area),
		     mrds_path_info_structure_version, mrds_path_info_ptr, code);
		if mrds_path_info_ptr = null () then
		     db_path = in_path;
		else db_path = mrds_path_info.absolute_path;
		if code ^= 0 then do;
		     if code = mrds_error_$no_model_submodel then
			code = mrds_error_$no_database;
		     call error (code, db_path);
		end;

		if mrds_path_info.type.submodel then
		     call error (error_table_$badcall,
		     "Data submodels are not supported by this command.  " || db_path);

/* END CHANGE 81-01-27 ************************************************ */

		call expand_pathname_ (db_path, db_dir, db_ent, code);
		if code ^= 0 then call error (code, db_path);	/* return to command level */
		
		if length (rtrim (db_path)) > 164		/* must allow path <db_path>>dbc totalling <= 168 chars */
		     then call error (error_table_$pathlong, db_path);

/* Get control arg, set appropriate switch for later use */

		if n_args = 1
		     then reset_sw = ON;
	     end;

	end;
	if path_name_sw = "0"b then
	     call error (0, "data base path name is missing."); /* exit with error message */

/* BEGIN CHANGE 81-01-27 ********************************************* */
/* make sure the user is a DBA */

	call mrds_dm_authorization$get_user_class (rtrim (db_path),
	     addr (local_area),
	     mrds_authorization_structure_version, mrds_authorization_ptr, code);
	if code ^= 0 then
	     call error (code, "Unable to get user class for database """ || rtrim (db_path) || """");

	else if ^mrds_authorization.administrator then
	     call error (error_table_$insufficient_access,
		"User must be a database administrator to perform this operation on the database " || rtrim (db_path));

/* END CHANGE 81-01-27 ************************************************ */



/* Check to see if inconsistent bit is set */
	call mrds_dm_open (rtrim (db_path), RETREIVE_MODE, dm_ptr, code);
	if code ^= 0 then call error (code,
		"Unable to get a pointer to database model segment");
	call mdbm_util_$inconsistent_get_info (dm_ptr, inconsistent_value,
	     inconsistent_name, inconsistent_message, inconsistent_undo);
	if inconsistent_value then do;
		if inconsistent_message = " "
		then call ioa_ ("adjust_mrds_db: Warning, the database is inconsistent.  No reason was given.");
		else do;
			call ioa_ ("adjust_mrds_db: Warning, the database is inconsistent for the following reason:");
			call ioa_ ("^a.", inconsistent_message);
		     end;
		call ioa_ ("^/Please refer to restructure_mrds_db to repair it.");
	     end;


/* Get dbc_ptr */
	call mu_concurrency_control$get_control_segment (db_path, dbc_ptr, dbc_bit_count, code);
	if code ^= 0 then
	     call error (code, "Unable to get a pointer to the database control segment.");

/* Attempt to lock dbc */

	locked = OFF;
	call set_lock_$lock (dbc.scope_lock, (mrds_data_$lock_wait_time), code);
	if code = error_table_$invalid_lock_reset |
	     code = error_table_$locked_by_this_process
	then code = 0;


/* only set trouble switch or ... */

	if trouble_sw_on & ^dead_process_sw & ^reset_sw then
	     call set_trouble (code);

/* Remove all dead procs or.... */

	else if dead_process_sw
	then call remove_dead_processes (code);


/* ..Reset whole dbc */

	else if reset_sw
	then call reset_dbc (code);

/* ..Reset trouble switch */

	else if ^trouble_sw_on
	then call reset_trouble (code);


exit:
	if locked
	then call set_lock_$unlock (dbc.scope_lock, code);

	return;


reset_dbc: proc (icode);

	dcl     icode		 fixed bin (35);

	if icode ^= 0
	then do;
		clear_lock_sw = ON;
		icode = 0;
	     end;
	else locked = ON;


/* If the force option is not in effect, check to make sure there will be
   no users affected by a reset.  Scan through the open and active user
   lists to determine this.  Any dead users with no active scope can be
   ignored.  If users that will be affected are found, tell the user so
   and ask if he still wants to continue.  If both open and scope locks
   cannot be set, assume that someone is in the process of becoming
   active or open.  */

	if ^force_option then do;
		call set_lock_$lock (dbc.proper.open_lock,
		     (mrds_data_$lock_wait_time), code);
		open_lock_set = (code = 0) |
		     (code = error_table_$invalid_lock_reset) |
		     (code = error_table_$locked_by_this_process);
		found_quiesced, found_active, found_open,
		     found_dead_active = OFF;
		if locked
		then if dbc.proper.user_counts.active_users > 0
		     then do;
			     current_user_offset = dbc.proper.offsets.
				active_users_ofs;
			     do while ((current_user_offset ^= NULL_OFS) &
				(^found_active | (found_active &
				^found_dead_active)));
				current_user_ptr = pointer (dbc_ptr,
				     current_user_offset);
				if current_user_ptr -> user_list.flags.
				     dead_proc
				then found_dead_active = ON;
				else if process_dead (current_user_ptr
					-> user_list.ids.db_lock_id)
				then found_dead_active = ON;
				else found_active = ON;
				current_user_offset = current_user_ptr
				     -> user_list.offsets.next_active_ofs;
			     end;
			end;
		if open_lock_set & ^found_active
		then if dbc.proper.user_counts.open_users > 0
		     then do;
			     current_user_offset = dbc.proper.offsets.
				open_users_ofs;
			     do while ((current_user_offset ^= NULL_OFS) &
				^found_open);
				current_user_ptr = pointer (dbc_ptr,
				     current_user_offset);
				if ^current_user_ptr -> user_list.
				     flags.dead_proc then found_open
					= ^process_dead (current_user_ptr
					-> user_list.ids.db_lock_id);
				current_user_offset
				     = current_user_ptr
				     -> user_list.offsets.next_open_ofs;
			     end;
			end;


/* Now tell the user what we've found */

		if found_active
		then call ioa_ ("There are active users that may be affected if you reset the database.");
		else if found_open
		then call ioa_ ("There are open users that may be affected if you reset the database.");
		if ^locked
		then call ioa_ ("There may be active users of the database.");
		else if ^open_lock_set & ^found_active
		then call ioa_ ("There may be open users of the database.");
		if found_dead_active
		then call ioa_ ("There are dead processes with active scope set.");


/* Check for quiescing too */

		call set_lock_$lock (dbc.proper.quiesce_lock,
		     DONT_WAIT, code);
		if code = error_table_$lock_wait_time_exceeded then do;
			found_quiesced = ON;
			if dbc.proper.flags.quiesce_sw
			then call ioa_ ("Another DBA has quiesced the database.");
			else call ioa_ ("Another DBA is waiting to quiesce the database.");
		     end;

		if ^locked | ^open_lock_set | found_active | found_open
		     | found_dead_active | found_quiesced then do;
			call command_query_$yes_no (
			     reset_db_response, 0,
			     "adjust_mrds_db",
			     "Any current users of ^a will be affected if you reset the database.  Continue?",
			     "Do you still wish to reset ^a?", db_path);
			if ^reset_db_response then do;
				if open_lock_set then do;
					call set_lock_$unlock (dbc.proper.
					     open_lock, code);
					if code ^= 0
					then call error (code,
						"unlocking database");
				     end;
				return;
			     end;
		     end;

/* Note that the scope lock is unlocked by the calling procedure if the
   the answer was no.  If yes, everything is unlocked by the reset. */

	     end;


/* Reset the data base
   this causes the control segment to be truncated
   and then re-initialized with the latest version of the dbc structures
   the name of the control segment is also changed if necessary */


	call mu_concurrency_control$reset_control_segment (db_path, dbc_ptr, dbc_bit_count, icode);

	if icode ^= 0 then call error (icode, "Unable to re-initialize database control segment.");

/* Set trouble switch if asked */

	if trouble_sw_on
	then dbc.trouble_switch = ON;



     end reset_dbc;

remove_dead_processes: proc (icode);

/*
   This routine will go through the dbc lists, removing dead dead_processs
*/

	dcl     dead_sw		 bit (1);
	dcl     icode		 fixed bin (35);
	dcl     saved_ul_ptr	 ptr;
	dcl     ulo_ptr		 ptr;



/* Test for success of locking */

	if icode ^= 0
	then call error (icode, "");
	else locked = ON;


/* Search through open users list, looking for dead procs and cleaning them up */

	ulo_ptr = addr (dbc.open_users_ofs);
	ul_ptr = convert (dbc_ptr, dbc.open_users_ofs);
	do while (ul_ptr ^= null);
	     if user_list.dead_proc			/* Find out if user is dead */
	     then dead_sw = ON;
	     else do;
		     call set_lock_$lock ((user_list.db_lock_id), 0, icode);
		     if icode = error_table_$invalid_lock_reset
		     then dead_sw = ON;
		     else dead_sw = OFF;
		end;

/*  If user is dead, get rid of her */

	     if dead_sw
	     then do;

		     if user_list.event_signal_sw	/* Is waking up */
		     then dbc.wakeup_waiters = dbc.wakeup_waiters - 1;

/* Remove user from all lists, decrement totals, free structures */

		     saved_ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);
		     call mu_de_queue_user (DQ_OPEN, FREE_FIL_LIST, dbc_ptr, ul_ptr, icode);
		     ul_ptr = saved_ul_ptr;
		end;

	     else do;
		     ulo_ptr = addr (user_list.next_open_ofs);
		     ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);
		end;

	end /* End search through open list */;


/* Removal of all dead procs resolves any dead proc conflicts */

	dbc.flags.dead_proc_flag = OFF;

/* Set trouble switch if asked */

	if trouble_sw_on
	then dbc.trouble_switch = ON;


     end remove_dead_processes;

set_trouble: procedure (icode);

/* this routine sets the trouble switch, when that
   is all that is to be done */

	declare icode		 fixed bin (35);

/* test for success of locking */

	if icode ^= 0 then
	     call error (icode, "locking");
	else locked = ON;

	dbc.trouble_switch = ON;

     end;

reset_trouble: proc (icode);

	dcl     icode		 fixed bin (35);


/* Test for success of locking; failure means scope_lock must be reset */

	if icode ^= 0
	then dbc.scope_lock = CLEAR;
	else locked = ON;

/* Reset trouble switch */

	if dbc.flags.trouble_switch
	then dbc.flags.trouble_switch = OFF;

/* Clear scope lock, if necessary */

	if clear_lock_sw
	then dbc.scope_lock = CLEAR;

     end reset_trouble;

convert: proc (a_ptr, ofs) returns (ptr);

/* this procedure function converts an offset from "0"b to null
   or from the offset value to a pointer value within the segment denoted by a_ptr
*/

	dcl     result		 ptr;		/* the reultant pointer value */
	dcl     a_ptr		 ptr;		/* ptr to the segment to which the offset refers */
	dcl     ofs		 bit (18) unal;	/* the bit offset */

	dcl     (null, ptr)		 builtin;

	if ofs ^= NULL_OFS
	then result = ptr (a_ptr, ofs);
	else result = null;

	return (result);

     end convert;

error: proc (icode, string);

	dcl     icode		 fixed bin (35);
	dcl     string		 char (*);

	call com_err_ (icode, "adjust_mrds_db", "^/^a", string);

	goto exit;				/* return */

     end error;

process_dead:
     proc (lock_id) returns (bit (1));

/* This procedure check to see the process whose lock id is "lock_id"
   is a live process */

	dcl     icode		 fixed bin (35);
	dcl     lock_id		 bit (36) aligned;
	dcl     temp_lock		 bit (36) aligned;

	temp_lock = lock_id;
	call set_lock_$lock (temp_lock, DONT_WAIT, icode);
	return (icode = error_table_$invalid_lock_reset);
     end process_dead;

	dcl     (n_args,				/* nbr arguments in command string */
	        dbp_len,				/* length of data base path */
	        arg_len)		 fixed bin;	/* len of arg in chars */


	dcl     (dbp_ptr,				/* ptr to data base path */
	        arg_ptr)		 ptr;		/* ptr to control argument */

	dcl     code		 fixed bin (35);	/* Error code returned */
	dcl     db_dir		 char (168);	/* containing directory pathname of the data base */
	dcl     db_ent		 char (32);	/* entry name of the data base */
	dcl     cont_dir_ent	 char (32) init (""); /* containing dir entry */
	dcl     cont_dir_dir	 char (168) init (""); /* containing dir of the containing dir */

	dcl     in_path		 char (168) init (""); /* db pathname argument, in form suitable for passing */
	dcl     db_path		 char (168) init (""); /* absolute pathname of data base */
	dcl     db_path_var		 char (202) varying init (""); /* data base pathname made up of concatenation of dir and entry name */

	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     dbp		 char (dbp_len) based (dbp_ptr);

	dcl     idx		 fixed bin;

	dcl     reset_sw		 bit (1) init ("0"b); /* -rs=>reset dbc */
	dcl     trouble_sw_on	 bit (1) init ("0"b); /* -tsw=>trouble switch on/off */
	dcl     dead_process_sw	 bit (1) init ("0"b); /* -dpr=>remove only dead processes  */
	dcl     clear_lock_sw	 bit (1) init ("0"b); /* scope_lock is damaged */
	dcl     locked		 bit (1) init ("0"b); /* scope_lock has been locked - must unlock on error */
	dcl     dm_ptr		 ptr;		/* pointer to db_model segment */
	dcl     inconsistent_value	 bit (1);		/* The value of the inconsistency bit in db_model */
	dcl     inconsistent_name	 char (32);	/* The program which set the database inconsistent */
	dcl     inconsistent_message	 char (500);	/* The text message explaining the inconsistency */
	dcl     inconsistent_undo	 char (500);	/* The request to remove the inconsistency */
	dcl     open_lock_set	 bit (1);		/* Did amdb lock the open_lock of the dbc */
	dcl     current_user_ptr	 ptr;		/* Pointer to current node in user_list list */
	dcl     current_user_offset	 bit (18);	/* The corresponding offset */
	dcl     found_active	 bit (1);		/* Were any active database users found */
	dcl     found_open		 bit (1);		/* Any open users */
	dcl     found_dead_active	 bit (1);		/* Any dead users with active scope */
	dcl     found_quiesced	 bit (1);		/* Anybody quiescing the database */
	dcl     reset_db_response	 bit (1);		/* Response from continue query */
          dcl     path_name_sw           bit (1);           /* Path name missing or not */
                                                            /* Builtins */

	dcl     (index, copy, null, addr, empty, rtrim, length, pointer) builtin;

/* Constants */

	dcl     OFF		 bit (1) init ("0"b) int static options (constant);
	dcl     ON		 bit (1) init ("1"b) int static options (constant);
	dcl     CLEAR		 bit (36) init ("000000000000000000000000000000000000"b)
				 int static options (constant);
	dcl     RETREIVE_MODE	 fixed bin init (2) int static options (constant); /* Opening mode for mrds_dm_open */
	dcl     DONT_WAIT		 fixed bin init (0) int static options (constant); /* Don't wait on locking operations */

	dcl     mrds_data_$lock_wait_time ext fixed bin (35);

	dcl     sys_info$max_seg_size	 fixed bin ext;

          dcl     error_table_$bad_arg fixed bin(35) ext static;
	dcl     error_table_$badopt	 ext fixed bin (35);
	dcl     error_table_$inconsistent ext fixed bin (35);
	dcl     error_table_$insufficient_access ext fixed bin (35);
	dcl     error_table_$invalid_lock_reset ext fixed bin (35);
	dcl     error_table_$locked_by_this_process ext fixed bin (35);
	dcl     error_table_$lock_wait_time_exceeded fixed bin (35) ext static;
	dcl     error_table_$pathlong	 ext fixed bin (35);
	dcl     error_table_$too_many_args ext fixed bin (35);


/* Entries */


	dcl     command_query_$yes_no	 entry options (variable);
	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     mdbm_util_$inconsistent_get_info entry (ptr, bit (1), char (*), char (*), char (*));
	dcl     mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35));
	dcl     mu_de_queue_user	 entry (bit (1), bit (1), ptr, ptr, 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));
	declare mrds_error_$no_model_submodel fixed bin (35) ext; /* model or submodel */
	declare mrds_error_$no_database fixed bin (35) ext; /* model only */

	declare (mu_concurrency_control$get_control_segment, mu_concurrency_control$reset_control_segment)
				 entry (char (*), ptr, fixed bin (24), fixed bin (35)); /* gets dbc_ptr/ reset dbc structures */
	declare dbc_bit_count	 fixed bin (24);	/* unused */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* tells if user DBA */
	declare local_area		 area (1024);	/* space for various mrds structures */
	declare mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin,
				 ptr, fixed bin (35)); /* finds db version */
	declare error_table_$badcall	 fixed bin (35) ext;/* improper call */
	declare force_option	 bit (1) init ("0"b);  /* on => dont query user */

%include mdbm_dbc;

%include mdbm_users;

%include mrds_authorization;

%include mrds_path_info;


     end adjust_mrds_db;




		    copy_mrds_data.pl1              08/01/88  1408.1r w 08/01/88  1313.8      384552



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-04-19 by Thanh
     Nguyen. (see mrds #136)
  2) change(86-06-10,Blair), approve(86-08-07,MCR7491),
     audit(86-08-07,Gilcrease), install(86-08-15,MR12.0-1127):
     Set the bit dbcb.dont_check_txn_id to indicate that we will have multiple
     txns across one selection_expression (because of transaction_group_size,
     see mrds #156).
                                                   END HISTORY COMMENTS */


copy_mrds_data: cpmd: procedure ();

/*
   BEGIN_DESCRIPTION:

   This command was written to assist in converting vfile_ databases
   into DMS databases, with the least impact on existing user
   application programs.  It has, however, been generalized so that
   the input and output databases can each be either a vfile_
   database or a DM database.  To copy a database, one must first
   obtain a copy of the create_mrds_db source, using the 
   display_mrds_dm command if neccessary to obtain the needed
   information.  Using a new pathname, use create_mrds_db
   to create a new database.  You now have an "unpopulated" 
   database. To get the old data into the new database, use this
   command, giving the old database pathname first, and the old
   database pathname second.  This program will then retrieve the
   data from the old database, and store it into the new database. 

   END_DESCRIPTION


   COMMAND ARGUMENTS

   input_db_path   -  -  (input)  first argument, the pathname of the old
   database that is to be copied.  

   output_db_path   -  -  (input)  second argument, the pathname of the new
   database.  

   HISTORY:

   Originally written by Donna Woodka, 82-08-23.
   Modified 82-12-20 by PWB to remove restriction of the input having to be a
            vfile_ database and the output having to be a FAMIS database.
   Modified 83-07-20 by PWB to change the opening from exclusive update to:
            input db:  open r, permit r, prevent dms
            output db: open u, permit rs, prevent dms
            and to add -input_prevent_ops, -output_prevent_ops & 
            -transaction_group_size.
   Modified 84-10-17 by PWB in an attempt to make it work with databases that
            have been restructured in a nonstandard fashion.  If this journal
            notice remains, it worked.
*/

/* Area */

	dcl     work_area		 area (sys_info$max_seg_size) based (temp_seg_ptr); /* space for tuple data */

/* Automatic */

	dcl     arg_length		 fixed bin (21);
	dcl     arg_ptr		 ptr;
	dcl     attr_bit_length	 fixed bin (35);
	dcl     data_space_ptr_ptr	 ptr;		/* ptr to array of data space ptrs */
	dcl     error_code		 fixed bin (35);	/* error status encoding */
	dcl     finished		 bit (1);		/* set when no more tuples are to be retrieved */
	dcl     first_retrieval	 bit (1);		/* on => first tuple retrieval for a relation */
	dcl     found		 bit (1);		/* on => relation name in output model found in input model */
	dcl     i			 fixed bin;	/* index thru all relations in output model */
	dcl     input_abs_path	 char (168);	/* absolute version of input database path */
	dcl     input_converted_time	 char (24);	/* character version of date/time */
	dcl     input_db_uid	 bit (36);	/* unique id for input db dir */
	dcl     input_dbi		 fixed bin (35);	/* DB index */
	dcl     input_dm_ptr	 ptr;		/* ptr to data model */
	dcl     input_dmh_ptr	 ptr;		/* points to header info */
	dcl     input_path_len	 fixed bin (21);	/* in characters */
	dcl     input_path_ptr	 ptr;
	dcl     input_rd_ptr	 ptr;		/* pointer to relation description */
	dcl     input_rel_missing	 bit (1);		/* the specified relation is missing in the input model */
	dcl     j			 fixed bin;	/* index thru all relations in input model */
	dcl     k			 fixed bin;	/* relation index for all data moves */
	dcl     l			 fixed bin;	/* index thru all attributes in present input relation */
	dcl     m			 fixed bin;	/* index thru all attributes in present output relation */
	dcl     nargs		 fixed bin;	/* current argument count */
	dcl     n			 fixed bin;	/* general index */
	dcl     n_rels_to_be_copied	 fixed bin;	/* number of relations being copied */
	dcl     op_num		 fixed bin;	/* character position within scope string */
	dcl     output_abs_path	 char (168);	/* absolute version of input database path */
	dcl     output_converted_time	 char (24);	/* character version of date/time */
	dcl     output_db_uid	 bit (36);	/* unique id for output db dir */
	dcl     output_dbcb_ptr	 ptr;		/* ptr to dbcb for output DB */
	dcl     output_dbi		 fixed bin (35);	/* DB index */
	dcl     output_dm_ptr	 ptr;		/* ptr to data model */
	dcl     output_dmh_ptr	 ptr;		/* points to header info */
	dcl     output_path_len	 fixed bin (21);	/* in characters */
	dcl     output_path_ptr	 ptr;
	dcl     output_rd_ptr	 ptr;		/* pointer to relation description */
	dcl     rel_arg_length	 fixed bin (21);	/* length of -rel operand */
	dcl     rel_arg_ptr		 ptr;		/* ptr to -rel operand */
	dcl     retrieve_al_ptr	 ptr;		/* points to arg_list for retrieve */
	dcl     retrieve_desc_index	 fixed bin;	/* array offset of descriptor pointers in arg_list */
	dcl     retrieve_select_expr	 char (53) aligned; /* "select * from relname" */
	dcl     rtbc_ptr		 ptr;		/* ptr to relations_to_be_copied structure */
	dcl     single_relation	 bit (1);		/* copying only one relation */
	dcl     specified_input_prevents
				 fixed bin;	/* prevent ops for input relation */
	dcl     specified_output_prevents
				 fixed bin;	/* prevent ops for output relation */
	dcl     store_al_ptr	 ptr;		/* points to arg_list for store */
	dcl     store_select_expr	 char (32) aligned; /* relation name for doing mrds_dsl_store */
	dcl     temp_seg_ptr	 ptr;		/* points to temp segment */
	dcl     transaction_group_size fixed bin;	/* number of tuple to be in a transaction */
						/* if = 0, don't generate transactions */
	dcl     transaction_tuple_count
				 fixed bin;	/* running count of tuples copied */
	dcl     tuples_retrieved	 fixed bin (35);	/* number of tuples copied for a relation */

/* Based */

	dcl     arg		 char (arg_length) based (arg_ptr);
	dcl     data_space		 bit (attr_bit_length) based; /* space to allocate for attribute data */
	dcl     data_space_ptr	 (input_rd_ptr -> rel_desc.num_attr) ptr based (data_space_ptr_ptr);
	dcl     output_path		 char (output_path_len) based (output_path_ptr); /* pathname of output DB */
	dcl     input_path		 char (input_path_len) based (input_path_ptr); /* pathname of input database */
	dcl     rel_arg		 char (rel_arg_length) based (rel_arg_ptr); /* operand of -rel argument */

	dcl     1 relations_to_be_copied (n_rels_to_be_copied) based (rtbc_ptr),
		2 input_rel_num	 fixed,
		2 output_rel_num	 fixed,
		2 rel_name	 char (32);

/* Builtin */

	dcl     (addr, addrel, empty, fixed, null, substr, rel, rtrim,
	        search, verify)
				 builtin;

/* Condition */

	dcl     (any_other, cleanup, sub_error_, transaction_deadlock)
				 condition;

/* Entry */

	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cu_$generate_call	 entry (entry, ptr);
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     mrds_dm_close	 entry (ptr, fixed bin (35));
	dcl     mrds_dm_get_header	 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dm_get_attributes entry (ptr, char (32), ptr, ptr, fixed bin (35));
	dcl     mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35));
	dcl     mrds_dsl_close	 entry options (variable);
	dcl     mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_dsl_open	 entry options (variable);
	dcl     mrds_dsl_retrieve	 entry options (variable);
	dcl     mrds_dsl_set_scope$dl_scope
				 entry options (variable);
	dcl     mrds_dsl_set_scope$set_scope
				 entry options (variable);
	dcl     mrds_dsl_store	 entry options (variable);
	dcl     mu_data_class$varying	 entry (ptr) returns (bit (1) aligned);
	dcl     mu_data_length	 entry (bit (36)) returns (fixed bin (35));
	dcl     mu_database_index$get_resultant_model_pointer entry (fixed bin (35),
				 ptr);
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));

/* External */

	dcl     error_table_$bad_arg	 fixed bin (35) ext;
	dcl     error_table_$badcall	 fixed bin (35) ext static;
	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$noarg	 fixed bin (35) ext static;
	dcl     error_table_$sameseg	 fixed bin (35) ext static;
	dcl     mrds_error_$no_database fixed bin (35) ext static;
	dcl     mrds_error_$no_model_submodel fixed bin (35) ext static;
	dcl     mrds_error_$rst_wrong_command fixed bin (35) ext;
	dcl     mrds_error_$tuple_not_found fixed bin (35) ext;
	dcl     mrds_error_$undef_attr fixed bin (35) ext;
	dcl     mrds_error_$unknown_relation_name fixed bin (35) ext;
	dcl     mrds_error_$version_not_supported fixed bin (35) ext static;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext;

/* Internal Static */

	dcl     ANOTHER_RETRIEVAL_SELECT_EXPR char (8) aligned internal static options (constant)
				 init ("-another"); /* for second until EOF retrievals */
	dcl     CALLER_NAME		 char (15) internal static options (constant)
				 init ("copy_mrds_data");
	dcl     CHAR_8_DESCR	 bit (36) internal static options (constant)
				 init ("101010100000000000000000000000001000"b);
	dcl     CHAR_32_DESCR	 bit (36) internal static options (constant)
				 init ("101010100000000000000000000000100000"b);
	dcl     CHAR_53_DESCR	 bit (36) internal static options (constant)
				 init ("101010100000000000000000000000110101"b);
	dcl     FIXED_BIN_35_DESCR	 bit (36) internal static options (constant)
				 init ("100000100000000000000000000000100011"b);
	dcl     ON		 bit (1) internal static options (constant)
				 init ("1"b);
	dcl     OFF		 bit (1) internal static options (constant)
				 init ("0"b);
	dcl     PAREN_SELECT	 char (11) internal static options (constant)
				 init (") -select x");
	dcl     RANGE_PAREN		 char (10) internal static options (constant)
				 init ("-range (x ");
	dcl     RETRIEVAL_MODE	 fixed bin internal static options (constant)
				 init (2);

/* Include */

%include mdbm_arg_list;

%include mdbm_descriptor;

%include mdbm_rm_attr_info;

%include mdbm_rm_db_info;

%include mdbm_rm_domain_info;

%include mdbm_rm_rel_array;

%include mdbm_rm_rel_info;

%include mrds_dbcb;

%include mrds_path_info;

%include mrds_dm_header;

%include mrds_model_relations;

%include mrds_rel_desc;

%include mrds_new_scope_modes;

%include mrds_opening_modes_;

%include status_structures;

/* Program */


/* set up the input and output reference names, and get temp storage */

	call initialize;

	on cleanup call clean_up;			/* establish cleanup handler */

/* make sure the argument list is correct */

	call check_args;

/* check for duplicate pathnames */

	if duplicate_paths ()			/* the pathnames are the same */
	then call error (error_table_$sameseg, "");

/* begin moving the data */

	call copy_database_data ();			/* copy input data into the output database */

	call clean_up;
exit:	return;

check_args: procedure;

/* check_args is called by the main routine */

	call cu_$arg_count (nargs);
	if nargs < 2
	then call error (error_table_$noarg,
		"^/Usage: copy_mrds_data input_db_path output_db_path {-ctl_args}");

/* get the input pathname argument */

	call cu_$arg_ptr (1, input_path_ptr, input_path_len, error_code);
	if error_code ^= 0
	then call error (error_code, "Getting first argument.");

	if substr (input_path, 1, 1) = "-"
	then call error (error_table_$noarg, "^/First argument should be the input pathname.");

/* check for correct input version */

	call mrds_dsl_get_version$get_path_info (input_path, temp_seg_ptr,
	     mrds_path_info_structure_version, mrds_path_info_ptr, error_code);
	if mrds_path_info_ptr = null
	then input_abs_path = input_path;
	else input_abs_path = mrds_path_info.absolute_path;

	if error_code ^= 0
	then do;
		if error_code = mrds_error_$no_model_submodel
		then error_code = mrds_error_$no_database;

		call error (error_code, "^/" || input_abs_path);
	     end;
	if mrds_path_info.mrds_version ^= 4
	then call error (mrds_error_$version_not_supported, "/^The input database must be a version 4 database.");
	if mrds_path_info.type.submodel
	then call error (error_table_$badcall,
		"^/Data submodels are not supported by this command.  " || input_abs_path);

/* get the output pathname argument */

	call cu_$arg_ptr (2, output_path_ptr, output_path_len, error_code);
	if error_code ^= 0
	then call error (error_code, "Getting second argument.");
	if substr (output_path, 1, 1) = "-"
	then call error (error_table_$noarg,
		"^/Second argument should be the output pathname.");

	call mrds_dsl_get_version$get_path_info (output_path, temp_seg_ptr,
	     mrds_path_info_structure_version, mrds_path_info_ptr, error_code);
	if mrds_path_info_ptr = null
	then output_abs_path = output_path;
	else output_abs_path = mrds_path_info.absolute_path;

	if error_code ^= 0
	then do;
		if error_code = mrds_error_$no_model_submodel
		then error_code = mrds_error_$no_database;

		call error (error_code, "^/" || output_abs_path);
	     end;

	if mrds_path_info.type.submodel
	then do;
		call com_err_ (error_table_$badcall, CALLER_NAME,
		     "^/Data submodels are not supported by this command.  ^a", input_abs_path);
		call clean_up ();
		goto exit;
	     end;


	do n = 3 to nargs;


	     call cu_$arg_ptr (n, arg_ptr, arg_length, error_code);
	     if error_code ^= 0
	     then call error (error_code, "");
	     else if substr (arg, 1, 1) ^= "-"
	     then call error (error_table_$bad_arg, arg);
	     else if arg = "-relation" | arg = "-rel"
	     then do;
		     if n = nargs
		     then do;
			     call com_err_ (error_table_$noarg, CALLER_NAME, "Following ^a.", arg);
			     call clean_up;
			     goto exit;
			end;
		     else n = n + 1;
		     call cu_$arg_ptr (n, arg_ptr, arg_length, error_code);
		     if error_code ^= 0
		     then call error (error_code, "");
		     single_relation = "1"b;
		     rel_arg_ptr = arg_ptr;
		     rel_arg_length = arg_length;
		end;
	     else if arg = "-input_prevent_ops"
	     then do;
		     if n = nargs
		     then do;
			     call com_err_ (error_table_$noarg, CALLER_NAME, "Following ^a.", arg);
			     call clean_up;
			     goto exit;
			end;
		     else n = n + 1;
		     call cu_$arg_ptr (n, arg_ptr, arg_length, error_code);
		     if error_code ^= 0
		     then call error (error_code, "");
		     specified_input_prevents = 0;
		     if arg ^= "n" then do;		/* if non-null op. */
			     op_num = verify (arg, "aursdm");
			     if op_num ^= 0 then do;	/* invalid code */
				     call com_err_ (error_table_$bad_arg, CALLER_NAME,
					"Invalid scope code: ^a. ^/^-Valid codes are: n, r, a or s, d, m, and u = ""a+d+m""",
					substr (arg, op_num, 1));
				     call clean_up;
				     goto exit;
				end;
			     if search (arg, "r") ^= 0
			     then specified_input_prevents =
				     specified_input_prevents + READ_ATTR; /* convert to number */
			     if search (arg, "s") ^= 0 | search (arg, "a") ^= 0
			     then specified_input_prevents =
				     specified_input_prevents + APPEND_TUPLE;
			     if search (arg, "d") ^= 0
			     then specified_input_prevents =
				     specified_input_prevents + DELETE_TUPLE;
			     if search (arg, "m") ^= 0
			     then specified_input_prevents =
				     specified_input_prevents + MODIFY_ATTR;
			     if search (arg, "u") ^= 0
			     then specified_input_prevents =
				     specified_input_prevents + UPDATE_OPS;
			end;
		end;
	     else if arg = "-output_prevent_ops"
	     then do;
		     if n = nargs
		     then do;
			     call com_err_ (error_table_$noarg, CALLER_NAME, "Following ^a.", arg);
			     call clean_up;
			     goto exit;
			end;
		     else n = n + 1;
		     call cu_$arg_ptr (n, arg_ptr, arg_length, error_code);
		     if error_code ^= 0
		     then call error (error_code, "");
		     specified_output_prevents = 0;
		     if arg ^= "n" then do;		/* if non-null op. */
			     op_num = verify (arg, "aursdm");
			     if op_num ^= 0 then do;	/* invalid code */
				     call com_err_ (error_table_$bad_arg, CALLER_NAME,
					"Invalid scope code: ^a. ^/^-Valid codes are: n, r, a or s, d, m, and u = ""a+d+m""",
					substr (arg, op_num, 1));
				     call clean_up;
				     goto exit;
				end;
			     if search (arg, "r") ^= 0
			     then specified_output_prevents =
				     specified_output_prevents + READ_ATTR; /* convert to number */
			     if search (arg, "s") ^= 0 | search (arg, "a") ^= 0
			     then specified_output_prevents =
				     specified_output_prevents + APPEND_TUPLE;
			     if search (arg, "d") ^= 0
			     then specified_output_prevents =
				     specified_output_prevents + DELETE_TUPLE;
			     if search (arg, "m") ^= 0
			     then specified_output_prevents =
				     specified_output_prevents + MODIFY_ATTR;
			     if search (arg, "u") ^= 0
			     then specified_output_prevents =
				     specified_output_prevents + UPDATE_OPS;
			end;
		end;
	     else if arg = "-transaction_group_size"
	     then do;
		     if n = nargs
		     then do;
			     call com_err_ (error_table_$noarg, CALLER_NAME, "Following ^a.", arg);
			     call clean_up;
			     goto exit;
			end;
		     else n = n + 1;
		     call cu_$arg_ptr (n, arg_ptr, arg_length, error_code);
		     if error_code ^= 0
		     then call error (error_code, "");
		     if verify (arg, "1234567890") ^= 0
		     then call com_err_ (error_table_$bad_arg, "The operand to -transaction_group_size must be an integer.");
		     transaction_group_size = fixed (arg);
		end;
	     else call error (error_table_$badopt, arg);
	end;


     end check_args;

duplicate_paths: procedure returns (bit (1));

/* duplicate_paths is called by convert_database */

/* this routine check to see if the input and output input paths
   are to the same database. */

	equal = ON;
	call get_database_uid (output_abs_path, output_db_uid);
	call get_database_uid (input_abs_path, input_db_uid);
	if input_db_uid ^= output_db_uid
	then equal = OFF;

	return (equal);

	dcl     equal		 bit (1);		/* on => same path for both db's */

     end duplicate_paths;

initialize: procedure;

/* called by main routine */

/* initialize variables */

	data_space_ptr_ptr, input_dm_ptr, input_dmh_ptr, output_dm_ptr,
	     output_dmh_ptr, retrieve_al_ptr, rtbc_ptr, status_ptr,
	     store_al_ptr, temp_seg_ptr = null ();

	input_dbi, output_dbi, transaction_group_size = 0;

	single_relation = "0"b;

	specified_input_prevents, specified_output_prevents = UPDATE_OPS;

/* get the temporary storage space */

	call get_temp_segment_ (CALLER_NAME, temp_seg_ptr, error_code);
	if error_code ^= 0
	then call error (error_code, "");

	work_area = empty ();			/* init work area in temp segment */

     end initialize;

copy_database_data: procedure ();

/* copy_database_data is called by main routine */

/* copy data from a input  database, into a output database. */

	on sub_error_ ;				/* ignore subroutine error messages */

/* open the input and output databases and data models */

	call open_input_db ();
	call open_output_db ();

/* make sure we aren't copying apples to oranges */

	call compare_relations ();

/* copy the input database data into the output database,
   one relation at a time, checking for identical attribute
   makeup of the input and output relations. */

	call copy_relation_data ();

	call ioa_ ("^/Update complete, closing data models.");

     end copy_database_data;

open_input_db: procedure ();

/* open the input database and datamodel using the supplied pathname,
   and then output the header information for the datamodel */


	call mrds_dsl_open (input_abs_path, input_dbi, RETRIEVAL, error_code);
	if error_code ^= 0
	then do;
		input_dbi = 0;
		call com_err_ (error_code, CALLER_NAME, "^/^a^a^a",
		     "Unable to open """, input_abs_path, """.");
		call clean_up;
		goto exit;
	     end;
	call mrds_dm_open (input_abs_path, RETRIEVAL_MODE, input_dm_ptr, error_code);
	if error_code ^= 0
	then do;
		input_dm_ptr = null ();
		call com_err_ (error_code, CALLER_NAME, "^/^a^a^a",
		     "Unable to open data model for """, input_abs_path, """.");
		call clean_up;
		goto exit;
	     end;

/* output the header information for each version model */

	call mrds_dm_get_header (input_dm_ptr, temp_seg_ptr, input_dmh_ptr, error_code);
	if error_code ^= 0
	then call error (error_code, input_abs_path);
	call date_time_ (input_dmh_ptr -> dm_header.create_time, input_converted_time);
	call ioa_ ("^/Opening data model: ^a^/^5xCreated: ^a^/^5xVersion: ^d^/^5xBy: ^a",
	     input_abs_path, input_converted_time,
	     input_dmh_ptr -> dm_header.dmd_version, input_dmh_ptr -> dm_header.creator_id);

	if input_dmh_ptr -> dm_header.dmd_version < 4
	then call error (mrds_error_$rst_wrong_command, "The input database must be a version 4 database.");

     end open_input_db;

open_output_db: procedure ();

/* open the output database and datamodel using the supplied pathname,
   and then output the header information for the datamodel */

	call mrds_dsl_open (output_abs_path, output_dbi, UPDATE, error_code);
	if error_code ^= 0
	then do;
		output_dbi = 0;
		call com_err_ (error_code, CALLER_NAME, "^/^a^a^a",
		     "Unable to open """, output_abs_path, """.");
		call clean_up;
		goto exit;
	     end;

	call mrds_dm_open (output_abs_path, RETRIEVAL_MODE, output_dm_ptr, error_code);
	if error_code ^= 0
	then do;
		output_dm_ptr = null ();
		call com_err_ (error_code, CALLER_NAME, "^/^a^a^a",
		     "Unable to open the datamodel for """, output_abs_path, """.");
		call clean_up;
		goto exit;
	     end;

/* output the header information for each version model */

	call mrds_dm_get_header (output_dm_ptr, temp_seg_ptr, output_dmh_ptr, error_code);
	if error_code ^= 0
	then call error (error_code, output_abs_path);

	call date_time_ (output_dmh_ptr -> dm_header.create_time,
	     output_converted_time);
	call ioa_ ("^/Opening data model: ^a^/^5xCreated: ^a^/^5xVersion: ^d^/^5xBy: ^a^/",
	     output_abs_path, output_converted_time,
	     output_dmh_ptr -> dm_header.dmd_version,
	     output_dmh_ptr -> dm_header.creator_id);

     end open_output_db;

compare_relations: procedure ();

/* make sure that the input and output databases have the same relations */

	call mu_database_index$get_resultant_model_pointer (input_dbi, dbcb_ptr);
	call mu_database_index$get_resultant_model_pointer (output_dbi, output_dbcb_ptr);

/* first check that the number of relations match */

	if ^single_relation &
	     (dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.num_rels ^=
	     output_dbcb_ptr -> dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.num_rels)
	then call error (error_table_$badcall, "^/The 2 databases must have the same number of relations.");

	if single_relation
	then n_rels_to_be_copied = 1;
	else n_rels_to_be_copied = dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.num_rels;
	allocate relations_to_be_copied in (work_area);

	call match_relation_names ();			/* check for consistency */

     end compare_relations;

match_relation_names: procedure ();

/* compare the input relation list names to the output names */

	if single_relation
	then do;
		found = OFF;
		do i = 1 to dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.num_rels while (^found);
		     if dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.rel_data.model_name (i) = rel_arg
		     then do;
			     found = ON;
			     relations_to_be_copied.input_rel_num (1) = i;
			end;
		end;

		if ^found
		then do;
			error_code = mrds_error_$unknown_relation_name;
			input_rel_missing = ON;
		     end;

		else do;
			found = OFF;
			do i = 1 to output_dbcb_ptr -> dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.num_rels while (^found);
			     if output_dbcb_ptr -> dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.rel_data.model_name (i) = rel_arg
			     then do;
				     found = ON;
				     relations_to_be_copied.output_rel_num (1) = i;
				     relations_to_be_copied.rel_name (1) = rel_arg;
				end;
			end;
			if ^found
			then do;
				error_code = mrds_error_$unknown_relation_name;
				input_rel_missing = OFF;
			     end;
		     end;
		if ^found
		then do;
			call com_err_ (mrds_error_$unknown_relation_name,
			     CALLER_NAME,
			     "^/The relation ^a was specified but not found in the ^[input^;output^] model.",
			     rel_arg,
			     (input_rel_missing = ON));
			call clean_up;
			goto exit;
		     end;
	     end;
	else do;


		do i = 1 to dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.num_rels while (error_code = 0);

		     found = OFF;

		     do j = 1 to dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.num_rels while (^found & error_code = 0);

			if output_dbcb_ptr -> dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.rel_data.model_name (i) =
			     dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.rel_data.model_name (j)
			then do;
				found = ON;
				relations_to_be_copied.input_rel_num (i) = j;
				relations_to_be_copied.output_rel_num (i) = i;
				relations_to_be_copied.rel_name (i) =
				     output_dbcb_ptr ->
				     dbcb.data.rdbi_ptr ->
				     rm_db_info.data.ra_ptr ->
				     rm_rel_array.rel_data.model_name (i);
			     end;

			else if j = dbcb.data.rdbi_ptr -> rm_db_info.data.ra_ptr -> rm_rel_array.num_rels
			then error_code = mrds_error_$unknown_relation_name;
		     end;

		end;

		if error_code ^= 0
		then do;

			call com_err_ (error_code,
			     CALLER_NAME,
			     "^/^a^a^a",
			     "The relation """,
			     output_dbcb_ptr ->
			     dbcb.data.rdbi_ptr ->
			     rm_db_info.data.ra_ptr ->
			     rm_rel_array.rel_data.model_name (i - 1),
			     """ was not found in the input datamodel, but was in the output model.");
			call clean_up;
			goto exit;
		     end;
	     end;
     end match_relation_names;

copy_relation_data: procedure ();

/* for each relation in the database, this routine will go through
   one relation at a time, and copy all tuples for that relation
   from the input database into the output database. */


	do k = 1 to n_rels_to_be_copied while (error_code = 0);

/* get the input and output data model attribute
   descriptions and attribute make up for this relation */

	     call set_scope;

	     call get_relation_attributes ();

/* make sure that the attribute make up of the relations agree */

	     call compare_attributes ();

/* make an argument structure for calls to mrds_dsl_retrieve */

	     call build_retrieve_argument_list;

/* make an argument structure for calls to mrds_dsl_store */

	     call build_store_argument_list ();

/* while their are tuples left, retrieve them from the
   input database and store them into the output database */

	     call copy_tuples ();

/* free the space used for argument lists and attribute data space */

	     call free_arg_lists ();

	     call delete_scope;

	end;

     end copy_relation_data;

set_scope:
     procedure;

/* for this current relation, set scope on both input and output */

	call mrds_dsl_set_scope$set_scope (input_dbi, relations_to_be_copied.rel_name (k), READ_ATTR, specified_input_prevents, error_code);

	if error_code ^= 0
	then do;
		call com_err_ (error_code, CALLER_NAME, "^/Setting scope on relation ^a of input database.", relations_to_be_copied.rel_name (k));
		call clean_up;
		goto exit;
	     end;

	call mrds_dsl_set_scope$set_scope (output_dbi, relations_to_be_copied.rel_name (k), APPEND_TUPLE, specified_output_prevents, error_code);

	if error_code ^= 0
	then do;
		call com_err_ (error_code, CALLER_NAME, "^/Setting scope on relation ^a of output database.", relations_to_be_copied.rel_name (k));
		call clean_up;
		goto exit;
	     end;

     end set_scope;

get_relation_attributes: procedure ();

/* for this current relation, get the attribute make up
   and attribute descriptions for this relation */

	call mrds_dm_get_attributes (input_dm_ptr, relations_to_be_copied.rel_name (k),
	     temp_seg_ptr, input_rd_ptr, error_code);
	if error_code ^= 0
	then do;
		call com_err_ (error_code, CALLER_NAME, "^/^a^a^a",
		     "Getting attribute descriptions for input relation """,
		     relations_to_be_copied.rel_name (k), """.");
		call clean_up;
		goto exit;
	     end;

	call mrds_dm_get_attributes (output_dm_ptr,
	     relations_to_be_copied.rel_name (k),
	     temp_seg_ptr, output_rd_ptr, error_code);
	if error_code ^= 0
	then do;
		call com_err_ (error_code, CALLER_NAME, "^/^a^a^a",
		     "Getting attribute descriptions for output relation """,
		     relations_to_be_copied.rel_name (k), """.");
		call clean_up;
		goto exit;
	     end;

     end get_relation_attributes;

compare_attributes: procedure ();

/* make sure the attribute descriptions still match,
   first checking that attribute counts are equal, as well as key counts. */

	if input_rd_ptr -> rel_desc.num_attr ^= output_rd_ptr -> rel_desc.num_attr |
	     input_rd_ptr -> rel_desc.num_keys ^= output_rd_ptr -> rel_desc.num_keys
	then do;
		error_code = mrds_error_$rst_wrong_command;
		call com_err_ (error_code, CALLER_NAME, "^/^a^a^a",
		     "The number of attributes, or key attributes, for relation """,
		     relations_to_be_copied.rel_name (k),
		     """ are not the same in the output and input data model.");
		call clean_up;
		goto exit;
	     end;


/* go through all output attributes, making sure there is a corresponding input attribute */

	do l = 1 to output_rd_ptr -> rel_desc.num_attr while (error_code = 0);
	     found = OFF;
	     m = 1;
	     do m = 1 to input_rd_ptr -> rel_desc.num_attr while (^found & error_code = 0);

/* see if this attribute has a matching name */

		if input_rd_ptr -> rel_desc.attributes.attribute_name (m) =
		     output_rd_ptr -> rel_desc.attributes.attribute_name (l)
		then do;

			found = ON;
			if input_rd_ptr -> rel_desc.attributes.key_flag (m) ^=
			     output_rd_ptr -> rel_desc.attributes.key_flag (l) &
			     input_rd_ptr -> rel_desc.attributes.descriptor (m) ^=
			     output_rd_ptr -> rel_desc.attributes.descriptor (l)
			then do;
				call com_err_ (error_code, CALLER_NAME, "^/^a^a^a^a^a^a",
				     " The attribute """,
				     output_rd_ptr -> rel_desc.attributes.attribute_name (l),
				     """ in relation """, relations_to_be_copied.rel_name (k),
				     """ does not agree in input and output datamodels as to being either a",
				     "key attribute or its data type.");
				call clean_up;
				goto exit;
			     end;
		     end;

		else if m = input_rd_ptr -> rel_desc.num_attr /* go on to next attribute */
		then error_code = mrds_error_$undef_attr;
	     end;

/* report non-matching attribute name found, if necessary */

	     if error_code = mrds_error_$undef_attr
	     then do;
		     call com_err_ (error_code, CALLER_NAME, "^/^a^a^a^a",
			"The attribute """, output_rd_ptr -> rel_desc.attributes.attribute_name (l),
			""" is not defined in the input relation """,
			dbcb.data.rdbi_ptr ->
			rm_db_info.data.ra_ptr ->
			rm_rel_array.rel_data.model_name (k),
			""" ");
		     call clean_up;
		     goto exit;
		end;
	end;
     end compare_attributes;

build_retrieve_argument_list:
     proc ();

/* this routine builds up an argument list for a call to mrds_dsl_retrieve
   that makes it look like it was called thusly:

   call mrds_dsl_retrieve (database_index, selection_expression, 
		       value1, value1, ..., valueN, code);
*/

	retrieve_desc_index = input_rd_ptr -> rel_desc.num_attr + 3;

	num_ptrs = retrieve_desc_index * 2;

	allocate arg_list set (retrieve_al_ptr) in (work_area);

	retrieve_al_ptr -> arg_list.code = 4;

	retrieve_al_ptr -> arg_list.arg_count = num_ptrs;

	retrieve_al_ptr -> arg_list.desc_count = num_ptrs;

	retrieve_al_ptr -> arg_des_ptr (1) = addr (input_dbi);

	retrieve_al_ptr -> arg_des_ptr (1 + retrieve_desc_index) = addr (FIXED_BIN_35_DESCR);

	retrieve_select_expr = RANGE_PAREN || relations_to_be_copied.rel_name (k);

	retrieve_select_expr = rtrim (retrieve_select_expr) || PAREN_SELECT;

	retrieve_al_ptr -> arg_des_ptr (2) = addr (retrieve_select_expr);

	retrieve_al_ptr -> arg_des_ptr (2 + retrieve_desc_index) = addr (CHAR_53_DESCR);

	allocate data_space_ptr in (work_area);

	do n = 3 to retrieve_desc_index - 1;
	     attr_bit_length =
		mu_data_length (
		(dbcb.data.rdbi_ptr
		-> rm_db_info.data.ra_ptr
		-> rm_rel_array.rel_data.ri_ptr (relations_to_be_copied.input_rel_num (k))
		-> rm_rel_info.attr_ptrs (n - 2)
		-> rm_attr_info.domain_ptr
		-> rm_domain_info.user_desc));
	     allocate data_space set (data_space_ptr (n - 2)) in (work_area);

	     if mu_data_class$varying (addr
		(dbcb.data.rdbi_ptr
		-> rm_db_info.data.ra_ptr
		-> rm_rel_array.rel_data.ri_ptr (relations_to_be_copied.input_rel_num (k))
		-> rm_rel_info.attr_ptrs (n - 2)
		-> rm_attr_info.domain_ptr
		-> rm_domain_info.user_desc))
	     then retrieve_al_ptr -> arg_des_ptr (n) = addrel (data_space_ptr (n - 2), 1);
	     else retrieve_al_ptr -> arg_des_ptr (n) = data_space_ptr (n - 2);

	     retrieve_al_ptr -> arg_des_ptr (n + retrieve_desc_index) =
		addr (dbcb.data.rdbi_ptr
		-> rm_db_info.data.ra_ptr
		-> rm_rel_array.rel_data.ri_ptr (relations_to_be_copied.input_rel_num (k))
		-> rm_rel_info.attr_ptrs (n - 2)
		-> rm_attr_info.domain_ptr
		-> rm_domain_info.user_desc);		/* whew! */
	end;

	retrieve_al_ptr -> arg_des_ptr (retrieve_desc_index) = addr (error_code);
	retrieve_al_ptr -> arg_des_ptr (2 * retrieve_desc_index) = addr (FIXED_BIN_35_DESCR);
     end build_retrieve_argument_list;

build_store_argument_list: procedure ();

/* this routine builds up an argument list for a call to mrds_dsl_store
   that makes it look like it was called with the arguments
   call mrds_dsl_store(database_index, relation_expression, attribute_1, ..., attribute_n, error_code)
   for all attributes in the current relation, and with relation expression
   being the current relation name, so successive tuples my be stored. */

	allocate arg_list set (store_al_ptr) in (work_area);

	store_al_ptr -> arg_list = retrieve_al_ptr -> arg_list;

/* only the database index, and selection expression arguments differ
   between the retrieve and store argument lists */

	store_al_ptr -> arg_list.arg_des_ptr (1) = addr (output_dbi);

	store_al_ptr -> arg_list.arg_des_ptr (2) = addr (store_select_expr);

	store_al_ptr -> arg_list.arg_des_ptr (retrieve_desc_index + 2) = addr (CHAR_32_DESCR);

	store_select_expr = relations_to_be_copied.rel_name (k);

     end;

copy_tuples: procedure ();

/* this routine uses the argument lists built for the retrieve and store,
   with its use of cu_$generate_call to mrds_dsl_retrieve, and mrds_dsl_store,
   to sucessively retrieve tuples from the input datbase, and store them into 
   the output database, until all tuples for this relation have been copied. */

	tuples_retrieved, mftxn_code = 0;
	first_retrieval = ON;
	finished = OFF;
	transaction_tuple_count = transaction_group_size;
	if transaction_group_size ^= 0		/* user wants us to handle transactions */
	then do;
	          dbcb.data.dont_check_txn_id = "1"b;
		if dbcb.data.transactions_needed	/* see if input db is protected */
		then mstxn_transactions_needed = "1"b;
		else do;				/* if not, check output db */
			call mu_database_index$get_resultant_model_pointer (output_dbi, output_dbcb_ptr);
			mstxn_transactions_needed = output_dbcb_ptr -> dbcb.data.transactions_needed;
		     end;
	     end;

retrieve_tuple:
	if transaction_group_size = 0
	then goto dont_start_the_transaction;
	if transaction_tuple_count < transaction_group_size
	then goto dont_start_the_transaction;
	transaction_tuple_count = 0;
	mstxn_txn_id = "0"b;
	on any_other call mstxn_any_other;
	on cleanup begin;
		call mstxn_cleanup;
		call clean_up;
	     end;
	on transaction_deadlock begin;
		mftxn_code = dm_error_$lock_deadlock;
		mstxn_retries = 100;		/* fake the include file into not retrying */
		goto mftxn_check_code;
	     end;

%include mrds_start_transaction;

	if mstxn_code ^= 0
	then call error (mstxn_code, "Unable to start a transaction.");

	dbcb.user_started_transaction = user_started_transaction;

dont_start_the_transaction:
	call cu_$generate_call (mrds_dsl_retrieve, retrieve_al_ptr);
	if error_code ^= 0
	then finished = ON;
	else do;
		tuples_retrieved = tuples_retrieved + 1;
		transaction_tuple_count = transaction_tuple_count + 1;
		call cu_$generate_call (mrds_dsl_store, store_al_ptr);
		if error_code ^= 0
		then finished = ON;
		if first_retrieval & ^finished
		then do;
			first_retrieval = OFF;
			retrieve_al_ptr -> arg_list.arg_des_ptr (2) = addr (ANOTHER_RETRIEVAL_SELECT_EXPR);
			retrieve_al_ptr -> arg_list.arg_des_ptr (retrieve_desc_index + 2) = addr (CHAR_8_DESCR);
		     end;
	     end;
	if error_code = mrds_error_$tuple_not_found
	then do;
		error_code = 0;
		call ioa_ ("Copied ^4d tuples from relation ^a.",
		     tuples_retrieved, relations_to_be_copied.rel_name (k));
	     end;

	if transaction_group_size = 0
	then goto dont_finish_the_transaction;
	if transaction_tuple_count < transaction_group_size & ^finished
	then goto dont_finish_the_transaction;
	mftxn_code = error_code;

%include mrds_finish_transaction;

	revert any_other;
	revert transaction_deadlock;
	on cleanup call clean_up;
dont_finish_the_transaction:
	if error_code ^= 0
	then call error (error_code, "");
	if mftxn_code ^= 0
	then call error (mftxn_code, "");
	if ^finished
	then goto retrieve_tuple;
should_rollback:
     procedure returns (bit (1));
	return ("0"b);
     end should_rollback;
restore_significant_data:
     procedure;
     end restore_significant_data;

     end copy_tuples;

free_arg_lists: procedure ();

/* this routine frees the existing argument lists, and data space for attributes,
   so that the same space can be reused for each relation */


	if store_al_ptr ^= null
	then free store_al_ptr -> arg_list in (work_area);

	if retrieve_al_ptr ^= null
	then free retrieve_al_ptr -> arg_list in (work_area);

	if data_space_ptr_ptr ^= null
	then do;
		do n = 1 to input_rd_ptr -> rel_desc.num_attr;
		     if data_space_ptr (n) ^= null
		     then free data_space_ptr (n) -> data_space;
		end;
		free data_space_ptr;
	     end;




     end free_arg_lists;

delete_scope:
     procedure;

/* for this current relation, delete scope on both input and output */

	call mrds_dsl_set_scope$dl_scope (input_dbi, relations_to_be_copied.rel_name (k), READ_ATTR, specified_input_prevents, error_code);

	if error_code ^= 0
	then do;
		call com_err_ (error_code, CALLER_NAME, "^/Deleting scope on relation ^a of input database.", relations_to_be_copied.rel_name (k));
		call clean_up;
		goto exit;
	     end;

	call mrds_dsl_set_scope$dl_scope (output_dbi, relations_to_be_copied.rel_name (k), APPEND_TUPLE, specified_output_prevents, error_code);

	if error_code ^= 0
	then do;
		call com_err_ (error_code, CALLER_NAME, "^/Deleting scope on relation ^a of output database.", relations_to_be_copied.rel_name (k));
		call clean_up;
		goto exit;
	     end;
     end;

get_database_uid: procedure (path, db_uid);

/* this routine turns a path into a pointer for comparison purposes */

	call expand_pathname_ (path, dir, entry, error_code);
	if error_code ^= 0
	then call error (error_code, path);

	allocate status_branch set (status_ptr) in (work_area); /* get space for answer */

	call hcs_$status_long (dir, entry, 1, status_ptr, temp_seg_ptr, error_code);

	if error_code ^= 0
	then do;
		free status_ptr -> status_branch in (work_area);
		call error (error_code, path);
	     end;

	db_uid = status_ptr -> status_branch.uid;

	free status_ptr -> status_branch in (work_area);

	declare path		 char (168);	/* absolute path input */
	declare dir		 char (168);	/* direcotry portion */
	declare entry		 char (32);	/* entry portion */
	declare db_uid		 bit (36);	/* unique id of directory given by input path */

     end get_database_uid;

error: procedure (err_code, err_message);

	dcl     err_code		 fixed bin (35);
	dcl     err_message		 char (*);
	dcl     saved_code		 fixed bin (35);

	saved_code = err_code;
	call com_err_ (saved_code, CALLER_NAME, err_message);
	call clean_up;
	go to exit;

     end error;

clean_up: procedure ();

/* get rid of temporary storage, and close any open databases or datamodels */

	if status_ptr ^= null
	then free status_ptr -> status_branch;

	if rtbc_ptr ^= null
	then free relations_to_be_copied;

	call free_arg_lists;
	dbcb.data.dont_check_txn_id = "0"b;
	
	if input_dbi ^= 0
	then do;
		call mrds_dsl_close (input_dbi, error_code);
		if error_code ^= 0
		then call com_err_ (error_code, CALLER_NAME, "^/^a ^d ^a",
			"Unable to close the input database using index", input_dbi, ".");
		input_dbi = 0;
	     end;

	if output_dbi ^= 0
	then do;
		call mrds_dsl_close (output_dbi, error_code);
		if error_code ^= 0
		then call com_err_ (error_code, CALLER_NAME, "^/^a ^d ^a",
			"Unable to close the output database using index", output_dbi, ".");
		output_dbi = 0;
	     end;

	if input_dm_ptr ^= null ()
	then do;
		call mrds_dm_close (input_dm_ptr, error_code);
		if error_code ^= 0
		then call com_err_ (error_code, CALLER_NAME, "^/Unable to close the input datamodel.");
		input_dm_ptr = null ();
	     end;

	if output_dm_ptr ^= null ()
	then do;
		call mrds_dm_close (output_dm_ptr, error_code);
		if error_code ^= 0
		then call com_err_ (error_code, CALLER_NAME, "^/Unable to close the output datamodel.");
		output_dm_ptr = null ();
	     end;

	if temp_seg_ptr ^= null ()
	then do;
		call release_temp_segment_ (CALLER_NAME, temp_seg_ptr, error_code);
		if error_code ^= 0
		then call com_err_ (error_code, CALLER_NAME);
		temp_seg_ptr = null ();
	     end;

     end clean_up;

     end copy_mrds_data;




		    create_mrds_dm_include.pl1      03/25/87  0950.6rew 03/25/87  0948.9      426393



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



/****^  HISTORY COMMENTS:
  1) change(85-11-21,Dupuis), approve(86-08-05,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     Provided a fix for phx19078 (mrds #150). PL/I doesn't accept
     hyphens in names, but MRDS, COBOL, and other things do. Changed
     the code to translate hyphens to underscores when generating a
     PL/I include.
  2) change(86-11-21,Blair), approve(87-02-05,MCR7593),
     audit(87-03-24,Gilcrease), install(87-03-25,MR12.1-1012):
     Implement SCP6238 to allow creation of include files and tables for single
     relations or a list of relations, and to name the output_files with a
     control argument.
                                                   END HISTORY COMMENTS */


create_mrds_dm_include: cmdmi: proc;

/* DESCRIPTION:

   *** create_mrds_dm_include (cmdmi) This entry creates an  include
   file  from  a MRDS data base model. The file is named "<data base
   model  entry  name>.incl.pl1".  The  include  file   contains   a
   structure for each relation with the attributes for each relation
   declared as second level members of the structure.

   *** create_mrds_dm_table (cmdmt)  This  entry  creates  a  sement
   displaying  the  relations  in  a  data  base  model suitable for
   printing on a line printer. The display for each  relation  is  a
   series  of  rectangular  boxes,  each  containing  the name of an
   attribute. If the attribute is a primary key, a  "*"  appears  in
   the  upper  left corner. If the attribute is a secondary index, a
   "O" will appear in the upper right corner.
*/

/* HISTORY:

   created 78 September by Art Beattie

   Modified   by   Jim   Gray   -   -   Dec.   1979,    to    change
   mrds_cmdb_alpha_desc  to  mu_display_descriptor,  so that
   the new data types could be handled.

   Modified by Jim Gray - - Jan.  1980,  to  put  descriptor  abbrev
   function  in mu_trim_descriptor, to handle new descriptor
   lengths

   Modified by Jim Gray - - Jan. 1980, to  handle  ".db"  suffix  on
   databases

   Modified by Jim Gray - - April 1980, to work with submodels.

   Modified by Jim - - 80-9-23,  to  work  with  databases/submodels
   that have a -decode_dcl user view of the data declared. The entry
   $set_user_view in mrds_dm_get_attributes returns  the  user  view
   instead of the db view in the descriptor, if they differ.

   80-12-12 Jim Gray : Changed to use actual  entry  name  given  in
   users  link  or  addname,  rather  than  surprising  him  with  a
   different name on the database for his include or  table  segment
   name. Changed the header path to be the actual database path.

   80-12-19 Jim Gray :  added  -based  control  argument  to  CMDMI.
   changed version number from 2.0 to 3.0.

   80-12-30 Jim Gray : added force  iox_$close/detach  in  clean  up
   handler, for cases where error occurs, and this has not been done
   yet.

   81-1-6 Jim Gray : changed usage message  so  valid  control  args
   shown for cmdmi and cmdmt.

   81-01-28 Davids: removed mrds_dsm_display_rels.incl.pl1 which was
   not  being used. The code uses the model_relation structure which
   has the same format as the dsm_display_rels structure. Since  the
   format  of  the structures is fixed because of user documentation
   it does not matter which structure is used.

   81-01-31      Jim      Gray      :       added       use       of
   mrds_dsl_get_version$get_path_info        in       place       of
   dsl_$get_db_version, to take advantage of the improved interface.

   81-02-10 Jim Gray : added  check  for  a  peon  using  a  secured
   submodel once the database has become secured.

   81-02-11 Jim Gray : changed name of dsmd_, to  mrds_dsm_dsmd,  so
   that  the  internal,  not  extenral name in the bound segment was
   called.

   81-04-27  Jim  Gray  :  added  -long|-lg  and  -no_based  control
   arguments.  Also  made  a  non-DBA looking at secured db see only
   indexed flag, no key flags.

   81-06-05 Davids: removed references to the external user submodel
   interface  and  replaced  them  with  references to internal mrds
   interfaces (this includes both include files and  modules).  Also
   removed  declared  but  never referenced variables. Changed error
   messages to use the actual name of the  mrds_dsm_*  module  being
   called rather than the dsmd_* name that used to be called. Solved
   the  problem  of  mrds_dsm_relation_names  being  overlayed  with
   model_relations  by  allocating  a  model_relations structure and
   copying   the   contents   of    mrds_dsm_relations_names    into
   model_relations.  If any submodel relation name is longer than 32
   characters  (not  currently  possible)  it  will  not  be  copied
   correctly.

   81-10-21 Davids: Corrected the handling of add names and links so
   that  the name of the created segment depends of the name used in
   the command line and not the actual name of the database or  data
   submodel.

   83-01-10  Roger Lackey : Changed out_dir to always be working dir.

   83-01-18  Roger Lackey : added mrds_error_$no_model_submodel to handle
   the case where mrds_dsl_get_version$get_path_info
   returns mrds_error_$no_database.  Also declared undeclared variables.

   83-07-12  Roger Lackey: Changed call to tssi_$finish_segment to put
		       rw access on output segment for caller.

   84-02-15 Mike Kubicar: Fixed tr phx16539.  When displaying a submodel,
   cmdmi (and cmdmt) would always use the domains of the model in attribute
   order, no matter what the order of the attributes in the submodel was.
   The result was that attributes in a submodel would have have the wrong
   domains associated with them.

*/

/* Identify entry point used. */
	prog_name = "create_mrds_dm_include";
	creating_incl = ON;
	line_len = 110;
	go to COMMON;

create_mrds_dm_table: cmdmt: entry;
	prog_name = "create_mrds_dm_table";
	creating_incl = no;
	line_len = 136;
						/* Common code for all entries. */
COMMON:
						/* Initialize variables. */
	attr_desc_ptr = null;
	based_decls = OFF;
	brief_table = no;
	dm_path = "";
	dm_ptr = null;
	dmh_ptr = null;
	expect = 0;
	legend_len = 38;
	have_of = no;
	have_relation = no;
	mr_order_ptr = null;
	mr_ptr = null;
	ordering = no;
	order_begin, order_end = 0;
	out_ptr, out_acl_ptr = null;
	page_len = 59;
	rd_ptr = null;
	submodel = OFF;
	str_ptr = null ();
	hd_ptr = null ();
	new_rd_ptr = null ();
						/* Obtain number of arguments in this call. */
	call cu_$arg_count (nargs);
	if nargs < 1 then do;
		code = error_table_$wrong_no_of_args;
		if creating_incl then
		     options = "-based, -no_based, -order, -output_file, -page_length and/or -relation";
		else options = "-brief, -long, -line_length, -order, -output-file, -page_length and/or -relation";
		call ioa_$rsnnl (
		     "^/Usage is: ^a dm_path {-control_args}^/where control_args can be  ^a",
		     er_mess, 0, prog_name, options);
		go to ERROR;
	     end;
						/* The first argument is the pathname of the data base. */
	call cu_$arg_ptr (1, arg_ptr, arg_len, 0);

/* BEGIN CHANGE 81-01-31 ************************************************** */

	path_argument = arg;
	call mrds_dsl_get_version$get_path_info ((arg), addr (local_area),
	     mrds_path_info_structure_version, mrds_path_info_ptr,
	     code);				/* get full path, with .db suffix if needed */
	if mrds_path_info_ptr = null () then
	     dm_path = arg;
	else do;
		dm_path = mrds_path_info.absolute_path;
		db_version = mrds_path_info.mrds_version;
	     end;
	if code ^= 0 then do;
		if code = mrds_error_$no_database then
		     code = mrds_error_$no_model_submodel;

		call ioa_$rsnnl ("^/No database found using the data model path ""^a"".",
		     er_mess, 0, dm_path);
		goto ERROR;
	     end;

	if mrds_path_info.type.submodel then
	     submodel = ON;

/* END CHANGE 81-01-31 ********************************************** */

/* Scan the arguments which are not position sensitive. */
	do iarg = 2 to nargs;
	     call cu_$arg_ptr (iarg, arg_ptr, arg_len, 0);
RECHECK_ARG:
	     if expect = 0 then do;
						/* Next argument doesn't follow a previously processed control */
						/*   argument. */
		     if arg = "-relation" | arg = "-rel" then
			     expect = rel_name_arg;
		     else if arg = "-of" | arg = "-output_file" then
			     expect = output_file_arg;
		     else if arg = "-brief" | arg = "-bf" | arg = "-long" | arg = "-lg" then do;
			     if arg = "-brief" | arg = "-bf" then
				brief_table = ON;
			     if creating_incl then call ioa_ ("^a: The ^a control argument is ignored by this command.",
				     prog_name, arg);
			end;
		     else if arg = "-line_length" then go to HAVE_LL_CTL;
		     else if arg = "-ll" then do;

HAVE_LL_CTL:
			     if creating_incl then do;
				     call ioa_ ("^a: The ^a control argument is ignored by this command.", prog_name, arg);
				     iarg = iarg + 1;
				end;
			     else expect = ll_arg;
			end;
		     else if arg = "-page_length" then expect = pl_arg;
		     else if arg = "-pl" then expect = pl_arg;
		     else if arg = "-order" then do;
			     expect = order_arg;
			     ordering = ON;
			     order_begin = 0;
			end;
		     else if arg = "-based" | arg = "-no_based" then do;
			     if arg = "-based" then
				based_decls = ON;
			     if ^creating_incl then do;
				     call ioa_$rsnnl ("^/The ""-based"" control argument is ignored by this command.", er_mess, 0);
				     code = error_table_$badopt;
				     goto ERROR;
				end;
			end;
		     else if substr (arg, 1, 1) = "-" then do;
			     call ioa_$rsnnl ("^/Unrecognized control argument, ^a", er_mess, 0, arg);
			     code = error_table_$badopt;
			     go to ERROR;
			end;
		     else do;			/* Pathname already given.  Might be an error. */
			     call ioa_$rsnnl ("^/Bad syntax in this call at the argument, ^a", er_mess, 0, arg);
			     code = error_table_$badopt;
			     go to ERROR;
			end;
		     control_arg = arg;
		end;				/* Ends do if not expecting. */


	     else do;				/* Current arg occurs after control arg requiring one. */
		     if expect = output_file_arg then do;
			out_entry_name = arg;
			have_of = ON;
			expect = 0;
			end;
		     if expect = ll_arg then do;
						/* Expecting argument after -line_length control argument. */
			     on conversion call conv_error ();
			     line_len = convert (line_len, arg);
			     revert conversion;
			     if (^creating_incl & line_len < 64) | (creating_incl & line_len < 100) | line_len > 136 then do;
				     call ioa_$rsnnl ("^/Value of line length argument is out of the range, 63<ll<137; ^d",
					er_mess, 0, line_len);
				     code = error_table_$bad_arg;
				     go to ERROR;
				end;
			     expect = 0;
			end;			/* Ends do if expect = ll_arg. */

		     if expect = pl_arg then do;
						/* Expecting argument after -page_length control argument. */
			     on conversion call conv_error ();
			     page_len = convert (page_len, arg);
			     revert conversion;
			     if (page_len ^= 0 & page_len < 30) | page_len > 127 then do;
				     call ioa_$rsnnl ("^/^a ^d", er_mess, 0,
					"Value of page length argument can be 0 or in the range 29<pl<128. Value received was",
					page_len);
				     code = error_table_$bad_arg;
				     go to ERROR;
				end;
			     expect = 0;
			end;			/* Ends do if expect = pl_arg. */

		     if expect = order_arg | expect = rel_name_arg then do;
						/* Expecting relation names after -order control argument. */
			     if expect = rel_name_arg then have_relation = ON;
			     if order_begin = 0 then order_begin = iarg; /* Remember where first name is. */
			     if substr (arg, 1, 1) = "-" then do;
						/* Encountered a control argument. (Relation names */
						/*   cannot start with a "-" character. */
				     order_end = iarg - 1; /* Last argument was last order name, remember its position. */
				     expect = 0;
				     if order_begin > order_end then go to MISSING_VALUE;
				     go to RECHECK_ARG;
				end;
			     if iarg = nargs then do; /* Since this is the last argument, remember its position. */
				     order_end = iarg;
				     expect = 0;
				end;
			end;			/* Ends do if expect = order_arg. */
		end;				/* Ends do if expecting. */
	end;					/* Ends do for iarg loop. */
						/* Check for overall syntaxical errors. */
	if expect ^= 0 then do;

MISSING_VALUE:
		code = error_table_$noarg;
		call ioa_$rsnnl ("^/Required value for ^a control argument is missing.", er_mess, 0, control_arg);
		go to ERROR;
	     end;
	if ordering then
	     if have_relation then do;
		code = error_table_$inconsistent;
		call ioa_$rsnnl ("^/Inconsistent combination of arguments, -relation and -order.", er_mess, 0);
		go to ERROR;
		end;
	     else if order_begin = 0 then do;		/* No names were supplied after -order argument. */
		     control_arg = "-order";
		     go to MISSING_VALUE;
		end;

	call expand_pathname_ (dm_path, dm_dir, dm_entry_name, code);
	if code ^= 0 then do;
		call ioa_$rsnnl ("^/Error occured in expanding pathname for, ^a",
		     er_mess, 0, dm_path);
		go to ERROR;
	     end;

/* Prefer to have actual pathname of data model. */
	call hcs_$get_link_target (dm_dir, dm_entry_name, dm_adir, dm_aentry_name, code);
	if code ^= 0 then do;
		call ioa_$rsnnl ("^/Error occured in obtaining link target for , ^a>^a",
		     er_mess, 0, dm_dir, dm_entry_name);
		go to ERROR;
	     end;
						/* This is mostly for error messages. */
	dm_abs_path = rtrim (dm_adir) || ">" || dm_aentry_name;
						/* Create proper suffix for output file name. */
	if creating_incl then suffix = "incl.pl1";
	else suffix = "table";
	if submodel then
	     entry_suffix = "dsm";
	else entry_suffix = "db";

/* CHANGE: use entry name given, not actual database name */

	if ^have_of then do;
	     call expand_pathname_ (path_argument, out_dir, out_entry_name, code);
	     if code ^= 0 then do;
		call ioa_$rsnnl ("^/Tried to expand pathname, ^a.^a, in working directory.",
		     er_mess, 0, dm_entry_name, suffix);
		go to ERROR;
		end;
	     end;
	
	out_dir = get_wdir_ ();			/* Always put output in working_dir */

	call suffixed_name_$new_suffix ((out_entry_name), (entry_suffix), suffix, out_entry_name, code);
	if code ^= 0 then do;
		call ioa_$rsnnl ("^/Tried to change suffix on ^a.^a, in working directory.",
		     er_mess, 0, dm_entry_name, suffix);
		go to ERROR;
	     end;

/* Need some working storage. */
	dm_area_ptr = get_system_free_area_ ();
						/* Open the data model for reading only. */
	if submodel then do;
		sm_abs_path = dm_abs_path;
		call mrds_dsm_open$read (dm_path, submodel_iocb_ptr, code);
		if code ^= 0 then do;
			call ioa_$rsnnl ("^/Unable to open the submodel, ^a",
			     er_mess, 0, dm_path);
			goto ERROR;
		     end;

		call mrds_dsm_read_header (dm_area_ptr, hd_ptr, submodel_iocb_ptr, code);
		if hd_ptr = null () | code ^= 0 then do;
			call ioa_$rsnnl ("^/Unable to get header info from mrds_dsm_read_header for submodel, ^a",
			     er_mess, 0, dm_abs_path);
			goto ERROR;
		     end;

/* make a phony dm_header, with submodel info in it */

		allocate dm_header set (dmh_ptr) in (dm_area);

		dmh_ptr -> dm_header.dm_header_id = "SUBMODEL";
		dmh_ptr -> dm_header.dmd_version = hd_ptr -> mrds_dsm_header.dsm_generator_version;
		dmh_ptr -> dm_header.creator_id = hd_ptr -> mrds_dsm_header.creator_id;
		dmh_ptr -> dm_header.create_time = hd_ptr -> mrds_dsm_header.date_time_generated;

	     end;

	if submodel then
	     model_path = hd_ptr -> mrds_dsm_header.database_pn;
	else model_path = dm_abs_path;		/* CHANGE: use actual not given path in header */

	call mrds_dm_open ((model_path), retrieval, dm_ptr, code);
	if dm_ptr = null | code ^= 0 then do;
		call ioa_$rsnnl ("^/Received a null pointer from dmd_$open_dm for data model, ^a",
		     er_mess, 0, model_path);
		go to ERROR;
	     end;
	on cleanup call clean_up ();			/* Got to start thinking about cleaning this up if anything */
						/*   goes wrong. */

/* Get header information from data model for title block. */
	if ^submodel then do;
		call mrds_dm_get_header (dm_ptr, dm_area_ptr, dmh_ptr, code);
		if dmh_ptr = null () | code ^= 0 then do;
			call ioa_$rsnnl ("^/Unable to get header info from dmd_$get_header for data model, ^a",
			     er_mess, 0, model_path);
			goto ERROR;
		     end;

	     end;
	call date_time_ (create_time, time_str);
						/* Want to put current time into title block. */
	call date_time_ ((clock_ ()), current_date_time);
						/* Setup basic title block. */

/* BEGIN CHANGE 81-02-10 ********************************************** */
/* 	check to see if the database is secured */

	secured_view = OFF;
	if dmd_version >= 4 then do;

		call mrds_dm_db_secured$get_secured_status (dm_ptr, addr (local_area),
		     database_state_structure_version, database_state_ptr, code);
		if code ^= 0 then do;
			call ioa_$rsnnl ("^/Unable to get secured state of database ^a",
			     er_mess, 0, model_path);
			goto ERROR;
		     end;

		if database_state.secured then do;

/* check for correct authorization and usage,
   a DBA can do anything, a peon must be using a secure submodel */

			call mrds_dm_authorization$get_user_class (model_path, addr (local_area),
			     mrds_authorization_structure_version, mrds_authorization_ptr, code);
			if code ^= 0 then do;
				call ioa_$rsnnl ("^/Unable to get user class for database ^a",
				     er_mess, 0, model_path);
				goto ERROR;
			     end;

			if mrds_authorization.administrator then ; /* user is a DBA */
			else do;

/* must check that peon is using a secure submodel */

				secured_view = ON;
				secure_submodel = OFF;
				if ^submodel then ;
				else if mrds_dm_secured_submodel (
				     rtrim (model_path), rtrim (dm_adir), rtrim (dm_aentry_name)) then
				     secure_submodel = ON;

				if ^secure_submodel then do;
					if submodel then
					     call ioa_$rsnnl ("^/^a^a^a^a^a ^a^a^a", er_mess, 0,
						"The submodel """, sm_abs_path, """ refers to a database """,
						model_path, """ that has been secured,",
						"but the submodel itself is not in the databases inferior directory """,
						mrds_data_$submodel_dir_name, """.");
					else call ioa_$rsnnl ("^/^a^a^a ^a", er_mess, 0,
						"The database """, model_path, """ has been secured,",
						"but the caller is not a DBA, and must use a submodel to reference it.");
					code = mrds_error_$inc_secure_open;
					goto ERROR;
				     end;

			     end;

		     end;

	     end;

/* END CHANGE 81-02-10 ***************************************************** */

/* set up output header */

	lines_left = page_len;
	buf = "";

	if submodel then
	     model_type = " Sub";
	else model_type = "Data";

	call ioa_$rsnnl ("^3x* BEGIN ^a", buf (3), 0, out_entry_name);
	call ioa_$rsnnl ("^3x*^6xcreated: ^a", buf (4), 0, current_date_time);
	call ioa_$rsnnl ("^3x*^11xby: ^a (^a)", buf (5), 0, prog_name, version);

/* CHANGE: using actual path of model in header, rather than path given */

	if submodel then
	     call ioa_$rsnnl ("^3x* ^a model ^a", buf (7), 0, model_type, sm_abs_path);
	else call ioa_$rsnnl ("^3x* ^a model ^a", buf (7), 0, model_type, model_path);
	call ioa_$rsnnl ("^3x*^6xcreated: ^a", buf (8), 0, time_str);
	call ioa_$rsnnl ("^3x*^6xversion: ^d", buf (9), 0, dmd_version);
	call ioa_$rsnnl ("^3x*^11xby: ^a", buf (10), 0, dm_header.creator_id);
						/* Determine longest line in title block to find out where */
						/*   right side of box is. */
	max_buf_len = length (buf (3));
	do i = 4 to 10;
	     max_buf_len = max (max_buf_len, length (buf (i)));
	end;
						/* Put right side of title block in. */
	do i = 3 to 10;
	     buf (i) = buf (i) || copy (" ", max_buf_len + 1 - length (buf (i))) || "*";
	end;
						/* Now for the top side of title block. */
	er_mess = copy ("*", max_buf_len - 1);
	call ioa_$rsnnl ("/* ^a", buf (1), 0, er_mess);
						/* Finially, the bottom side. */
	call ioa_$rsnnl ("^3x*^vx*", buf (2), 0, max_buf_len - 3);
	call ioa_$rsnnl ("^3x^a */", buf (12), 0, er_mess);
						/* Put some blank separator lines in title block for */
						/* appearances. */
	buf (6), buf (11) = buf (2);
						/* Ready to access output segment, so lets try to get it. */

	call tssi_$get_segment (out_dir, out_entry_name, out_ptr, out_acl_ptr, code);
	if out_ptr = null then do;
		call ioa_$rsnnl ("^/Received a null pointer to segment, ^a>^a",
		     er_mess, 0, out_dir, out_entry_name);
		go to ERROR;
	     end;
						/* Attach an output stream to output segment. */
	out_atd = "vfile_ " || rtrim (out_dir) || ">" || rtrim (out_entry_name);
	call iox_$attach_name ((unique_chars_ (no)), out_iocb_ptr, (out_atd), null, code);
	if code ^= 0 then do;
		call ioa_$rsnnl ("^/Attaching switch to ^a,>^a", er_mess, 0, out_dir, out_entry_name);
		go to ERROR;
	     end;
	call iox_$open (out_iocb_ptr, stream_out, "0"b, code);
	if code ^= 0 then do;
		call ioa_$rsnnl ("^/Opening switch to ^a>^a", er_mess, 0, out_dir, out_entry_name);
		go to ERROR;
	     end;
						/* Output the title block. */
						/*   If creating a table, put legend along side of title block, */
						/*   otherwise below it. */
	if creating_incl then call output_buffer (0, 12);
	else do;
		below_sw = no;
		if legend_len + max_buf_len + 2 > line_len then do;
						/* Put legend below title box. */
			call output_buffer (0, 12);
			below_sw = ON;
			buf = "";
		     end;
						/* Construct the legend. */
		buf (2) = buf (2) || " L_E_G_E_N_D_:";
		buf (3) = buf (3) || copy (" ", 11) || copy ("_", 15) || "/  /_" || copy ("_", 8);
		buf (4) = buf (4) || copy (" ", 11) || "|*" || copy (" ", 9) || "I| /  /  |     |";
		buf (5) = buf (5) || "  relation | Attribute |       |     |";
		i = 0;
		if ^brief_table then do;
			buf (6) = buf (6) || copy (" ", 11) || "| Data Type |       |     |";
			i = 1;
		     end;
		buf (6 + i) = buf (6 + i) || copy (" ", 11) || "_|" || copy ("_", 11) || "_|__/  /___|______|";
		buf (7 + i) = buf (7 + i) || copy (" ", 25) || "/  /";
		buf (8 + i) = buf (8 + i) || copy (" ", 11) || "* = Key Attribute";
		buf (9 + i) = buf (9 + i) || copy (" ", 11) || "I = Index Attribute";
		if below_sw then call output_buffer (0, 9 + i);
		else call output_buffer (0, 12);
	     end;					/* Ends do if generating display table. */
						/* Get all the relation names. */

/* get the relations in this view */

	if ^submodel then do;
		call mrds_dm_get_relations (dm_ptr, dm_area_ptr, mr_ptr, code);
		if mr_ptr = null | code ^= 0 then do;
			call ioa_$rsnnl ("^/Received null pointer from dmd_$get_relations for data model, ^a",
			     er_mess, 0, model_path);
			go to ERROR;
		     end;
	     end;

	else do;					/* for submodels */

		call mrds_dsm_get_relation_names (dm_area_ptr, mrds_dsm_relation_names_ptr, submodel_iocb_ptr, code);
		if mrds_dsm_relation_names_ptr = null () | code ^= 0 then do;
			call ioa_$rsnnl ("^/Unable to get relation names from mrds_dsm_get_relation_names for submodel, ^a",
			     er_mess, 0, model_path);
			goto ERROR;
		     end;
		num_relations_alloc = mrds_dsm_relation_names.nrels;
		allocate model_relations in (dm_area) set (mr_ptr);
		do i = 1 to num_relations_alloc;
		     model_relations.relation_name (i) = mrds_dsm_relation_names.relation (i);
		end;
		free mrds_dsm_relation_names_ptr -> mrds_dsm_relation_names in (dm_area);
	     end;

	if ordering  | have_relation then do;			/* Special ordering has been requested. */
		num_relations_alloc, nrelations = model_relations.nrels;
		norder = order_end - order_begin + 1;
		if model_relations.nrels < norder then do; /* Can't order something that isn't there. */
			code = error_table_$badcall;
			call ioa_$rsnnl ("^/^a model has fewer relations (^d) than order list (^d).",
			     er_mess, 0, model_type, model_relations.nrels, norder);
			go to ERROR;
		     end;
						/* Set up some wroking storage to order the names in. */
		allocate model_relations in (dm_area) set (mr_order_ptr);
		if have_relation then mr_order_ptr -> model_relations.nrels = norder;
						/* Go over the argument list to put the names into the new */
						/*   storage. */
		i = 0;
		do iarg = order_begin to order_end;
		     call cu_$arg_ptr (iarg, arg_ptr, arg_len, 0);
		     i = i + 1;
		     mr_order_ptr -> relation_name (i) = arg;
		end;
		do i = 1 to norder;			/* For each name in the ordered list, find it in */
		     do j = 1 to model_relations.nrels; /*   the data model list and zip it out. */
			if mr_order_ptr -> relation_name (i) = relation_name (j) then do;
				relation_name (j) = "";
				go to NEXT_ORDER;
			     end;
		     end;				/* Ends do for model_relations.nrels loop. */
		     call ioa_$rsnnl ("^/Order list entry, ""^a"", wasn't found in model, ^a.",
			er_mess, 0, mr_order_ptr -> relation_name (i), model_path);
		     code = error_table_$bad_arg;
		     go to ERROR;

NEXT_ORDER:
		end;				/* Ends do for norder loop. */
						/* Now copy those names that weren't zipped out. */
	          if ordering then do;
		     j = norder;
		     do i = 1 to model_relations.nrels;
			if relation_name (i) ^= " " then do;
			     j = j + 1;
			     mr_order_ptr -> relation_name (j) = relation_name (i);
			     end;
			end;				/* Ends do for model_relations.nrels loop. */
	          end;
		free model_relations in (dm_area);	/* All done with original structure. */
		mr_ptr = mr_order_ptr;		/* Setup reference to new sturcture as if it was the old one. */
		mr_order_ptr = null;
	     end;					/* Ends do if ordering. */
						/* Determine length of longest relation name. */

/* go through all relations */

	max_rel_name_len = length (rtrim (relation_name (1)));
	do i = 2 to model_relations.nrels;
	     max_rel_name_len = max (max_rel_name_len, length (rtrim (relation_name (i))));
	end;
	do rltn = 1 to model_relations.nrels while (relation_name(rltn) ^= " ");

	     if ^submodel then ;
	     else do;
		     call mrds_dsm_read_relation ((relation_name (rltn)), dm_area_ptr, str_ptr, submodel_iocb_ptr, code);
		     if code ^= 0 | str_ptr = null () then do;
			     call ioa_$rsnnl ("^/Unable to get attribute information from mrds_dsm_read_relation for submodel, ^a",
				er_mess, 0, model_path);
			     goto ERROR;
			end;

		end;

	     if submodel then
		model_name = str_ptr -> relation_block.dm_rel_name;
	     else model_name = relation_name (rltn);

	     call mrds_dm_get_attributes$set_user_view ();
	     call mrds_dm_get_attributes (dm_ptr, model_name, dm_area_ptr, rd_ptr, code);
	     call mrds_dm_get_attributes$set_db_view ();
	     if rd_ptr = null | code ^= 0 then do;
		     call ioa_$rsnnl ("^/Received a null pointer from dmd_$get_attributes for data model, ^a",
			er_mess, 0, model_path);
		     go to ERROR;
		end;
						/* Convert descriptor to ASCII in standard format. */
	     buf_next_column = max_rel_name_len + 3;
	     right_margin = 5;
	     row = 1;

	     if submodel then do;			/* make a new attr list of only submodel attrs */

		     num_attr_alloc = str_ptr -> relation_block.no_rb_attributes;

		     allocate rel_desc set (new_rd_ptr) in (dm_area);

		     unspec (new_rd_ptr -> rel_desc) = "0"b;
		     new_rd_ptr -> rel_desc.num_attr = num_attr_alloc;

/* change the model attribute names to those of the submodel */

		     do sm_attr_num = 1 to num_attr_alloc;

			found = OFF;
			attr_num = 1;
			do while (^found);

			     if rd_ptr -> rel_desc.attributes (attr_num).attribute_name =
				str_ptr -> relation_block.attribute_info (sm_attr_num).dm_attr_name then do;
				     found = ON;
				     new_rd_ptr -> rel_desc.attributes (sm_attr_num) =
					rd_ptr -> rel_desc.attributes (attr_num);
				     new_rd_ptr -> rel_desc.attributes (sm_attr_num).attribute_name =
					str_ptr -> relation_block.attribute_info (sm_attr_num).dsm_attr_name;
				end;
			     else if attr_num < rd_ptr -> rel_desc.num_attr then
				attr_num = attr_num + 1;
			     else do;
				     found = ON;
				     call ioa_$rsnnl ("^/Unable to find submodel relation ""^a"" in the data model, ^a",
					er_mess, 0, str_ptr -> relation_block.attribute_info (sm_attr_num).dsm_attr_name,
					model_path);
				     goto ERROR;
				end;

			end;

		     end;

		     free rd_ptr -> rel_desc in (dm_area);
		     rd_ptr = new_rd_ptr;
		     new_rd_ptr = null ();

		end;

/* set up column and box length parameters */

	     allocate attr_descriptors in (dm_area);

	     do attr = 1 to num_attr;


		attr_desc (attr) = mu_display_descriptor (addr (descriptor (attr)));
		if creating_incl then do;
			i = index (attr_desc (attr), "leading sign");
			if i = 0 then ;
			else attr_desc (attr) = /* remove part of comment to shorten line */
				substr (attr_desc (attr), 1, i - 1) || substr (attr_desc (attr), i + 13);
		     end;
		else do;
						/* Prescan attributes and determine if this relation will fit */
						/*   on current page.  No output is done here. */
			box_len = length (rtrim (attribute_name (attr)));
			if ^brief_table then do;
				attr_desc (attr) = mu_trim_descriptor (attr_desc (attr));
				box_len = max (length (attr_desc (attr)), box_len);
			     end;
			if j = num_attr then right_margin = 3;
			if box_len + right_margin > line_len + 1 - buf_next_column then do;
						/* Have to go to another row of boxes. */
				buf_next_column = max_rel_name_len + 10;
				row = row + 1;
			     end;
			buf_next_column = buf_next_column + box_len + 3;
		     end;				/* Ends do if creating a table. */
	     end;					/* Ends do for num_attr loop. */
						/* Determine if a new page is required to display current */
						/*   relation. */
	     if creating_incl then
		if num_attr + 2 > lines_left then call new_page ();
		else ;
	     else if brief_table & (row * 4 + 1 > lines_left) | ^brief_table & (row * 5 + 1 > lines_left) then call new_page ();
	     blank_lines = 1;
	     if creating_incl then do;		/* This is all that is needed for an include file. */
		     call ioa_$rsnnl ("dcl 1 ^a aligned^[ based^;^],", buf (1), 0,
			translate (relation_name (rltn), "_", "-"), based_decls);
		     call output_buffer (blank_lines, 1);
		end;
	     else do;				/* Setup begining of line for table display. */
		     buf_next_column = max_rel_name_len + 3;
		     buf (1) = copy (" ", max_rel_name_len + 1) || "_";
		     buf (2), buf (4) = copy (" ", max_rel_name_len + 1) || "|";
		     call ioa_$rsnnl ("^vx^a |", buf (3), 0,
			max_rel_name_len - length (rtrim (relation_name (rltn))), rtrim (relation_name (rltn)));
		     buf (5) = copy (" ", max_rel_name_len + 1) || "_|";
		end;
	     right_margin = 5;

/* go through all attributes */

	     do attr = 1 to num_attr;			/* Do each attribute in turn. */

/* BEGIN CHANGE 81-04-27 ******************************************* */

/* map key heads to indexed, and other key attrs to data only
   for a secured database being viewed by a non-DBA,
   to avoid a security violation possible if the user knows key info */

		if key_flag (attr) & secured_view then do;

			key_flag (attr) = OFF;

			if key_attr_order (attr) = 1 then
			     inver_flag (attr) = ON;

		     end;

/* END CHANGE 81-04-27 *************************************************** */

		if creating_incl then do;		/* No line in incl file will be over 126 chars. */
			call ioa_$rsnnl ("^6x2 ^a ^a^[;^;,^]^[^vx/* ^[Key^]^[, ^]^[Index^] */^]", buf (1), 0,
			     translate (attribute_name (attr), "_", "-"), attr_desc (attr), (attr = num_attr),
			     (key_flag (attr) | inver_flag (attr)),
			     max (2, 98 - length (rtrim (attribute_name (attr))) - length (attr_desc (attr))), key_flag (attr),
			     (key_flag (attr) & inver_flag (attr)), inver_flag (attr));
			call output_buffer (0, 1);
		     end;
		else do;				/* This is what has to be done for each attribute in a */
						/*   table display. */
			box_len = length (rtrim (attribute_name (attr)));
			if ^brief_table then box_len = max (length (attr_desc (attr)), box_len);
						/* Don't have to worry about right hand continuations if this */
						/*   is last attribute. */
			if j = num_attr then right_margin = 3;
			if box_len + right_margin > line_len + 1 - buf_next_column then do;
						/* Box won't fit.  Indicate continuation. */
				buf (1) = buf (1) || "__";
				buf (5) = buf (5) || "__";
				i = 1;
				if brief_table then do;
					i = 0;
					buf (4) = buf (5);
				     end;
						/* Send it out to segment. */
				call output_buffer (blank_lines, 4 + i);
						/* Start next row of boxes. */
				buf (1) = copy (" ", max_rel_name_len + 6) || "___";
				do b = 2 to 4;
				     buf (b) = copy (" ", max_rel_name_len + 8) || "|";
				end;
				buf (5) = copy (" ", max_rel_name_len + 6) || "___|";
				buf_next_column = max_rel_name_len + 10;
			     end;			/* Ends do if overflowed right side of page. */
						/* Construct top of box. */
			buf (1) = buf (1) || copy ("_", box_len + 3);
						/* Indicate if attribute is keyed and/or secondary. */
			call ioa_$rsnnl ("^[*^; ^]^vx^[I^; ^]|", er_mess, 0, key_flag (attr), box_len, inver_flag (attr));
			buf (2) = buf (2) || er_mess;
						/* Now comes the attribute name. */
			call ioa_$rsnnl (" ^va |", er_mess, 0, box_len, attribute_name (attr));
			buf (3) = buf (3) || er_mess;
						/* If wanted, the descriptor info goes in next. */
			if ^brief_table then do;
				call ioa_$rsnnl (" ^va |", er_mess, 0, box_len, attr_desc (attr));
				buf (4) = buf (4) || er_mess;
			     end;
						/* The bottom of the box is last. */
			buf (5) = buf (5) || copy ("_", box_len + 2) || "_|";
			buf_next_column = buf_next_column + box_len + 3;
		     end;				/* Ends do for table generation. */
	     end;					/* Ends do for num_attr loop. */
	     if ^creating_incl then do;		/* Output anything left in output buffer. */
		     i = 1;
		     if brief_table then do;
			     i = 0;
			     buf (4) = buf (5);
			end;
		     call output_buffer (blank_lines, 4 + i);
		end;

	     if submodel then do;
		     free str_ptr -> relation_block in (dm_area);
		     str_ptr = null ();
		end;
	     free rd_ptr -> rel_desc in (dm_area);
	     rd_ptr = null ();
	     free attr_descriptors in (dm_area);	/* All done with descriptor info. */
	     attr_desc_ptr = null;
	end;					/* Ends do for model_relations.nrels loop. */

	if creating_incl then do;			/* Put out a separator bar at end of include segment. */
		er_mess = copy ("*", 76 - length (rtrim (dm_entry_name)));
		call ioa_$ioa_switch (out_iocb_ptr, "^//* END of ^a^4x^a/", out_entry_name, er_mess);
	     end;
						/* Close the output stream. */
	call iox_$close (out_iocb_ptr, code);
	if code ^= 0 then do;
		call ioa_$rsnnl ("^/Tried to close switch to ^a>^a", er_mess, 0, out_dir, out_entry_name);
		go to ERROR;
	     end;
						/* Detach the output switch. */
	call iox_$detach_iocb (out_iocb_ptr, code);
	if code ^= 0 then do;
		call ioa_$rsnnl ("^/Tried to detach switch to ^a>~a", er_mess, 0, out_dir, out_entry_name);
		go to ERROR;
	     end;
						/* Get the bit count so that tssi_ can finish its act up. */
	out_iocb_ptr = null ();

	call hcs_$status_minf (out_dir, out_entry_name, chase, 0, out_len, code);
	if code ^= 0 then do;
		call ioa_$rsnnl ("^/Tried to get length of ^a>^a", er_mess, 0, out_dir, out_entry_name);
		go to ERROR;
	     end;
						/* Now its tssi_'s turn. */
	call tssi_$finish_segment (out_ptr, out_len, (RW_ACCESS), out_acl_ptr, code);
	if code ^= 0 then do;
		call ioa_$rsnnl ("^/Tried to finish segment, ^a>^a", er_mess, 0, out_dir, out_entry_name);
		go to ERROR;
	     end;
	go to CLEANUP;				/* Mission accomplished. */

ERROR:						/* Report all errors here. */
	call com_err_ (code, prog_name, er_mess);
	code = 1;					/* so segment gets deleted */

CLEANUP:
	call clean_up ();
	return;					/* Done no matter what. */

clean_up: proc;					/* Clean up this operation. */

	call mrds_dm_get_attributes$set_db_view ();	/* leave in known state */
	if attr_desc_ptr ^= null then free attr_descriptors in (dm_area);
	if rd_ptr ^= null then free rel_desc in (dm_area);
	if mr_order_ptr ^= null then free mr_order_ptr -> model_relations in (dm_area);
	if mr_ptr ^= null then free model_relations in (dm_area);
	if dmh_ptr ^= null then free dm_header in (dm_area);
	if out_iocb_ptr ^= null then do;
		call iox_$close (out_iocb_ptr, discard_code);
		call iox_$detach_iocb (out_iocb_ptr, discard_code);
	     end;
	if out_acl_ptr ^= null then call tssi_$clean_up_segment (out_acl_ptr);
	if out_ptr ^= null & code ^= 0 then call delete_$ptr (out_ptr, "000111"b, (prog_name), code);
	if dm_ptr ^= null then call mrds_dm_close (dm_ptr, code);
	if submodel then call mrds_dsm_close$force (submodel_iocb_ptr);
	if hd_ptr ^= null () then free hd_ptr -> mrds_dsm_header in (dm_area);
	if str_ptr ^= null () then free str_ptr -> relation_block in (dm_area);
	if new_rd_ptr ^= null () then free new_rd_ptr -> rel_desc in (dm_area);

     end clean_up;

conv_error: proc;

	call ioa_$rsnnl ("^/Conversion error occured in argument, ""^a"", following ^a control argument.",
	     er_mess, 0, arg, control_arg);
	code = error_table_$bad_conversion;
	go to ERROR;

     end conv_error;

new_page: proc;

	call ioa_$ioa_switch_nnl (out_iocb_ptr, "^|");
	lines_left = page_len;

     end new_page;

output_buffer: proc (blank_line_count, buf_line_count);

	dcl     b			 fixed bin;
	dcl     blank_line_count	 fixed bin;
	dcl     buf_line_count	 fixed bin;

	if page_len ^= 0 then do;
		if lines_left < blank_line_count + buf_line_count then call new_page ();
		lines_left = lines_left - blank_line_count - buf_line_count;
	     end;

	do b = 1 to blank_line_count;
	     call ioa_$ioa_switch (out_iocb_ptr, "");
	end;
	blank_line_count = 0;

	do b = 1 to buf_line_count;
	     call ioa_$ioa_switch (out_iocb_ptr, "^a", buf (b));
	end;

     end output_buffer;

	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     arg_len		 fixed bin;
	dcl     arg_ptr		 pointer;
	dcl     attr		 fixed bin;
	dcl     attr_desc_ptr	 pointer internal static;
	dcl     1 attr_descriptors	 aligned based (attr_desc_ptr),
		2 nattr		 fixed bin,
		2 attr_desc	 (num_attr refer (attr_descriptors.nattr)) char (120) varying;
	dcl     b			 fixed bin;
	dcl     below_sw		 bit (1);
	dcl     blank_lines		 fixed bin;
	dcl     box_len		 fixed bin;
	dcl     brief_table		 bit (1);
	dcl     buf		 (12) char (256) varying;
	dcl     buf_next_column	 fixed bin;
	dcl     chase		 fixed bin (1) init (1) internal static options (constant);
	dcl     clock_		 entry returns (fixed bin (71));
	dcl     copy		 builtin;
	dcl     current_date_time	 char (24);
	dcl     addr		 builtin;
	dcl     cleanup		 condition;
	dcl     code		 fixed bin (35);
	dcl     com_err_		 entry options (variable);
	dcl     control_arg		 char (32);
	dcl     conversion		 condition;
	dcl     convert		 builtin;
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     dm_abs_path		 char (168);
	dcl     dm_adir		 char (168);
	dcl     dm_aentry_name	 char (32);
	dcl     dm_area		 area based (dm_area_ptr);
	dcl     dm_area_ptr		 pointer internal static init (null);
	dcl     dm_dir		 char (168);
	dcl     dm_entry_name	 char (32);
	dcl     dm_path		 char (168);
	dcl     dm_ptr		 pointer;
	dcl     mrds_dm_close	 entry (ptr, fixed bin (35));
	dcl     mrds_dm_get_attributes entry (ptr, char (32), ptr, ptr, fixed bin (35));
	dcl     mrds_dm_get_header	 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dm_get_relations	 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35));
	dcl     empty		 builtin;
	dcl     er_mess		 char (256) varying;
	dcl     error_table_$bad_arg	 fixed bin (35) external;
	dcl     error_table_$bad_conversion fixed bin (35) external;
	dcl     error_table_$badcall	 fixed bin (35) external;
	dcl     error_table_$badopt	 fixed bin (35) external;
          dcl     error_table_$inconsistent fixed bin (35) external;
	dcl     error_table_$noarg	 fixed bin (35) external;
	dcl     error_table_$wrong_no_of_args fixed bin (35) external;
	dcl     suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     expect		 fixed bin;
	dcl     get_system_free_area_	 entry returns (ptr);
          dcl     have_of                bit (1);
          dcl     have_relation          bit (1);
	dcl     hcs_$get_link_target	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     i			 fixed bin;
	dcl     iarg		 fixed bin;
	dcl     creating_incl	 bit (1);
	dcl     based_decls		 bit (1);		/* on => create based declaration */
	dcl     secured_view	 bit (1);		/* on => non-dba on secured db */
	dcl     index		 builtin;
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$ioa_switch	 entry options (variable);
	dcl     ioa_$ioa_switch_nnl	 entry options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     j			 fixed bin;
	dcl     legend_len		 fixed bin;
	dcl     length		 builtin;
	dcl     line_len		 fixed bin;
	dcl     lines_left		 fixed bin;
	dcl     ll_arg		 fixed bin init (1) internal static options (constant);
	dcl     max		 builtin;
	dcl     max_buf_len		 fixed bin;
	dcl     max_rel_name_len	 fixed bin;
	dcl     mr_order_ptr	 pointer;
	dcl     mu_display_descriptor	 entry (ptr) returns (char (120) varying);
	dcl     nargs		 fixed bin;
	dcl     no		 bit (1) init ("0"b) internal static options (constant);
	dcl     norder		 fixed bin;
	dcl     nrelations		 fixed bin;
	dcl     null		 builtin;
	dcl     order_arg		 fixed bin init (3) internal static options (constant);
	dcl     order_begin		 fixed bin;
	dcl     order_end		 fixed bin;
	dcl     ordering		 bit (1);
          dcl     output_file_arg        fixed bin init (5) internal static options (constant);
	dcl     out_acl_ptr		 pointer internal static;
	dcl     out_atd		 char (175) varying;
	dcl     out_dir		 char (168);
	dcl     out_entry_name	 char (32);
	dcl     out_iocb_ptr	 pointer init (null ());
	dcl     out_len		 fixed bin (24);
	dcl     out_ptr		 pointer;
	dcl     path_argument	 char (168);	/* holds the input argumenbt corresponding to the db/dsm path */
	dcl     page_len		 fixed bin;
	dcl     pl_arg		 fixed bin init (2) internal static options (constant);
	dcl     prog_name		 char (32) varying;
	dcl     rel_name_arg           fixed bin init (4) internal static options (constant);           
	dcl     retrieval		 fixed bin init (2) internal static options (constant);
	dcl     right_margin	 fixed bin;
	dcl     rltn		 fixed bin;
	dcl     row		 fixed bin;
	dcl     rtrim		 builtin;
	dcl     stream_out		 fixed bin init (2) internal static options (constant);
	dcl     substr		 builtin;
	dcl     suffix		 char (32);
	dcl     tssi_$clean_up_segment entry (ptr);
	dcl     tssi_$finish_segment	 entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
	dcl     tssi_$get_segment	 entry (char (*), char (*), ptr, ptr, fixed bin (35));
	dcl     time_str		 char (24);
	dcl     translate		 builtin;
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     unspec		 builtin;
	dcl     version		 char (4) varying init ("3.0") internal static options (constant);
	dcl     mu_trim_descriptor	 entry (char (120) varying) returns (char (*)); /* shortens descriptor string
						   using defaults/abbrevs */
	dcl     (mrds_dm_get_attributes$set_user_view, mrds_dm_get_attributes$set_db_view) entry ();
	dcl     db_version		 fixed bin;	/* db_version 1 - 4 of database */
	dcl     mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* gets path details */
	dcl     local_area		 area (2048);	/* space for path info */
	dcl     hd_ptr		 ptr;		/* points to submodel header */
	dcl     str_ptr		 ptr;		/* points to submodel relation info */
	dcl     submodel		 bit (1);		/* on => submodel pathname given */
	dcl     mrds_dsm_close$force	 entry (ptr);
	dcl     discard_code	 fixed bin (35);	/* unused error code */
	dcl     mrds_dsm_open$read	 entry (char (*), ptr, fixed bin (35));
	dcl     mrds_dsm_read_header	 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_get_relation_names entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_read_relation entry (char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     submodel_iocb_ptr	 ptr init (null ());/* pointer to the submodels iocb */
	dcl     found		 bit (1);		/* on => found model attr in submodel list */
	dcl     sm_attr_num		 fixed bin;	/* index into submodel attr list */
	dcl     model_path		 char (168);	/* name of data model to open */
	dcl     entry_suffix	 char (4) varying;	/* either .dsm or .db */
	dcl     attr_num		 fixed bin;	/* index into model attr list */
	dcl     ON		 bit (1) internal static options (constant) init ("1"b); /* true value */
	dcl     OFF		 bit (1) internal static options (constant) init ("0"b); /* false value */
	dcl     model_type		 char (4);	/* either Data or Sub model */
	dcl     new_rd_ptr		 ptr;		/* to temp copy of rel_desc */
	dcl     model_name		 char (32);	/* name of data model relation */
	dcl     delete_$ptr		 entry (ptr, bit (6), char (*), fixed bin (35)); /* deletes segment from pointer */
	dcl     options		 char (80) varying; /* allowed control arguments */
	dcl     sm_abs_path		 char (168) varying;/* absolute path of submodel with suffix */
	dcl     mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin, ptr, fixed bin (35)); /* gets security bit */
	dcl     secure_submodel	 bit (1);		/* on => submodel resides in submodel dir */
	dcl     mrds_error_$inc_secure_open fixed bin (35) ext; /* using db path or un-secure submodel when secured */
	dcl     mrds_error_$no_database fixed bin (35) ext static;
	dcl     mrds_error_$no_model_submodel fixed bin (35) ext static;

	dcl     mrds_data_$submodel_dir_name char (16) ext; /* name of sm dir */
	dcl     mrds_dm_secured_submodel entry (char (*), char (*), char (*)) returns (bit (1)); /* returns( true if submodel in sm dir */
	dcl     mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* finds if user a dba */
	dcl     get_wdir_		 entry () returns (char (168));
%page;
%include mrds_authorization;
%page;
%include mrds_database_state;
%page;
%include mrds_dsm_header;
%page;
%include mrds_dsm_rel_block;
%page;
%include mrds_dsm_relation_names;
%page;
%include mrds_dm_header;
%page;
%include mrds_rel_desc;
%page;
%include mrds_model_relations;
%page;
%include mrds_path_info;
%page;
%include access_mode_values;

     end cmdmi;




		    create_mrds_dsm.pl1             08/15/86  1629.0r   08/15/86  1437.0      351288



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



/****^  HISTORY COMMENTS:
  1) change(86-06-09,Dupuis), approve(86-08-05,MCR7491), audit(86-08-08,Blair),
     install(86-08-15,MR12.0-1127):
     There were several inconsistencies and problems with its usage message
     (mrds #149, phx19350). Changed the code so that each call to com_err_ used
     a constant for the usage message.
                                                   END HISTORY COMMENTS */


create_mrds_dsm: cmdsm: proc;

/*
   Create a MRDS database submodel (dsm) from a cmdsm  source.  Most
   of the interesting code is in four subroutines:
   .	mrds_dsm_parse,
   .	mrds_dsm_scanner,
   .	mrds_dsm_semantics, and
   .	mrds_dsm_compute_access.
   To change either the syntax or semantics involved in the creation
   of  a  dsm,  the  LRK source, mrds_dsm_parse.lrk, must be edited,
   followed by a series of  include  file  generations  and  program
   recompilations.   This   is   all   automated   in  an  exec_com,
   compile_dsm_lrk.ec .

   .	lrk mrds_dsm_parse -ssl
   .
   .	ted$com >udd>LIS>Wardd>lrk|hal_dcl mrds_dsm_parse mrds_dsm_terminals
   .	ted$com >udd>LIS>Wardd>Wardd|incl_cmt mrds_dsm_terminals
   .	indent mrds_dsm_terminals.incl
   .
   .	>udd>LIS>Wardd>msd mrds_dsm_parse mrds_dsm_skip_table
   .	ted$com >udd>LIS>Wardd>Wardd|incl_cmt mrds_dsm_skip_table
   .	indent mrds_dsm_skip_table.incl
   .	indent mrds_dsm_semantics
   .
   .	pl1 mrds_dsm_parse -tb -map
   .	pl1 mrds_dsm_semantics -tb -map
   .	pl1 mrds_dsm_scanner -tb -map

   Known Bugs:

   Other Problems:

   The submodel file is used  as  a  scratch  pad  to  store  access
   records  and  model  relation  names.  This  information is never
   cleaned up. It should at least be removed from the submodel  when
   its finished and should probably be moved to some other file.
   
   HISTORY:

   80-02-01 Spratt: written

   80-06-24 Spratt: Put working submodel in  the  process_dir  using
   .        mrds_dsm_define_temp,  added  submodel  validation   via
   .        mrds_dsm_valid_.

   80-10-29 Spratt: Added deletion of the temporary submodel in  the
   .        finish  proc,  under  the  control  of  a  new   switch,
   .        control_debug_submodel.  Added  a  new control argument,
   .        "-debug_submodel",  to  set  the  control_debug_submodel
   .        switch.

   80-11-08 Spratt: Added the -install control  argument.  submodels
   .        are now stored in the users working directory unless the
   .        -install  control argument is given, in which case it is
   .        "installed" under the  database  submodel  directory.  A
   .        call  to  a  new  dsm subroutine mrd_dsm_set_db_path was
   .        added to set  the  database  pathname  in  the  submodel
   .        header.  Append  access on the database directory is now
   .        only checked for when installing.

   11/25/80 by Lindsey  Spratt:  Changed  "finish"  processing.  The
   .        finish procedure now takes an argument which tells it to
   .        delete  the  submodel.  Most  calls  to finish now use a
   .        variable  as  the  argument,  submodel_deletion_control.
   .        Before  the  dsm  has  been  created, or defined, by the
   .        current invocation of  cmdsm,  submodel_deletion_control
   .        is   set   to   DONT_DELETE_SUBMODEL.   Once  cmdsm  has
   .        successfully        defined         the         submodel
   .        submodel_deletion_control  is  set  to  DELETE_SUBMODEL.
   .        Name  duplication  handling  has  been  added  for   the
   .        submodel.  If  a  dsm  of the given name already exists,
   .        nd_handler_ is called. The access on  the  database  now
   .        checked   for   is   sma,   instead   of   a.   If   the
   .        secure.submodels directory doesn't  already  exist  (and
   .        cmdsm  was invoked with -install), it is created. All of
   .        the error messages are now preceded by  a  newline.  The
   .        submodel is now created in place, instead of copied from
   .        the process_dir. mrds_dsm_define_temp was changed to use
   .        the  dsm_path  argument  as  an input argument if it was
   .        non-null. Mrds_dsm_dmdsm is now called  if  validate  is
   .        on,  even if generate_display is off. This is to use the
   .        validation  aspect  of  mrds_dsm_dmdsm.  Iocbs  are  now
   .        destroyed after being closed.

   81-01-12 Davids: changed the references of  mrds_dsm_display_rels
   .        to mrds_dsm_relation_names, changed the area set up from
   .        zero_on_free  to  zero_on_alloc  and removed the call to
   .        emtry which came right after the call to define_area_

   81-01-22     Davids:      changed      mrds_dsm_open_read      to
   .         mrds_dsm_open$read.

   81-01-28 Davids: removed the mrds_dsm_relation_names include file
   .        which was used.

   81-02-10 Davids: reformated the header and declaration sections

   .        reformated the code so  that  the  argument  processing,
   .        model  path  processing and submodel path processing are
   .        on separate pages.

   .        removed calls to the  internal  procedure  finish  which
   .        were  not  needed, nothing that finish cleans up was yet
   .        allocated.

   .        rewrote the argument  processing  so  that  it  is  much
   .        simpler and only takes the control arguments -list, -ls,
   .        -^list, -^ls, -install, -ins, -^install, -^ins. also the
   .        first non-control argument is the cmdsm source, the next
   .        is the db path, control args may come  before,  between,
   .        or after the path arguments.

   81-02-17 Davids: changed the arguments ^list, ^ls, ^install,  and
   .        ^ins to no_list, nls, no_install and nins.

   .        move the processing of the list path so that it  is  the
   .        first  thing  done,  also  if  the  list segment already
   .        exists it is truncated, if  it  does  not  exist  it  is
   .        created.  if  an error occurs before usefull information
   .        is placed in the listing and the listing was created  it
   .        is deleted.

   .        changed the name of  the  variable  controling  submodel
   .        deletion      from      submodel_deletion_control     to
   .        delete_submodel. Also changed the  finish  procedure  to
   .        use    the    gobal    variables   delete_submodel   and
   .        delete_listing rather than have parameters.

   81-02-18 Davids: fixed a bunch of  errors  that  were  introduced
   .        when the listing segment  processing  was  moved.  these
   .        included  using  elements  of  structures  that were not
   .        allocated, pointers that were not null'ed and typos that
   .        were  also  variables. also changed the finish procedure
   .        so  that  it  does  not  use   the   pointers   in   the
   .        mrds_dsm_parse_info  str but uses the automatic pointers
   .        that  are  used  to  set   the   pointer   elements   in
   .        mrds_dsm_parse_info.

   .        replaced         get/release_temp_segments_         with
   .        get/release_temp_segment.  only one temp segment is ever
   .        used.

   .        changed  the  name  of  the  submodel_name  variable  to
   .        dsm_name  so  that  the  variable  names refering to the
   .        submodel segment are more consistant.

   .        changed  all  calls  to  mrds_dsm_close  in  the   finsh
   .        procedure to mrds_dsm_close$force. also removed the call
   .        to iox_$destroy_iocb since that is now done by close.

   .        changed the  name  of  source_dir  to  cmdsm_source_dir,
   .        source_entry  to  cmdsm_source_entry and delete_submodel
   .        to delete_dsm for more consistant names.

   81-02-19 Davids: added security and DBAness checks.  now  only  a
   .        DBA can use the -install (-ins) control argument,  if  a
   .        DBA  creates  a  submodel for a secure database and does
   .        not install it a warning message is issued  and  only  a
   .        DBA can use the cmdsm command against a secure database.

   .        changed the  error  message  for  a  non-existant  cmdsm
   .        source.

   81-02-25  Davids  header  and  declaration  sections  reformated.
   .        removed   the   include   files   iox_modes,   iox_dcls,
   .        mrds_dsm_entry_dcls, and control_argument_dcls.

   .        changed the call to dmd_$open_dm to mrds_dm_open$open_dm
   .        so secure databases can be opened.

   .        access of sma is now put on the submodel directory  (for
   .        the  DBA)  if  the install option is used and access was
   .        not already there.

   .        mrds_dsm_dmdsm is now called only if a listing is to  be
   .        preoduced. it is called in such a manner that validation
   .        is  not  done.  submodel  validation  will  be  done  by
   .        semantics and compute_access.

   .        the  call  to  mrds_dsm_set_db_path  was  replaced  with
   .        mrds_dsm_write_header   which   will  write  a  complete
   .        header, i.e. set the relation count.

   81-02-26 Davids: changed the call of mrds_dm_open$open_dm to just
   .        mrds_dm_open.

   81-02-27 Davids removed the  iox_$user_output  declaration.  this
   .        pointer was used if  a  listing  was  not  going  to  be
   .        generated  but  the  call  to mrds_dsm_dmdsm was done to
   .        validate the submodel. the call  is  now  made  only  to
   .        produce a listing.

   .        changed the call to dmd_$close_dm to mrds_dm_close.

   .        mrds_dsm_dmdsm  always  expects  the  validate  bit   in
   .        dsm_display_info to be set. if it is not set dmdsm blows
   .        up with a null pointer. The bit is now set.

   81-03-02 Davids: changed error_table_$arg_err to argerr.  arg_err
   .        does not exist.

   81-05-05 Davids: added force and no_force control arguments

   .        now using hcs_status_ rather than  hcs_$get_user_effmode
   .        to determine the acl on the secure.submodels directory.

   .        now   calling    mrds_dm_authorization$set_needed_access
   .        rather  than  hcs_$add_dir_acl  to  set  the  acl on the
   .        secure.submodels directory for a DBA

   .        changed name  duplication  handling  to  only  delete  a
   .        segment  (msf)  if  its  a submodel and to only unlink a
   .        link if its target is a submodel.

   81-05-07   Davids:    modified    to    set    the    value    of
   .        mrds_dsm_parse_info.data_mode_ptr, which was just  added
   .        to the mrds-dsm_parse_info structure.

   81-05-11   Davids:    changed    the    calling    sequence    of
   .        mrds_dsm_compute_access to include the  pointer  to  the
   .        listing iocb.

   81-05-13 Davids: added code to call cmdsm_v1 in  the  event  that
   .        the database is a version 3 or  earlier.  reordered  the
   .        processing of db_path and listing so that the db_path is
   .        first, followed by the submodel path,  followed  by  the
   .        listing path.

   81-05-15      Davids:      modified      to       check       the
   .        mrds_dsm_parse_info.highest_severity*  values   and   to
   .        delete  the created submodel unless all values are zero.
   .        Also the listing will not contain the dmdsm  display  if
   .        the source had errors.

   81-05-22  Davids:  added  data_model_ptr  to  the  parameters  of
   .         mrds_dsm_compute_access so that it can determine if the
   .         relation access is valid.

   81-05-27 Davids: changed the setting of delete_dsm so that it  is
   .        inited to "1"b and so that it is only set to "0"b if  no
   .        errors occured. There used to be a window where the only
   .        thing in the submodel would be the header record.

   81-05-28 Davids: modified to handle the new mrds_dsm_display_info
   .        structure (replaces the dsm_display_info structure).

   .        modified so that if the responce from nd_handler  is  no
   .        the  old submodel is not deleted, this started happening
   .        when the default value of delete_dsm  was  set  to  "1"b
   .        instead of "0"b.

   81-05-29 Davids: modified so that if an entry with  the  submodel
   .        name already exists and its not a  submodel  it  is  not
   .        deleted  and  so that as long asa non-zero error code is
   .        return from nd_handler the entry is not deleted.

   81-06-25     Davids:     Changed      the      references      to
   .        mrds_dsm_parse_info.submodel_iocb_ptr in  the  calls  to
   .        write_header  and  close  to references to dsm_iocb_ptr.
   .        both pointers start off withthe same value but the  call
   .        to  close  changes  the value to null - a new version of
   .        iox_ does this now (it didn't use to). the  new  version
   .        of iox_ also goes crazy when you give it a pointer to an
   .        iocb that it has already close/detached/destroyed.  this
   .        change gets around the changed behavior of iox.

   81-07-21 Jim Gray : changed logic to not try to build a submodel,
   if  a  severity  >=  1 occured in the parsing. Also added message
   about submodel not being created, and the highest severity  error
   message seen, if the severity was > 0.

   81-08-06 Davids: changed the inited value of delete_dsm  to  "0"b
   .        (from "1"b) and do not set it to "1"b until the submodel
   .        msf  has  been  successfully created i.e. after the call
   .        the mrds_dsm_define_temp and its  associated  error  and
   .        name_dup  processing. This elimintaed several setting of
   .        the switch to "0"b before this  point.  This  change  is
   .        required  because if an error occurs before the value of
   .        dsm_name is set (in the call to hcs_$initiate_count)  it
   .        could  be  ""  or  garbadge, if its null then the finish
   .        procedure will end up deleting the working directory.

   83-06-21 Davids: Removed check for old version database and the call
   to v1 code if it was an old version db (old version dbs can no longer
   be opened)
*/

/* AUTOMATIC */

	dcl     arg_index		 fixed bin;	/* index of argument */
	dcl     arg_len		 fixed bin (21);	/* length of argument */
	dcl     arg_ptr		 ptr;		/* pointer to argument */

	dcl     cmdsm_source_bc	 fixed bin (24);	/* bit count of the cmdsm source */
	dcl     cmdsm_source_dir	 char (168);	/* directory containing cmdsm source */
	dcl     cmdsm_source_entry	 char (32);	/* entry name of cmdsm source */
	dcl     cmdsm_source_path	 char (168);	/* path of cmdsm source */
	dcl     cmdsm_source_ptr	 ptr init (null ());/* pointer to the cmdsm source */

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

	dcl     control_debug_parse	 bit (1) init ("0"b); /* debug switch for mrds_dsm_parse */
	dcl     control_debug_scanner	 bit (1) init ("0"b); /* debug switch for mrds_dsm_scanner */
	dcl     control_debug_semantics bit (1) init ("0"b); /* debug switch for mrds_dsm_semantics */

	dcl     data_model_ptr	 ptr init (null ());/* pointer to the database data_model segment */

	dcl     db_path		 char (168) init (""); /* path of database directory */

	dcl     delete_dsm		 bit (1) init ("0"b); /* controls deletion of submodel msf */
	dcl     delete_listing	 bit (1) init ("0"b); /* controls deletion of listing segment */

	dcl     dsm_dir		 char (168);	/* containing directory of submodel */
	dcl     dsm_iocb_ptr	 ptr init (null ());/* iocb pointer to the submodel */
	dcl     dsm_name		 char (32);	/* entry name of submodel msf */
	dcl     dsm_path		 char (168);	/* path of submodel */

	dcl     force		 bit (1) unal init ("0"b); /* true if existing submodel should be deleted without query */
	dcl     install		 bit (1) init ("0"b); /* true if submodel is to be installed */

	dcl     listing_dir		 char (168) init (""); /* directory containing the listing segment */
	dcl     listing_entry	 char (32) init (""); /* entry name of listing segment */
	dcl     listing_iocb_ptr	 ptr init (null ());/* iocb pointer to the listing segment */
	dcl     listing_ptr		 ptr init (null ());/* pointer to the listing segment */

	dcl     local_area		 area (1000);	/* local area for allocs, no need to free */
	declare max_severity	 fixed bin;	/* highest severity error seen */
	dcl     nargs		 fixed bin;	/* number of arguments this command was called with */
	dcl     produce_listing	 bit (1) aligned init ("0"b); /* true if listing is to be produced */

	dcl     ring		 fixed bin;	/* user ring */
	dcl     ring_array		 (3) fixed bin (3); /* ring brackets for submodel dir */

	dcl     01 status_stuff	 like status_branch;/* space for status to put info in */

	dcl     temp_dsm_path	 char (168) init (""); /* path to a temp segment used as a local area */
	dcl     temp_seg_ptr	 ptr init (null ());/* pointer to the temp segment */

	dcl     user_id		 char (32);	/* person.project.tag of user */
	dcl     work_area_ptr	 ptr init (null ());/* pointer to the local area */

/* BASED */

	dcl     arg		 char (arg_len) based (arg_ptr); /* the argument */
	dcl     work_area		 area (sys_info$max_seg_size) based (work_area_ptr);

/* BUILTIN */

	dcl     addr		 builtin;
	dcl     divide		 builtin;
	dcl     empty		 builtin;
	dcl     fixed		 builtin;
	dcl     length		 builtin;
	dcl     max		 builtin;
	dcl     null		 builtin;
	dcl     rtrim		 builtin;
	dcl     substr		 builtin;
	dcl     unspec		 builtin;

/* CONDITION */

	dcl     cleanup		 condition;

/* CONSTANT */

	dcl     CMDSM_SUFFIX	 char (5) internal static options (constant) init ("cmdsm");
	dcl     CREATE_A_DIRECTORY	 init (1) fixed bin (1) internal static options (constant);
	dcl     DONT_CHASE_LINKS	 init (0) fixed bin (1) internal static options (constant);
	dcl     DONT_COPY		 init (0) fixed bin (1) internal static options (constant);
	dcl     DSM_SUFFIX		 char (3) internal static options (constant) init ("dsm");
	dcl     LISTING_SUFFIX	 char (4) internal static options (constant) init ("list");
	dcl     MYNAME		 char (15) init ("create_mrds_dsm") internal static options (constant);
	dcl     SMA_MODE_VALUE	 init ("01011"b) bit (5) unal internal static options (constant);
	dcl     STREAM_OUTPUT	 fixed bin init (2) internal static options (constant);
	dcl     USAGE 		 char (60) internal static options (constant) init
	("^/Usage: cmdsm dsm_source_path database_path {-control_args}");
/* ENTRY */

	dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35));
	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     define_area_	 entry (ptr, fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     get_group_id_$tag_star entry returns (char (32));
	dcl     get_ring_		 entry returns (fixed bin (3));
	dcl     get_temp_segment_	 entry (char (*), pointer, fixed bin (35));
	dcl     get_wdir_		 entry () returns (char (168));
	dcl     hcs_$append_branchx	 entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*),
				 fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
	dcl     hcs_$del_dir_tree	 entry (char (*), char (*), fixed bin (35));
	dcl     hcs_$delentry_file	 entry (char (*), char (*), fixed bin (35));
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	dcl     hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     hcs_$status_	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     hcs_$terminate_noname	 entry (ptr, fixed bin (35));
	dcl     hcs_$truncate_seg	 entry (ptr, fixed bin, fixed bin (35));
	dcl     ioa_		 options (variable) entry;
	declare ioa_$ioa_switch	 entry options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35));
	dcl     mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_dm_close	 entry (ptr, fixed bin (35));
	dcl     mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35));
	dcl     mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_dsm_close	 entry (ptr, fixed bin (35));
	dcl     mrds_dsm_close$force	 entry (ptr);
	dcl     mrds_dsm_compute_access entry (char (*), char (*), ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_define_temp	 entry (char (*), ptr, fixed bin (35));
	dcl     mrds_dsm_dmdsm	 entry (ptr, fixed bin (35));
	dcl     mrds_dsm_open$read	 entry (char (*), ptr, fixed bin (35));
	dcl     mrds_dsm_parse	 entry (ptr, fixed bin (35));
	dcl     mrds_dsm_write_header	 entry (ptr, char (*), fixed bin (35));
	dcl     nd_handler_		 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     nd_handler_$force	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     release_temp_segment_	 entry (char (*), pointer, fixed bin (35));
	dcl     suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35));

/* EXTERNAL */

	dcl     error_table_$action_not_performed fixed bin (35) external static;
	dcl     error_table_$bad_arg	 fixed bin (35) external static;
	dcl     error_table_$empty_file fixed bin (35) external static;
	dcl     error_table_$insufficient_access fixed bin (35) external static;
	dcl     error_table_$namedup	 fixed bin (35) external static;
	dcl     error_table_$no_dir	 fixed bin (35) external static;
	dcl     error_table_$noentry	 fixed bin (35) external static;
	dcl     error_table_$pathlong	 fixed bin (35) external static;
	dcl     error_table_$wrong_no_of_args fixed bin (35) external static;
	dcl     iox_$error_output	 ptr external static;
	dcl     mrds_data_$dsmd_version_number fixed bin (35) external static;
	dcl     mrds_data_$submodel_dir_name char (16) external static;
	dcl     mrds_error_$no_database fixed bin (35) external static;
	dcl     mrds_error_$no_model_submodel fixed bin (35) external static;
	dcl     mrds_error_$version_3_db fixed bin (35) external static;
	dcl     sys_info$max_seg_size	 fixed bin (35) external static;

/* set up */

	on cleanup call finish;

	call ioa_ ("CMDSM Version ^d submodels.^/", mrds_data_$dsmd_version_number);

	cmdsm_source_path = "";
	mrds_dsm_display_info_ptr = null;
	mrds_dsm_parse_info_ptr = null;

/* process arguments */

	call cu_$arg_count (nargs);
	if nargs < 2
	then do;
		call com_err_ (error_table_$wrong_no_of_args, MYNAME, USAGE);
		goto exit;
	     end;

	do arg_index = 1 to nargs;
	     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, MYNAME, "^/Error while processing argument ^i", arg_index);
		     goto exit;
		end;
	     if substr (arg, 1, 1) = "-"
	     then do;
		     if arg = "-list" | arg = "-ls"
		     then produce_listing = "1"b;
		     else
			if arg = "-no_list" | arg = "-nls"
		     then produce_listing = "0"b;
		     else
			if arg = "-install" | arg = "-ins"
		     then install = "1"b;
		     else
			if arg = "-no_install" | arg = "-nins"
		     then install = "0"b;
		     else
			if arg = "-force" | arg = "-fc"
		     then force = "1"b;
		     else
			if arg = "-no_force" | arg = "-nfc"
		     then force = "0"b;
		     else do;
			     call com_err_ (error_table_$bad_arg, MYNAME, "^/Unrecognizable control argument ^a", arg);
			     goto exit;
			end;
		end;
	     else do;
		     if cmdsm_source_path = ""
		     then cmdsm_source_path = arg;
		     else
			if db_path = ""
		     then db_path = arg;
		     else do;
			     call com_err_ (0, MYNAME, "Extra path supplied ^a" || USAGE, arg);
			     goto exit;
			end;
		end;
	end;

	if db_path = ""
	then do;
		call com_err_ (error_table_$wrong_no_of_args, MYNAME, USAGE);
		goto exit;
	     end;

/* process database path */

	call mrds_dsl_get_version$get_path_info (db_path, addr (local_area),
	     mrds_path_info_structure_version, mrds_path_info_ptr, code);
	if code = mrds_error_$no_model_submodel
	then do;
		call com_err_ (mrds_error_$no_database, MYNAME, "^/^a is not a valid database path", db_path);
		call finish;
	     end;
	else
	     if code = mrds_error_$version_3_db
	then do;
		call com_err_ (code, MYNAME, "^/^a", db_path);
		call finish;
	     end;
	else
	     if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Unable to get version info for ^a", db_path);
		call finish;
	     end;

	db_path = mrds_path_info.absolute_path;
	if ^mrds_path_info.model
	then do;
		call com_err_ (mrds_error_$no_database, MYNAME, "^/^a is not a valid database path", db_path);
		call finish;
	     end;

	call mrds_dm_open (db_path, 2, data_model_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Unable to open the database ^a", db_path);
		call finish;
	     end;

	call mrds_dm_db_secured$get_secured_status (data_model_ptr, addr (local_area),
	     database_state_structure_version, database_state_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Unable to get secured state of database ^a", db_path);
		call finish;
	     end;

	call mrds_dm_authorization$get_user_class (db_path, addr (local_area),
	     mrds_authorization_structure_version, mrds_authorization_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Unable to get user class for database ^a", db_path);
		call finish;
	     end;

	if database_state.secured & ^mrds_authorization.administrator
	then do;
		call com_err_ (error_table_$insufficient_access, MYNAME,
		     "^/Only a DBA can create a submodel for a secure database");
		call finish;
	     end;

	if database_state.secured & ^install & mrds_authorization.administrator
	then call com_err_ (0, MYNAME,
		"^/WARNING: You are not installing this submodel which is defined for a secure database");

	if install
	then do;
		if ^mrds_authorization.administrator
		then do;
			call com_err_ (error_table_$insufficient_access, MYNAME,
			     "^/Only a DBA may install a submodel");
			call finish;
		     end;

		call hcs_$status_ (db_path, mrds_data_$submodel_dir_name, DONT_CHASE_LINKS, addr (status_stuff),
		     null (), code);
		if code = error_table_$noentry
		then do;
			ring = get_ring_ ();
			user_id = get_group_id_$tag_star ();
			ring_array (1) = ring;
			ring_array (2) = ring;
			ring_array (3) = ring;
			call hcs_$append_branchx (db_path, mrds_data_$submodel_dir_name, fixed (SMA_MODE_VALUE),
			     ring_array, user_id, CREATE_A_DIRECTORY, DONT_COPY, 0, code);
			if code ^= 0
			then do;
				call com_err_ (code, MYNAME, "^/Unable to create the submodel directory in ^a", db_path);
				call finish;
			     end;
		     end;
		else
		     if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to determine access to the submodel directory in ^a", db_path);
			call finish;
		     end;
		else do;
			if status_stuff.short.mode ^= SMA_MODE_VALUE
			then do;
				call mrds_dm_authorization$set_needed_access (db_path, code);
				if code ^= 0
				then do;
					call com_err_ (code, MYNAME, "^/Unable to set needed access in the database ^a", db_path);
					call finish;
				     end;
			     end;
		     end;

		if length (rtrim (db_path)) + 1 + length (rtrim (mrds_data_$submodel_dir_name)) > length (dsm_dir)
		then do;
			call com_err_ (error_table_$pathlong, MYNAME, "^/^a>^a exceeds the maximum path length of ^d.",
			     db_path, mrds_data_$submodel_dir_name, length (dsm_dir));
			call finish;
		     end;

		dsm_dir = rtrim (db_path) || ">" || rtrim (mrds_data_$submodel_dir_name);
	     end;
	else dsm_dir = get_wdir_ ();

/* submodel path processing */

	call expand_pathname_$add_suffix (cmdsm_source_path, CMDSM_SUFFIX, cmdsm_source_dir, cmdsm_source_entry, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Could not use the string ^a as a data submodel pathname.",
		     cmdsm_source_path);
		call finish;
	     end;

	call hcs_$initiate_count (cmdsm_source_dir, cmdsm_source_entry, "", cmdsm_source_bc, 1, cmdsm_source_ptr, code);
	if cmdsm_source_ptr = null
	then do;
		call com_err_ (code, MYNAME, "^/Cannot find the submodel source ^a>^a", cmdsm_source_dir, cmdsm_source_entry);
		call finish;
	     end;

	if cmdsm_source_bc = 0
	then do;
		call com_err_ (error_table_$empty_file, MYNAME, "^/The source file cannot be empty: ^a>^a.", cmdsm_source_dir,
		     cmdsm_source_entry);
		call finish;
	     end;

	call suffixed_name_$new_suffix (cmdsm_source_entry, CMDSM_SUFFIX, DSM_SUFFIX, dsm_name, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Unable to make submodel name.");
		call finish;
	     end;

	if install
	then do;
		if length (rtrim (dsm_dir)) + 1 + length (rtrim (dsm_name)) > length (dsm_path)
		then do;
			call com_err_ (error_table_$pathlong, MYNAME, "^/^a>^a exceeded the maximum path length of ^d.", dsm_dir,
			     dsm_name, length (dsm_path));
			call finish;
		     end;
		dsm_path = pathname_ (dsm_dir, dsm_name);
	     end;
	else do;
		call absolute_pathname_ (dsm_name, dsm_path, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to make pathname for submodel: ^a.", dsm_name);
			call finish;
		     end;
	     end;

	call mrds_dsm_define_temp (dsm_path, dsm_iocb_ptr, code);
	if code = error_table_$namedup
	then do;
		call mrds_dsm_open$read (dsm_path, dsm_iocb_ptr, code);
		if code = 0
		then do;
			call mrds_dsm_close$force (dsm_iocb_ptr);
			if force
			then call nd_handler_$force (MYNAME, dsm_dir, dsm_name, code);
			else call nd_handler_ (MYNAME, dsm_dir, dsm_name, code);
			if code = error_table_$action_not_performed
			then call finish;
			else
			     if code ^= 0
			then do;
				call com_err_ (code, MYNAME,
				     "^/Unable to do name duplication processing on the submodel entry ^a.", dsm_path);
				call finish;
			     end;
			else call mrds_dsm_define_temp (dsm_path, dsm_iocb_ptr, code);
		     end;
		else do;
			call com_err_ (code, MYNAME, "^/^a already exists and is not a submodel", dsm_path);
			call finish;
		     end;
	     end;

	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Unable to create submodel entry ^a.", dsm_path);
		call finish;
	     end;

	delete_dsm = "1"b;

/* process the listing segment path and iocb's */

	if produce_listing
	then do;
		call expand_pathname_ (cmdsm_source_path, cmdsm_source_dir, cmdsm_source_entry, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to expand the cmdsm source path");
			call finish;
		     end;

		call suffixed_name_$new_suffix (cmdsm_source_entry, CMDSM_SUFFIX, LISTING_SUFFIX, listing_entry, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to make listing name.");
			call finish;
		     end;

		listing_dir = get_wdir_ ();
		call hcs_$initiate (listing_dir, listing_entry, "", 0, 1, listing_ptr, code);
		if listing_ptr ^= null ()
		then do;
			call hcs_$truncate_seg (listing_ptr, 0, code);
			if code ^= 0
			then do;
				call com_err_ (code, MYNAME, "^/Unable to truncate the already existing listing segment ^a>^a",
				     listing_dir, listing_entry);
				call finish;
			     end;
		     end;
		else do;
			call hcs_$make_seg (listing_dir, listing_entry, "", 14, listing_ptr, code);
			if code ^= 0
			then do;
				call com_err_ (code, MYNAME, "^/Unable to create the listing segment ^a>^a",
				     listing_dir, listing_entry);
				call finish;
			     end;
			else delete_listing = "1"b;
		     end;

		call iox_$attach_name (listing_entry, listing_iocb_ptr, "vfile_ " || listing_entry, null, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to attach to the listing segment.");
			call finish;
		     end;
		call iox_$open (listing_iocb_ptr, STREAM_OUTPUT, "0"b, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to open the listing segment switch.");
			call finish;
		     end;
	     end;

/* set up the working area */

	allocate area_info;
	area_info.version = 1;

	call get_temp_segment_ (MYNAME, temp_seg_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Unable to get temporary segments.");
		call finish;
	     end;
	work_area_ptr = temp_seg_ptr;
	area_info.extend = "1"b;
	area_info.owner = MYNAME;
	area_info.size = sys_info$max_seg_size;
	area_info.areap = work_area_ptr;
	area_info.zero_on_alloc = "1"b;
	call define_area_ (area_infop, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Unable to define area on temporary segment at ^p.", work_area_ptr);
		call finish;
	     end;
	free area_info;

/* parse the cmdsm source */

	allocate mrds_dsm_parse_info in (work_area);
	mrds_dsm_parse_info.version = MRDS_DSM_PARSE_INFO_VERSION_1;
	mrds_dsm_parse_info.debug_parse = control_debug_parse;
	mrds_dsm_parse_info.debug_semantics = control_debug_semantics;
	mrds_dsm_parse_info.debug_scanner = control_debug_scanner;
	mrds_dsm_parse_info.work_area_ptr = work_area_ptr;
	mrds_dsm_parse_info.listing_iocb_ptr = listing_iocb_ptr;
	mrds_dsm_parse_info.submodel_iocb_ptr = dsm_iocb_ptr;
	mrds_dsm_parse_info.source_ptr = cmdsm_source_ptr;
	mrds_dsm_parse_info.source_length = divide (cmdsm_source_bc, 9, 17, 0);
	mrds_dsm_parse_info.error_iocb_ptr = iox_$error_output;
	mrds_dsm_parse_info.data_model_ptr = data_model_ptr;
	mrds_dsm_parse_info.highest_severity = 0;
	mrds_dsm_parse_info.highest_severity_scanner = 0;
	mrds_dsm_parse_info.highest_severity_semantics = 0;

	delete_listing = "0"b;

	call mrds_dsm_parse (mrds_dsm_parse_info_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, MYNAME, "^/Unable to parse.");
		call finish;
	     end;

	max_severity = max (mrds_dsm_parse_info.highest_severity,
	     mrds_dsm_parse_info.highest_severity_scanner,
	     mrds_dsm_parse_info.highest_severity_semantics);
	if max_severity = 0 then do;

		call mrds_dsm_write_header (dsm_iocb_ptr, db_path, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to write the submodel header record in the submodel: ^a.", dsm_name);
			call finish;
		     end;

		call mrds_dsm_close (dsm_iocb_ptr, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to close the switch for the submodel, ^a.", dsm_path);
			call finish;
		     end;

		call mrds_dsm_compute_access (MYNAME, dsm_path, listing_iocb_ptr, data_model_ptr, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to compute the access within the submodel.");
			call finish;
		     end;
	     end;

/* produce the listing */

	if produce_listing & max_severity = 0
	then do;
		allocate mrds_dsm_display_info in (work_area);
		unspec (mrds_dsm_display_info) = "0"b;
		mrds_dsm_display_info.version = MRDS_DSM_DISPLAY_INFO_VERSION;
		mrds_dsm_display_info.submodel_pathname = dsm_path;
		mrds_dsm_display_info.rel_names_array_ptr = null;
		mrds_dsm_display_info.output_iocb_ptr = mrds_dsm_parse_info.listing_iocb_ptr;
		mrds_dsm_display_info.format = "l";
		mrds_dsm_display_info.access = "1"b;
		mrds_dsm_display_info.administrator = "1"b;

		call mrds_dsm_open$read (mrds_dsm_display_info.submodel_pathname,
		     mrds_dsm_display_info.submodel_iocb_ptr, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to re-open temporary submodel for creating display.");
			call finish;
		     end;

		call mrds_dsm_dmdsm (mrds_dsm_display_info_ptr, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to append submodel display to listing.");
			call finish;
		     end;
	     end;

/* finish up */

	if max_severity = 0 then
	     delete_dsm = "0"b;
	else do;					/* error occured */
		call ioa_ ("^/An error of severity ^d occured.^/Submodel not created.^/", max_severity);
		if produce_listing then
		     call ioa_$ioa_switch (mrds_dsm_parse_info.listing_iocb_ptr,
			"^/An error of severity ^d occured.^/Submodel not created.^/", max_severity);
	     end;

	call finish;

exit:
	return;

finish: proc;

	if data_model_ptr ^= null ()
	then do;
		call mrds_dm_close (data_model_ptr, code);
		if code ^= 0
		then call com_err_ (code, MYNAME, "^/Unable to close the database model");
	     end;

	if listing_iocb_ptr ^= null
	then do;
		call iox_$close (listing_iocb_ptr, code);
		call iox_$detach_iocb (listing_iocb_ptr, code);
		call iox_$destroy_iocb (listing_iocb_ptr, code);
	     end;

	if delete_listing
	then call hcs_$delentry_file (listing_dir, listing_entry, code);

	if dsm_iocb_ptr ^= null
	then call mrds_dsm_close$force (dsm_iocb_ptr);

	if delete_dsm
	then do;
		call hcs_$del_dir_tree (dsm_dir, dsm_name, code); /* delete the msf components */
		if code = 0 | code = error_table_$no_dir
		then call hcs_$delentry_file (dsm_dir, dsm_name, code);
	     end;

	if cmdsm_source_ptr ^= null
	then call hcs_$terminate_noname (cmdsm_source_ptr, code);

	if mrds_dsm_parse_info_ptr ^= null ()
	then free mrds_dsm_parse_info in (work_area);

	if mrds_dsm_display_info_ptr ^= null
	then do;
		if mrds_dsm_display_info.submodel_iocb_ptr ^= null
		then call mrds_dsm_close$force (mrds_dsm_display_info.submodel_iocb_ptr);

		free mrds_dsm_display_info in (work_area);
	     end;

	if temp_seg_ptr ^= null
	then do;
		call release_temp_segment_ (MYNAME, temp_seg_ptr, code);
		if code ^= 0
		then do;
			call com_err_ (code, MYNAME, "^/Unable to release temporary segments.");
		     end;
	     end;
	goto exit;

     end /* finish */;

%include mrds_dsm_display_info;
%page;
%include area_info;
%page;
%include mrds_dsm_parse_info;
%page;
%include mrds_database_state;
%page;
%include mrds_authorization;
%page;
%include mrds_path_info;
%page;
%include status_structures;


     end /* create_mrds_dsm */;




		    display_mrds_db_access.pl1      08/01/88  1408.1r w 08/01/88  1313.8      192942



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

display_mrds_db_access: dmdba: dmda: procedure ();

/* DESCRIPTION:

   This command will display the Multics acls, MRDS access, and  the
   effective result of these two access controls, on both a relation
   and attribute basis for a given view of a  database  provided  by
   either a model or submodel opening of it. It accepts the pathname
   that would be used in that opening. Any order  can  be  used  for
   path  and  control  arguments,  with  the control arguments being
   over-ridable, the last  one  taking  effect.  However,  the  path
   argument  must  precede the -relation option. If the database has
   been secured, then mrds/effective access use  the  r-a-m-d  modes
   for  display, otherwise version 4 databases use the r-e-w multics
   acls for display. If relation names exceed 50, or attribute names
   exceed  40  characters,  the  display  will truncate them at that
   length.

*/

/* PARAMETERS:

   path - - (input) char(*), the relative or absolute pathname of  a
   database  model  or submodel, whose view is to be used, and whose
   access controls are to be employed in determing the access to  be
   displayed.  The  user  must  have the access to actually open the
   referenced database in  order  to  obtain  view  information  and
   access  modes.  Only  one  pathname may be given, and must appear
   before any -relation option.

   ===========

   optional control arguments:

   -brief, specifies the short form  of  the  display  This  may  be
   overiden with a subsequent -long.

   -long, specifies the verbose form of the  display  this  includes
   multics and mrds access in addition to effective access. This can
   be overiden with a subsequent -brief. The -long  control  is  the
   default.

   -relation rel_name1 ...  rel_nameN  specifies  that  only  listed
   relations  acl's  be  displayed This argument must come after the
   pathname. If two -relation controls are given, the  last  one  is
   used. The default is to display all relations in the given view.

*/

/* HISTORY:

   81-04-06 Jim Gray : originally coded

   81-07-16 Jim Gray : added add name dmdba

   83-01-18  Roger Lackey : added mrds_error_$no_model_submodel to handle
   the case where mrds_dsl_get_version$get_path_info
   returns mrds_error_$no_database.  Also declared undeclared variables.


*/

	if recursive_call then do;			/* we can't allow recursion because of dsl_$open */
		error_code = mrds_error_$no_recursion;
		call com_err_ (error_code, caller_name, "^/^a",
		     "A release or a start must be done before continuing.");
	     end;
	else do;

/* initialize */

		error_code = 0;
		db_index = 0;
		area_ptr = null ();
		long_format = "1"b;			/* default to -long option */
		all_relations = "1"b;		/* default to showing all relations in the view */
		path_seen = "0"b;
		call cu_$af_arg_count (nargs, error_code); /* make sure we weren't called as an active function */
		if error_code ^= error_table_$not_act_fnc then
		     call com_err_ (error_code, caller_name, "^/^a",
			"Command called as an active function, or unable to obtain argument count.");
		else do;

			error_code = 0;
			on cleanup call clean_up ();
			recursive_call = "1"b;	/* prevent recursion */

/* check for a good call */

			if nargs < 1 then do;
				error_code = error_table_$wrong_no_of_args;
				call com_err_ (error_code, caller_name, "^/^a",
				     "Usage:  dmdba  path  {-brief|-long} {-relation rel_name1 ... rel_nameN}");
			     end;
			else do;

/* get some work space */

				call get_temp_segment_ (caller_name, area_ptr, error_code);
				if error_code ^= 0 then
				     call com_err_ (error_code, caller_name, "^/^a",
					"Unable to get a temp segment.");
				else do;

					area_ptr -> work_area = empty ();

/* gather all the arguments */

					arg_count = 1;
					args_finished = "0"b;
					do while (^args_finished);

/* get this argument, and decide if it is a control argument or not */

					     call cu_$arg_ptr (arg_count, arg_ptr, arg_len, error_code);
					     if error_code ^= 0 then do;
						     args_finished = "1"b;
						     call com_err_ (error_code, caller_name, "^/^a ^d",
							"Unable to get argument number", arg_count);
						end;
					     else do;

/* check for a null argument */

						     if arg_len < 1 then do;
							     args_finished = "1"b;
							     error_code = error_table_$bad_arg;
							     call com_err_ (error_code, caller_name, "^/^a ^d",
								"A null character string was detected for argument number", arg_count);
							end;
						     else do;

/* control arguments begin with a hyphen */

							     if substr (arg, 1, 1) = "-" then
								call process_control_arg ();
							     else call process_path_arg ();

							end;

/* advance to the next argument */

						     if arg_count < nargs then
							arg_count = arg_count + 1;
						     else args_finished = "1"b;

						end;

					end;

/* check that we got a  pathname argument */

					if error_code = 0 then do;

						if ^path_seen then do;
							error_code = error_table_$noarg;
							call com_err_ (error_code, caller_name, "^/^a",
							     "No pathname argument was given.");
						     end;

/* go display the requested access */

						else call display_access ();

					     end;
				     end;

			     end;


/* clean up after finishing */

			call clean_up ();

		     end;

	     end;

	return;

process_control_arg: procedure ();

/* routine to determine if user has given one of the legal
   control arguments of brief, long, or relation REL_NAME
   and to save the corresponding information.
   The logic is such as to allow duplicate control arguments
   to override each other, with the last given taking effect. */

/* BRIEF */

	if arg = "-brief" | arg = "-bf" then do;
		long_format = "0"b;			/* use short display format */
	     end;

/* LONG */

	else if arg = "-long" | arg = "-lg" then do;
		long_format = "1"b;			/* use verbose display format */
	     end;

/* UNKNOWN */

	else if arg ^= "-relation" then do;
		args_finished = "1"b;
		error_code = error_table_$badopt;
		call com_err_ (error_code, caller_name, "^/^a^a^a",
		     "The control argument """, arg, """ is not supported by this command.");
	     end;

/* BAD ORDER */

	else if ^path_seen then do;
		args_finished = "1"b;
		error_code = error_table_$noarg;
		call com_err_ (error_code, caller_name, "^/^a",
		     "The pathname argument did not appear before the ""-relation"" option.");
	     end;
	else do;

/* RELATION LIST */

		last_relation_seen = "0"b;
		some_relation_seen = "0"b;
		all_relations = "0"b;		/* only do the given relations */
		last_relation_ptr, relation_list_ptr = null ();
		arg_count = arg_count + 1;
		relation_list_length = 0;

/* go through all relation names given */

		do while (^last_relation_seen);

		     call cu_$arg_ptr (arg_count, arg_ptr, arg_len, error_code);
		     if error_code ^= 0 then do;
			     args_finished, last_relation_seen = "1"b;
			     call com_err_ (error_code, caller_name, "^/^a ^d",
				"Unable to get the relation name in argument", arg_count);
			end;
		     else if arg_len < 1 then do;
			     args_finished, last_relation_seen = "1"b;
			     error_code = error_table_$bad_arg;
			     call com_err_ (error_code, caller_name, "^/^a ^d",
				"A null character string was detected for agument number", arg_count);
			end;
		     else if substr (arg, 1, 1) = "-" then do;
			     last_relation_seen = "1"b; /* end of list of relation names */
			     arg_count = arg_count - 1; /* reset for processining remaining args */
			end;
		     else do;

/* first relation name seen */

			     some_relation_seen = "1"b;

/* gather this name for the list */

			     relation_name_length_init = arg_len;
			     allocate relation set (relation_ptr) in (work_area);
			     relation.name_length = relation_name_length_init;
			     relation.name = arg;	/* remember this relation's name */

/* add the name at the end of the list to maintain order */

			     relation.next = null ();
			     if last_relation_ptr = null () then
				relation_list_ptr = relation_ptr;
			     else last_relation_ptr -> relation.next = relation_ptr;
			     last_relation_ptr = relation_ptr;
			     relation_list_length = relation_list_length + 1;

/* advance to the next name given */

			     if arg_count < nargs then
				arg_count = arg_count + 1;
			     else last_relation_seen = "1"b;

			end;

		end;

/* check that at least one name was given */

		if ^some_relation_seen & error_code = 0 then do;
			args_finished = "1"b;
			error_code = error_table_$noarg;
			call com_err_ (error_code, caller_name, "^/^a",
			     "No relation name(s) given with the ""-relation"" control argument.");
		     end;

	     end;

     end;

process_path_arg: procedure ();

/* routine to verify the database model path or submodel path
   argument, that supplies the view for access information.
   Only one path argument is allowed */

	if path_seen then do;

/* duplicate path name arguments given */

		args_finished = "1"b;
		error_code = mrds_error_$duplicate_opt;
		call com_err_ (error_code, caller_name, "^/^a ^a",
		     "The pathname argument was given more than once:", arg);
	     end;
	else do;

/* first pathname seen */

		path_seen = "1"b;

/* check for a valid path to a model or submodel */

		call mrds_dsl_get_version$get_path_info (arg, area_ptr,
		     mrds_path_info_structure_version, mrds_path_info_ptr, error_code);
		if mrds_path_info_ptr = null () then
		     abs_path = arg;
		else abs_path = mrds_path_info.absolute_path;
		if error_code ^= 0 then do;
			if error_code = mrds_error_$no_database then
			     error_code = mrds_error_$no_model_submodel;

			args_finished = "1"b;
			call com_err_ (error_code, caller_name, "^/^a^a^a",
			     "Unable to find database information using the path """, abs_path, """.");
		     end;

/* check for a supported version model/submodel,
   old version database will not work unless they had been
   opened for exclusive update at least one,
   and if there are any other old version databases already open. */

		else if (mrds_path_info.type.model | mrds_path_info.type.submodel) &
			mrds_path_info.mrds_version < 4 then do;
			args_finished = "1"b;
			error_code = mrds_error_$version_not_supported;
			call com_err_ (error_code, caller_name, "^/^a^a^a",
			     "The path """, abs_path,
			     """ is to a database or submodel of version less than 4.");
		     end;
		else do;

/* good path, use it to get an opening index */

			call mrds_dsl_open (abs_path, db_index, retrieval_mode, error_code);
			if error_code ^= 0 then do;
				args_finished = "1"b;
				call com_err_ (error_code, caller_name, "^/^a^a^a",
				     "The database could not be opened to obtain view information using the path """,
				     abs_path, """.");
			     end;
			else do;

/*  get resultant model pointers */

				call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);
				if dbcb_ptr = null () then do;
					args_finished = "1"b;
					error_code = mrds_error_$invalid_db_index; /* logic error if this happens */
					call com_err_ (error_code, caller_name, "^/^a",
					     "Program LOGIC ERROR, database opening index gave null resultant model pointer.");
				     end;
				else do;

					rdbi_ptr = dbcb.rdbi_ptr;
				     end;

			     end;

		     end;
	     end;

     end;

display_access: procedure ();

/* routine to display the relation and attribute
   access details for the given view supplied by the caller
   first, get the access info for all relations in this view */

	call mrds_dsl_get_relation_list (db_index, area_ptr,
	     mrds_relation_list_structure_version, mrds_relation_list_ptr, error_code);
	if error_code ^= 0 then
	     call com_err_ (error_code, caller_name, "^/^a^a^a",
		"Unable to get the relation information using the path """, abs_path, """.");
	else do;

/* output details for the verbose format */

		if long_format then do;
			call ioa_ ("^/Database path:  ^a^/^6xversion:  ^d",
			     rm_db_info.db_path, rm_db_info.db_version);
			if rm_db_info.mdbm_secured then
			     call ioa_ ("^16xDatabase is in a secure state.");
			if dbcb.dsm_sw then
			     call ioa_ ("^/Submodel path:  ^a^/^6xversion:  ^d",
				rm_db_info.sm_path, rm_db_info.sm_version);
			call ioa_ ("^/Relation  Attribute^4-System^-MRDS^-Effective"); /* output header */
		     end;

/* gather attribute access information for each relation
   in the path provided view specified by the user,
   or only the subset in his relation list */

		if all_relations then
		     relation_count = mrds_relation_list.num_rels_in_view;
		else relation_count = relation_list_length;

		do i = 1 to relation_count while (error_code = 0);

		     if all_relations then do;
			     j = i;		/* use definition order */
			     found = "1"b;
			end;
		     else do;

/* make sure we have a good relation name from the user's -relation option
   by finding the relation name in the rmds_relation_list array */

			     if i = 1 then
				relation_ptr = relation_list_ptr;
			     else relation_ptr = relation.next;

			     found = "0"b;
			     done = "0"b;
			     j = 1;
			     do while (^done);	/* find the value of j to use */

				if relation.name = mrds_relation_list.relation (j).submodel_name then
				     done, found = "1"b;
				else if j < mrds_relation_list.num_rels_in_view then
				     j = j + 1;
				else done = "1"b;
			     end;

			     if ^found then
				call ioa_ ("^/^a^a^a", /* non-fatal error, keep going */
				     "The relation name """, relation.name,
				     """ is unknown in this view of the database.");
			end;

		     if found then do;

/* get the attribute access info for this relation */

			     call mrds_dsl_get_attribute_list (db_index,
				rtrim (mrds_relation_list.relation (j).submodel_name),
				area_ptr, mrds_attribute_list_structure_version, mrds_attribute_list_ptr, error_code);
			     if error_code ^= 0 then
				call com_err_ (error_code, caller_name, "^/^a^a^a",
				     "Unable to obtain the attribute access information for relation """,
				     mrds_relation_list.relation (j).submodel_name, """.");
			     else do;

/* good relation and attribute access info obtained,
   now we can display it according to the long/brief options
   NOTE: relation names longer than 50, and attribute
   names longer than 40 characters are truncated to that length
   This is done to get all info on one "screen" width, for the more common shorter names.
   first, output the relation access */

				     if long_format then
					call ioa_ ("^/^50a^1x^2a^-^1x^2a^-^2x^2a",
					     mrds_relation_list.relation (j).submodel_name, /* output rel name and it's access */
					     mrds_relation_list.relation (j).system_acl,
					     mrds_relation_list.relation (j).mrds_access,
					     mrds_relation_list.relation (j).effective_access);
				     else call ioa_ ("^/^50a^1x^2a",
					     mrds_relation_list.relation (j).submodel_name,
					     mrds_relation_list.relation (j).effective_access);

/* display all attributes for this relation */

				     do k = 1 to mrds_attribute_list.num_attrs_in_view;

					if long_format then
					     call ioa_ ("^-^40a^1x^2a^-^1x^2a^-^2x^2a",
						mrds_attribute_list.attribute (k).submodel_name,
						mrds_attribute_list.attribute (k).system_acl,
						mrds_attribute_list.attribute (k).mrds_access,
						mrds_attribute_list.attribute (k).effective_access);
					else call ioa_ ("^-^40a^1x^2a", mrds_attribute_list.attribute (k).submodel_name,
						mrds_attribute_list.attribute (k).effective_access);
				     end;
				end;
			end;
		end;
	     end;
     end;

clean_up: procedure ();

/* routine to clean up after a quit-release or an error */

	if area_ptr ^= null () then do;
		call release_temp_segment_ (caller_name, area_ptr, discard);
		area_ptr = null ();
	     end;

	if db_index ^= 0 then do;
		call mrds_dsl_close (db_index, discard);
		db_index = 0;
	     end;

	recursive_call = "0"b;

     end;

	declare abs_path		 char (200);	/* absolute pathname of model or submodel */
	declare all_relations	 bit (1);		/* on => do all rels in view */
	declare area_ptr		 ptr;		/* points to work space */
	declare arg		 char (arg_len) based (arg_ptr); /* input argument */
	declare arg_count		 fixed bin;	/* current arg under inspection */
	declare arg_len		 fixed bin (21);	/* lengh of input arg */
	declare arg_ptr		 ptr;		/* points to input argument */
	declare args_finished	 bit (1);		/* on => all args seen, or error */
	declare caller_name		 char (32) init ("display_mrds_db_access") int static options (constant); /* name of calling routine */
	declare cleanup		 condition;	/* signaled upon quit/release */
	declare com_err_		 entry options (variable); /* reports errors */
	declare cu_$af_arg_count	 entry (fixed bin, fixed bin (35)); /* gets arg count/call type */
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); /* gets Nth arg */
	declare db_index		 fixed bin (35);	/* database opening index */
	declare discard		 fixed bin (35);	/* ignored error code */
	declare done		 bit (1);		/* loop control for relation name search */
	declare mrds_dsl_close	 entry options (variable); /* closes databases */
	declare mrds_dsl_open	 entry options (variable); /* opens a database through model or submodel */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare error_table_$bad_arg	 fixed bin (35) ext;/* null input arg */
	declare error_table_$badopt	 fixed bin (35) ext;/* unknown control arg */
	declare error_table_$noarg	 fixed bin (35) ext;/* missing argument */
	declare error_table_$not_act_fnc fixed bin (35) ext; /* should get this normally */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* not minimum of 1 arg */
	declare found		 bit (1);		/* on => known relation name supplied, and it's index found */
	declare get_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* gets temp segs */
	declare i			 fixed bin;	/* current count of relations displayed */
	declare ioa_		 entry options (variable); /* does output display */
	declare j			 fixed bin;	/* index into the relation_list structure */
	declare k			 fixed bin;	/* index into the attribute_list structure */
	declare last_relation_ptr	 ptr;		/* points to last relation in list */
	declare last_relation_seen	 bit (1);		/* on => exit relation name loop */
	declare long_format		 bit (1);		/* on => display all access info */
	declare mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* gets r-model ptr from index */
	declare mrds_dsl_get_attribute_list entry (fixed bin (35), char (*),
				 ptr, fixed bin, ptr, fixed bin (35)); /* gets attrs in view of rel */
	declare mrds_dsl_get_relation_list entry (fixed bin (35), ptr, fixed bin, ptr, fixed bin (35)); /* gets rels in view */
	declare mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	declare mrds_error_$duplicate_opt fixed bin (35) ext; /* path arg given > 1 time */
	declare mrds_error_$invalid_db_index fixed bin (35) ext; /* caused by logic error */
	declare mrds_error_$no_database fixed bin (35) ext static;
	dcl     mrds_error_$no_model_submodel fixed bin (35) ext static;
	declare mrds_error_$no_recursion fixed bin (35) ext; /* recursion not allowed */
	declare mrds_error_$version_not_supported fixed bin (35) ext; /* not version 4 db */
	declare nargs		 fixed bin;	/* number of arguments presented */
	declare path_seen		 bit (1);		/* on => path name argument given */
	declare recursive_call	 bit (1) int static init ("0"b); /* on => attempt to use recursion */
	declare relation_count	 fixed bin;	/* number of relations to be displayed */
	declare relation_list_length	 fixed bin;	/* number of relations in -relation list  */
	declare relation_list_ptr	 ptr;		/* points to head of relation list */
	declare relation_name_length_init fixed bin (21); /* initial value for name length allocation */
	declare relation_ptr	 ptr;		/* points to relation list element */
	declare release_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* frees temp segs */
	declare retrieval_mode	 fixed bin int static options (constant) init (1); /* lowest opening mode */
	declare some_relation_seen	 bit (1);		/* on => at least one relation name given */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
	declare work_area		 area (sys_info$max_seg_size) based (area_ptr); /* space for temp storage */
	declare (addr, empty, fixed, null, rel, substr, rtrim) builtin;
	declare 1 relation		 based (relation_ptr), /* saved relation name for -relation options */
		2 next		 ptr,		/* points to next in list */
		2 name_length	 fixed bin (21),	/* length of the relation name */
		2 name		 char (relation_name_length_init refer (relation.name_length)); /* relation's name */

%include mrds_dbcb;
%page;
%include mdbm_rm_db_info;
%page;
%include mrds_path_info;
%page;
%include mrds_relation_list;
%page;
%include mrds_attribute_list;
%page;

     end;




		    display_mrds_db_population.pl1  10/16/86  1550.1r w 10/16/86  1143.7      330291



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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


/****^  HISTORY COMMENTS:
  1) change(85-11-17,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-04-19 by Thanh
     Nguyen. (see mrds #136)
                                                   END HISTORY COMMENTS */


display_mrds_db_population:
dmdbp:
dmdp:
     procedure ();

/* DESCRIPTION:

   This is a utility routine for MRDS  databases,  it  displays  the
   current  population  of  the relations in a database, and  in the
   long version, a list of the indexed  attributes and the number of
   tuples selected for each index.  It  can  not  display  secondary
   index information for  version <= 3 databases. Also, version <= 3
   databases  must  have been  opened  for exclusive update at least
   once prior to calling  this routine. For version 4 databases that
   are secured, the  path  must be to a secured submodel if the user
   is not a DBA. Arguments may be given in any order, but  the  path
   must come before the -relation argument.  Control   arguments can
   be over-ridden, with the last taking effect.




   PARAMETERS:

   database_path - - (input) the relative pathname of  the  database
   model  or  submodel  view  whose  population statistics are to be
   displayed.

   -brief, -bf - - (input) control argument,  to  limit  display  to
   relation  names,  and  their  current  tuple  count.  This is the
   default.

   -long, -lg - - (input) control argument to cause the  display  to
   contain  all  information  available  from vfile_status_ for each
   relation in the view, or specified in the -relation option.

   -relation rel_name 1 ... rel_nameN - - (input)  control  argument
   to  cause  only  the specified relations to have their statistics
   displayed according to the -long/-brief controls. The default  is
   to display all relations in the view.




   HISTORY:

   80-05-15 Jim Gray : Originally written.

   81-04-11 Jim Gray : modified for release in bound mrds as follows:
   1) extended the interface to accept submodel views
   2) added a -long option control arg
   3) made the default -brief
   4) added the -relation control arg
   5) for a secured db, limited non-DBA to secured submodel
   6) set needed access for a DBA
   7) changed the output formating

   81-06-04  Davids:  removed  references  to  the   user   external
   interface  (both  the mrds_dsm_dsmd and associated include files)
   and  replaced   them   with   mrds'   internal   interface.   The
   model_relations         and        dsm_relation_names        (now
   mrds_dsm_relation_names) were all being referenced by  overlaying
   the model_relation structure. Since they all have the same format
   this was working but it was changed so  that  each  structure  is
   referenced separately to improve maintainability.
   
   81-09-15 Rickie E.  Brinegar: Added substr to the assignment of abs_path to
   db_path  and  changed  action_type from char (12) to char (14) to avoid the
   substring condition.

   82-10-8 D. Woodka : Modified for DMS conversion. Changed to call 
   mu_rel_statistics return_tuple_count and return_index_attr_dups.
   Deleted the output of:  vfile version,  number of bytes in vfile
   records, number of  vfile keys and their total bytes,  number of
   duplicate keys  and their bytes,  tree height,  number of pages, 
   amount of free  space and number of  updates.  Added output of a
   list of the  indexed  attributes and  average  number  of tuples 
   expected to be selected (for -long display,version 4 databases).

   82-12-21  Roger Lackey : Added rtrim to several error messages and 
   removed unused dcls added undefined builtin dcls.

   83-02-04 Davids: Added transaction include files. Modified  the  internal
   routine error  not to call the clean_up procedure but to just go to exit.
   Changed the normal return sequence to  call  clean_up  after  the
   exit   label   instead  of  before  and  added  the  mrds  finish
   transaction include file after the call to clean_up. This made it
   easier  to  add  the  finish  transaction  code and mstxn cleanup
   condition handler. Note that there is only 1 transaction for  the
   entire  database, this means that if the transaction dies for any
   reason the rest of the relations will not be processed. It  would
   be better to have a transaction for each relation but it would be
   much slower.   

   83-02-14 Davids: modified to use the new db_type_flags in the db_model
   structure instead of the old numeric db_type.

   83-05-24 Mike Kubicar : Modified to not call mu_rel_statistics to get
   the tuple count.
*/
%page;
/* initialize */

	error_code = 0;
	dbm_ptr = null ();				/* model not open yet */
	submodel_open = "0"b;
	area_ptr = null ();
	long_format = "0"b;				/* default to -brief option */
	all_relations = "1"b;			/* default to showing all relations in the view */
	path_seen = "0"b;
	mstxn_txn_id = "0"b;

	call cu_$af_arg_count (nargs, error_code);	/* make sure we weren't called as an active function */
	if error_code ^= error_table_$not_act_fnc then
	     call error (error_code, "Command called as an active function,
                    or unable to obtain argument count.");
	error_code = 0;

	on cleanup begin;
		call mstxn_cleanup;
		call clean_up ();
	     end;

	on any_other call mstxn_any_other;

/* check for a good call */

	if nargs < 1 then do;
		error_code = error_table_$wrong_no_of_args;
		call error (error_code, "Usage:  dmdbp  path  {-brief|-long} {-relation rel_name1 ... rel_nameN}");

	     end;

/* get some work space */

	call get_temp_segment_ (caller_name, temp_seg_ptr, error_code);
	if error_code ^= 0 then
	     call error (error_code, "Unable to get a temp segment.");
	area_ptr = temp_seg_ptr;
	area_ptr -> work_area = empty ();

/* gather all the arguments */

	arg_count = 1;
	args_finished = "0"b;
	do while (^args_finished);

/* get this argument, and decide if it is a control argument or not */

	     call cu_$arg_ptr (arg_count, arg_ptr, arg_len, error_code);
	     if error_code ^= 0 then do;
		     args_finished = "1"b;
		     call error (error_code, "While getting argument.");
		end;


/* check for a null argument */

	     if arg_len < 1 then do;
		     args_finished = "1"b;
		     error_code = error_table_$bad_arg;
		     call error (error_code, "While getting argument.");
		end;

/* control arguments begin with a hyphen */

	     if substr (arg, 1, 1) = "-" then
		call process_control_arg ();
	     else call process_path_arg ();

/* advance to the next argument */

	     if arg_count < nargs then
		arg_count = arg_count + 1;
	     else args_finished = "1"b;

	end;

/* check that we got a  pathname argument */

	if error_code = 0 then do;

		if ^path_seen then do;
			error_code = error_table_$noarg;
			call error (error_code, "No pathname argument was given.");
		     end;
%page;
		if mrds_path_info.mrds_version <= 3
		then mstxn_transactions_needed = "0"b;
		else mstxn_transactions_needed = db_model.db_type_flags.transactions_needed;

%include mrds_start_transaction;

		if mstxn_code ^= 0
		then call error (mstxn_code, "Unable to start a transaction");

/* go display the requested status */

		call display_db_status ();

	     end;

exit:
	call clean_up ();

	mftxn_code = error_code;

%include mrds_finish_transaction;

	if mftxn_code ^= 0
	then call com_err_ (mftxn_code, caller_name, "Unable to finish transaction");

	return;
%page;
should_rollback: proc () returns (bit (1));

/* This routine is required by the transaction include files.  It is called
   when a transaction is in an error state.  The convention is that returning
   "0"b directs that the transaction be aborted and "1"b directs that the
   transaction be rolled back.  At this point, the only reasonable action in
   such situations seems to be to abort the transaction, so we always... */

	return ("0"b);

     end should_rollback;

restore_significant_data: proc ();

/* This routine is required by the transaction include files.  It is called
   when a transaction is aborted or rolled back.  The intent is to return
   non-FAMIS storage to the appropriate state to reflect the backing out of 
   whatever FAMIS changes were made. */

	return;

     end restore_significant_data;
%page;
process_control_arg:
     procedure ();

/* routine to determine if user has given one of the legal
   control arguments of brief, long, or relation REL_NAME
   and to save the corresponding information.
   The logic is such as to allow duplicate control arguments
   to override each other, with the last given taking effect. */

/* BRIEF */

	if arg = "-brief" | arg = "-bf" then long_format = "0"b; /* use short display format */

/* LONG */

	else if arg = "-long" | arg = "-lg" then long_format = "1"b; /* use verbose display format */

/* UNKNOWN */

	else if arg ^= "-relation" then do;
		args_finished = "1"b;
		error_code = error_table_$badopt;
		call error (error_code, "The control argument """ || arg ||
		     """ is not supported by this command.");
	     end;

/* BAD ORDER */

	else if ^path_seen then do;
		args_finished = "1"b;
		error_code = error_table_$noarg;
		call error (error_code, "The pathname argument did not appear before the ""-relation"" option.");
	     end;

	else do;

/* RELATION LIST */

		last_relation_seen = "0"b;
		some_relation_seen = "0"b;
		all_relations = "0"b;		/* only do the given relations */
		last_relation_ptr, relation_list_ptr = null ();
		arg_count = arg_count + 1;
		relation_list_length = 0;

/* go through all relation names given */

		do while (^last_relation_seen);

		     call cu_$arg_ptr (arg_count, arg_ptr, arg_len, error_code);
		     if error_code ^= 0 then do;
			     args_finished, last_relation_seen = "1"b;
			     call error (error_code, "While getting a relation name argument");
			end;
		     if arg_len < 1 then do;
			     args_finished, last_relation_seen = "1"b;
			     error_code = error_table_$bad_arg;
			     call error (error_code, "While getting a relation name argument");
			end;
		     else if substr (arg, 1, 1) = "-" then do;
			     last_relation_seen = "1"b; /* end of list of relation names */
			     arg_count = arg_count - 1; /* reset for processining remaining args */
			end;
		     else do;

/* first relation name seen */

			     some_relation_seen = "1"b;

/* gather this name for the list */

			     relation_name_length_init = arg_len;
			     allocate relation set (relation_ptr) in (work_area);
			     relation.name_length = relation_name_length_init;
			     relation.name = arg;	/* remember this relation's name */

/* add the name at the end of the list to maintain order */

			     relation.next = null ();
			     if last_relation_ptr = null () then
				relation_list_ptr = relation_ptr;
			     else last_relation_ptr -> relation.next = relation_ptr;
			     last_relation_ptr = relation_ptr;
			     relation_list_length = relation_list_length + 1;

/* advance to the next name given */

			     if arg_count < nargs then
				arg_count = arg_count + 1;
			     else last_relation_seen = "1"b;

			end;

		end;

/* check that at least one name was given */

		if ^some_relation_seen & error_code = 0 then do;
			args_finished = "1"b;
			error_code = error_table_$noarg;
			call error (error_code, "No relation name(s) given with the ""-relation"" control argument.");
		     end;

	     end;

     end process_control_arg;
%page;
process_path_arg:
     procedure ();

/* routine to verify the database model path or submodel path
   argument, that supplies the view for status information.
   Only one path argument is allowed */

	if path_seen then do;

/* duplicate path name arguments given */

		args_finished = "1"b;
		error_code = mrds_error_$duplicate_opt;
		call error (error_code, "The pathname argument was given more than once: " || arg);
	     end;
	else do;

/* first pathname seen */

		path_seen = "1"b;

/* check for a valid path to a model or submodel */

		call mrds_dsl_get_version$get_path_info (arg, area_ptr,
		     mrds_path_info_structure_version, mrds_path_info_ptr, error_code);
		if mrds_path_info_ptr = null () then
		     abs_path = arg;
		else abs_path = mrds_path_info.absolute_path;
		if error_code ^= 0 then do;
			args_finished = "1"b;
			call error (error_code, "Unable to find database information using the path """ || rtrim (abs_path) || """.");
		     end;

/* good path, if this is a submodel path, then get the
   database path from the submodel header */

		if mrds_path_info.type.model then
		     db_path = substr (abs_path, 1, 168);
		else do;				/* submodel view */

/* open the specified submodel */

			call mrds_dsm_open$read (rtrim (abs_path), submodel_iocb_ptr,
			     error_code);
			if error_code ^= 0 then do;
				args_finished = "1"b;
				call com_err_ (error_code, "Unable to open the submodel using the path """ || rtrim (abs_path) || """.");
			     end;

/* let them know we have the submodel open */

			submodel_open = "1"b;
			call ioa_ ("^/Displaying version ^d submodel:  ^a",
			     mrds_path_info.mrds_version, abs_path);

/* get the database path from the submodel header record */

			call mrds_dsm_read_header$db_path (submodel_iocb_ptr, db_path,
			     error_code);
			if error_code ^= 0 then do;
				args_finished = "1"b;
				call error (error_code,
				     "Unable to get the database path from the header for the submodel """ || rtrim (abs_path) || """.");
			     end;

		     end;

	     end;

/* for version 4 secured databases, make sure non-DBA's
   are using a secured submodel view of the database */

	if error_code = 0 then
	     call check_secured_view ();

     end process_path_arg;
%page;
check_secured_view:
     procedure ();

/* routine to check for a version 4 database that has been secured,
   and for a non-DBA user not looking through a secure submodel */

	if mrds_path_info.type.model then
	     db_info_ptr = mrds_path_info_ptr;
	else do;

		call mrds_dsl_get_version$get_path_info (rtrim (db_path), area_ptr,
		     mrds_path_info_structure_version, db_info_ptr, error_code);
		if error_code ^= 0 then do;
			args_finished = "1"b;
			call error (error_code,
			     "Unable to get information about the database """
			     || rtrim (db_path) || """ for the submodel """ || rtrim (abs_path) || """.");
		     end;

	     end;

	if error_code = 0 then do;

		if db_info_ptr -> mrds_path_info.mrds_version = 4 then do;

			call mrds_dm_open (db_path, mode, dbm_ptr, error_code);
			if error_code ^= 0 then do;
				args_finished = "1"b;
				call error (error_code, "Unable to open the data model for the database """ || rtrim (db_path) || """.");
			     end;

			call mrds_dm_db_secured$get_secured_status (dbm_ptr,
			     area_ptr, database_state_structure_version,
			     database_state_ptr, error_code);
			if error_code ^= 0 then do;
				args_finished = "1"b;
				call error (error_code,
				     "Unable to get the secured state for the database """ || rtrim (db_path) || """.");
			     end;


			if database_state.secured then do;

				call mrds_dm_authorization$get_user_class (rtrim (db_path),
				     area_ptr, mrds_authorization_structure_version,
				     mrds_authorization_ptr, error_code);
				if error_code ^= 0 then do;
					args_finished = "1"b;
					call error (error_code,
					     "Unable to determine if the user is a DBA for the database """ || rtrim (db_path) || """.");
				     end;


				if ^mrds_authorization.administrator then do;

					bad_path = "0"b;
					if mrds_path_info.type.model then
					     bad_path = "1"b;
					else do;
						call expand_pathname_ (abs_path, sm_dir, sm_name,
						     error_code);
						if error_code ^= 0 then do;
							args_finished = "1"b;
							call error (error_code,
							     "Unable to expand the submodel path """ || rtrim (abs_path) || """.");
						     end;
						else do;

							if ^mrds_dm_secured_submodel (rtrim (db_path),
							     sm_dir, sm_name) then
							     bad_path = "1"b;
						     end;

					     end;

					if bad_path then do;
						args_finished = "1"b;
						error_code = mrds_error_$inc_secure_open;
						call error (error_code,
						     "The submodel """ || rtrim (abs_path) ||
						     """ is not a secure submodel, but the database """ || rtrim (db_path) || """ has been secured.");
					     end;

				     end;

			     end;

		     end;

	     end;

     end check_secured_view;
%page;
display_db_status:
     procedure ();

/* routine to output all requested database info */

/* set up the path to the relation vfiles, based on database version */

/* get the relations from the model or submodel   depending upon how we were called */

	call get_relation_info ();


/* gather the status information for each relation in the view specified by the user,
   or only the subset in his relation list */

	if all_relations then
	     relation_count = number_of_relations;
	else relation_count = relation_list_length;


/* output a header for the long or short format */

	if (^long_format | db_info_ptr -> mrds_path_info.mrds_version < 4) then
	     call ioa_ ("^/RELATION^4-TUPLES^/");
	else
	     call ioa_ ("^/RELATION^-TUPLES^-INDEX^-AVE TUPLES SELECTED^/");

	if mrds_path_info.mrds_version >= 4 then do;
		if db_model.db_type_flags.vfile_type
		then vfile = "1"b;			/* if this is a vfile database */
		else vfile = "0"b;			/* if this is a page file database */
	     end;
						/* go through all specified relations */

	do i = 1 to relation_count while (error_code = 0);

	     if all_relations then do;
		     j = i;			/* use definition order */
		     found = "1"b;
		end;
	     else do;

/* make sure we have a good relation name from the user's -relation option
   by finding the relation name in the model_relations or submodel_relations array */

		     if i = 1 then
			relation_ptr = relation_list_ptr;
		     else relation_ptr = relation.next;

		     found = "0"b;
		     done = "0"b;
		     j = 1;
		     do while (^done);		/* find the value of j to use */

			if mrds_path_info.type.model then
			     rel_name = model_relations (j).relation_name;
			else rel_name = mrds_dsm_relation_names (j).relation;
			if relation.name = rel_name then
			     done, found = "1"b;
			else if j < number_of_relations then
			     j = j + 1;
			else done = "1"b;
		     end;

		     if ^found then
			call ioa_ ("^/^a^a^a",	/* non-fatal error, keep going */
			     "The relation name """, relation.name,
			     """ is unknown in this view of the database.");
		end;

	     if found then do;

		     if mrds_path_info.type.model then do;
			     rel_name = model_relations.relation_name (j);
			     model_rel_name = model_relations.relation_name (j);

/* get relation id */

			     if db_info_ptr -> mrds_path_info.mrds_version >= 4 then do;
				     file_model_name = rtrim (mr_ptr -> model_relations.relation_name (j)) || ".m";
				     call hcs_$initiate (db_path, file_model_name, "", 0, 0, fm_ptr, error_code);
				     if fm_ptr = null then call error (mrds_error_$no_model_rel,
					     rtrim (mr_ptr -> model_relations.relation_name (j)));
				     ri_ptr = ptr (fm_ptr, file_model.rel_ptr);
				     rel_id = rel_info.id;

				end;
			end;

		     else do;			/* get the model name for the submodel alias */
			     rel_name = mrds_dsm_relation_names (j).relation;

			     call mrds_dsm_read_relation (rtrim (mrds_dsm_relation_names (j).relation),
				area_ptr, relation_block_ptr, submodel_iocb_ptr, error_code);
			     if error_code ^= 0 then
				call error (error_code,
				     "Unable to get the model name for the submodel relation """
				     || mrds_dsm_relation_names.relation (j) || """.");

			     if db_info_ptr -> mrds_path_info.mrds_version >= 4 then do;
				     file_model_name = rtrim (relation_block_ptr -> relation_block.dm_rel_name) || ".m";
				     call hcs_$initiate (db_path, file_model_name, "", 0, 0, fm_ptr, error_code);
				     if fm_ptr = null then call error (mrds_error_$no_model_rel,
					     rtrim (mr_ptr -> model_relations.relation_name (i)));
				     ri_ptr = ptr (fm_ptr, file_model.rel_ptr);
				     rel_id = rel_info.id;
				end;

			     model_rel_name = relation_block_ptr -> relation_block.dm_rel_name;


			end;

/* go display the relation status */

		     call display_relation_status ();

		end;

	end;

     end display_db_status;
%page;
get_relation_info:
     procedure ();

/* routine to get the relation names from either the model
   or submodel, depending upon the view we were called with */

	if mrds_path_info.type.model then do;

/* open the data model for retrieval */

		if dbm_ptr = null () then do;		/* not open yet */
			call mrds_dm_open (db_path, mode, dbm_ptr, error_code);
			if error_code ^= 0 then
			     call error (error_code,
				"Unable to open the data model for database """ ||
				rtrim (db_path) || """.");
		     end;

/* let them know we got it open */

		call ioa_ ("^/^a ^d ^a ^a", "Displaying version",
		     db_info_ptr -> mrds_path_info.mrds_version, "data model:",
		     db_path);

/* get the names of all relations in the database */

		call mrds_dm_get_relations (dbm_ptr, addr (work_area),
		     mr_ptr, error_code);
		if error_code ^= 0 then
		     call error (error_code,
			"Unable to get the relation names from the model for database """
			|| rtrim (db_path) || """.");
		else number_of_relations = mr_ptr -> model_relations.nrels;



	     end;

	else do;					/* submodel view given */

/* get the submodel names in this view */

		call mrds_dsm_get_relation_names (area_ptr, mrds_dsm_relation_names_ptr,
		     submodel_iocb_ptr, error_code);
		if error_code ^= 0 then
		     call error (error_code,
			"Unable to get the relations in the submodel """ ||
			rtrim (abs_path) || """.");
		else number_of_relations =
			mrds_dsm_relation_names_ptr -> mrds_dsm_relation_names.nrels;

	     end;

     end get_relation_info;
%page;
display_relation_status:
     procedure ();

	if mrds_path_info.mrds_version <= 3 then do;
		info_ptr = addr (indx_info);
		call vfile_status_ (rtrim (db_path) || ">rel_dir", model_rel_name, info_ptr, error_code);

		if error_code ^= 0 then call error (error_code,
			"Unable to get status information on relation """ || rtrim (rel_name) || """ in the database """ || rtrim (db_path) || """ . ");
		num_tuples = indx_info.non_null_recs;
	     end;
	else do;
		if vfile then do;
			call vfile_relmgr_$open (db_path, model_rel_name,
			     rel_opening_id, error_code);
			if error_code ^= 0
			then call error (error_code, "Could not open relation " || rtrim (model_rel_name) || ".");
			call vfile_relmgr_$create_cursor (rel_opening_id,
			     area_ptr, relation_cursor_ptr, error_code);
			if error_code ^= 0
			then call error (error_code, "Could not create a cursor for relation " || rtrim (model_rel_name) || ".");
			call vfile_relmgr_$get_count (relation_cursor_ptr,
			     null (), num_tuples, error_code);
			if error_code ^= 0
			then call error (error_code, "Could not get count of tuples for relation "
				|| rtrim (model_rel_name) || ".");
		     end;
		else do;
			call relation_manager_$open (db_path, model_rel_name,
			     rel_opening_id, error_code);
			if error_code ^= 0
			then call error (error_code, "Could not open relation " || rtrim (model_rel_name) || ".");
			call relation_manager_$create_cursor (rel_opening_id,
			     area_ptr, relation_cursor_ptr, error_code);
			if error_code ^= 0
			then call error (error_code, "Could not create a cursor for relation " || rtrim (model_rel_name) || ".");
			call relation_manager_$get_count (relation_cursor_ptr,
			     null (), num_tuples, error_code);
			if error_code ^= 0
			then call error (error_code, "Could not get count of tuples for relation "
				|| rtrim (model_rel_name) || ".");
		     end;
	     end;

	if ^long_format then call ioa_ ("^40a^d", rel_name, num_tuples);

	else do;					/* if this is the long version */

		if db_info_ptr -> mrds_path_info.mrds_version < 4 then
		     call ioa_ ("^40a^d", rel_name, num_tuples);

		else do;

			call ioa_ ("^a^-^d", rel_name, num_tuples);

/* display attribute information */

			do ai_ptr = ptr (fm_ptr, rel_info.attr_ptr)
			     repeat ptr (fm_ptr, attr_info.fwd_thread)
			     while (rel (ai_ptr) ^= NULL_OFFSET);

			     if attr_info.index_attr then do;
				     found = "0"b;
				     if mrds_path_info.type.submodel then
					do k = 1 to relation_block.no_rb_attributes while (^found);
					     if attr_info.name = relation_block.attribute_info (k).dm_attr_name then do;
						     found = "1"b;
						     index_name = relation_block.attribute_info (k).dsm_attr_name;

						end;
					end;
				     else do;
					     found = "1"b;
					     index_name = attr_info.name;

					end;
				     if found then do;
					     if vfile then
						call vfile_relmgr_$get_duplicate_key_count (relation_cursor_ptr,
						     attr_info.index_id, ALL_THE_ATTRIBUTES, dup_count, error_code);
					     else
						call relation_manager_$get_duplicate_key_count (relation_cursor_ptr,
						     attr_info.index_id, ALL_THE_ATTRIBUTES, dup_count, error_code);
					     if error_code ^= 0
					     then call error (error_code, "Could not get duplicate count for index "
						     || rtrim (index_name) || ".");

					     if dup_count = num_tuples then ave_tuples = num_tuples;
					     else ave_tuples = num_tuples / (num_tuples - dup_count);
					     call ioa_ ("^2-^a^-^d", index_name, ave_tuples);

					end;
				end;
			end;
		     end;
	     end;

	if db_info_ptr -> mrds_path_info.mrds_version = 4 then do;
		if vfile then do;
			call vfile_relmgr_$destroy_cursor (relation_cursor_ptr,
			     area_ptr, error_code);
			if error_code ^= 0
			then call error (error_code, "Could not destroy a cursor for relation "
				|| rtrim (rel_name) || ".");
			call vfile_relmgr_$close (rel_opening_id, error_code);
		     end;
		else do;
			call relation_manager_$destroy_cursor (relation_cursor_ptr,
			     area_ptr, error_code);
			if error_code ^= 0
			then call error (error_code, "Could not destroy a cursor for relation "
				|| rtrim (rel_name) || ".");
			call relation_manager_$close (rel_opening_id, error_code);
		     end;
		if error_code ^= 0 then call error (error_code, "While closing the relation" || rel_name);
	     end;


     end display_relation_status;
%page;
error: proc (code, message);

/* Parameters */

	dcl     code		 fixed bin (35);
	dcl     message		 char (*);

	call com_err_ (code, caller_name, "^/^a", message);
	go to exit;

     end error;
%page;
clean_up:
     procedure ();

/* close the data model, if open */

	if dbm_ptr ^= null then do;
		call mrds_dm_close (dbm_ptr, discard);
		dbm_ptr = null ();
	     end;

	if submodel_open then do;
		call mrds_dsm_close$force (submodel_iocb_ptr);
		submodel_open = "0"b;
	     end;

	if area_ptr ^= null () then do;
		call release_temp_segment_ (caller_name, area_ptr, discard);
		area_ptr = null ();
	     end;
     end;
%page;
	dcl     abs_path		 char (200);	/* absolute pathname of model or submodel */
	dcl     ALL_THE_ATTRIBUTES	 fixed bin int static options (constant)
				 init (-1);	/* get_duplicate_key_count looks at all attributes in index */
	dcl     all_relations	 bit (1);		/* on => do all rels in view */
	dcl     area_ptr		 ptr;		/* points to work space */
	dcl     arg		 char (arg_len) based (arg_ptr); /* input argument */
	dcl     arg_count		 fixed bin;	/* current arg under inspection */
	dcl     arg_len		 fixed bin (21);	/* lengh of input arg */
	dcl     arg_ptr		 ptr;		/* points to input argument */
	dcl     args_finished	 bit (1);		/* on => all args seen, or error */
	dcl     ave_tuples		 fixed bin (35);
	dcl     bad_path		 bit (1);		/* on => non-dba not using secure submodel on secured db */
	dcl     caller_name		 char (32) init ("display_mrds_db_population") int
				 static options (constant); /* calling routine */
	dcl     cleanup		 condition;	/* signaled upon quit/release */
	dcl     any_other		 condition;
	dcl     com_err_		 entry options (variable); /* reports errors */
	dcl     cu_$af_arg_count	 entry (fixed bin, fixed bin (35)); /* gets arg count/call type */
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
						/* gets Nth arg */
	dcl     db_path		 char (168);	/* pathname of database */
	dcl     discard		 fixed bin (35);	/* ignored error error_code */
	dcl     mrds_dm_authorization$get_user_class
				 entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
						/* detects DBA */
	dcl     mrds_dm_db_secured$get_secured_status
				 entry (ptr, ptr, fixed bin, ptr, fixed bin (35));
						/* sets db secured state */
	dcl     mrds_dm_close	 entry (ptr, fixed bin (35)); /* closes data model */
	dcl     mrds_dm_get_relations	 entry (ptr, ptr, ptr, fixed bin (35));
						/* gets relation names */
	dcl     mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35));
						/* opens data model */
	dcl     mrds_dm_secured_submodel entry (char (*), char (*), char (*))
				 returns (bit (1)); /* checks for secured submodel */
	dcl     done		 bit (1);		/* loop control for relation name search */
	dcl     mrds_dsm_open$read	 entry (char (*), ptr, fixed bin (35));
	dcl     mrds_dsm_read_header$db_path entry (ptr, char (168), fixed bin (35));
	dcl     mrds_dsm_read_relation entry (char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_get_relation_names entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_close$force	 entry (ptr);
	dcl     submodel_iocb_ptr	 ptr init (null ());/* pointer to the submodel iocb */
	dcl     dup_count		 fixed bin (35);
	dcl     error_code		 fixed bin (35);	/* error status encoding */
	dcl     error_table_$bad_arg	 fixed bin (35) ext;/* null input arg */
	dcl     error_table_$badopt	 fixed bin (35) ext;/* unknown control arg */
	dcl     error_table_$noarg	 fixed bin (35) ext;/* missing argument */
	dcl     error_table_$not_act_fnc fixed bin (35) ext; /* should get this normally */
	dcl     error_table_$wrong_no_of_args fixed bin (35) ext; /* not minimum of 1 arg */
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     file_model_name	 char (32);
	dcl     found		 bit (1);		/* on => known relation name supplied, and it's index found */
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
						/* gets temp segs */
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	dcl     i			 fixed bin;	/* current count of relations displayed */
	dcl     index_name		 char (32);
	dcl     1 indx_info,			/* info structure for vfile status */
		2 info_version	 fixed bin init (1),
		2 type		 fixed bin init (4),
		2 records		 fixed bin (34),
		2 flags		 aligned,
		  3 lock_status	 bit (2) unal,
		  3 pad		 bit (34) unal,
		2 version		 aligned,
		  3 file_version	 fixed bin (17) unal,
		  3 program_version	 fixed bin (17) unal,
		2 action		 fixed bin,
		2 non_null_recs	 fixed bin (34),
		2 record_bytes	 fixed bin (34),
		2 free_blocks	 fixed bin,
		2 index_height	 fixed bin,
		2 nodes		 fixed bin,
		2 key_bytes	 fixed bin (34),
		2 change_count	 fixed bin (35),
		2 num_keys	 fixed bin (34),
		2 dup_keys	 fixed bin (34),
		2 dup_key_bytes	 fixed bin (34),
		2 reserved	 (1) fixed bin;
	dcl     info_ptr		 ptr;
	dcl     ioa_		 entry options (variable); /* does output display */
	dcl     j			 fixed bin;	/* index into the relation_list structure */
	dcl     k			 fixed bin;
	dcl     last_relation_ptr	 ptr;		/* points to last relation in list */
	dcl     last_relation_seen	 bit (1);		/* on => exit relation name loop */
	dcl     long_format		 bit (1);		/* on => display all status info */
	dcl     mode		 fixed bin init (2);/* retrieval */
	dcl     model_rel_name	 char (32);	/* name of the relation in the data model */
	dcl     mrds_dsl_get_version$get_path_info
				 entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_error_$duplicate_opt fixed bin (35) ext; /* path arg given > 1 time */
	dcl     mrds_error_$inc_secure_open fixed bin (35) ext; /* non-dba, secured db, un-secure submodel */
	dcl     mrds_error_$no_model_rel fixed bin (35) ext static;
	dcl     nargs		 fixed bin;	/* number of arguments presented */
	dcl     NULL_OFFSET		 int static bit (18) unal init ((18)"1"b) options (constant);
	dcl     num_tuples		 fixed bin (35);	/* number of tuples in relations */
	dcl     number_of_relations	 fixed bin;	/* number of relations in view */
	dcl     path_seen		 bit (1);		/* on => path name argument given */
	dcl     relation_id		 bit (36) aligned init ((36)"1"b);
	dcl     relation_cursor_ptr	 ptr;		/* Cursor to gather statistics */
	dcl     relation_manager_$create_cursor entry (bit (36) aligned, ptr, ptr, fixed bin (35));
	dcl     relation_manager_$destroy_cursor entry (ptr, ptr, fixed bin (35));
	dcl     relation_manager_$get_count entry (ptr, ptr, fixed bin (35), fixed bin (35));
	dcl     relation_manager_$get_duplicate_key_count entry (ptr, bit (36) aligned, fixed bin (17), fixed bin (35), fixed bin (35));
	dcl     relation_manager_$open entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     relation_manager_$close entry (bit (36) aligned, fixed bin (35));
	dcl     rel_id		 bit (36) aligned;
	dcl     rel_name		 char (64);	/* name of model or submodel relation */
	dcl     rel_opening_id	 bit (36) aligned;	/* opening id of the relation */
	dcl     relation_count	 fixed bin;	/* number of relations to be displayed */
	dcl     relation_list_length	 fixed bin;	/* number of relations in -relation list  */
	dcl     relation_list_ptr	 ptr;		/* points to head of relation list */
	dcl     relation_name_length_init fixed bin (21); /* initial value for name length allocation */
	dcl     relation_ptr	 ptr;		/* points to relation list element */
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
						/* frees temp segs */
	dcl     sm_dir		 char (168);	/* containing directory of submodel */
	dcl     sm_name		 char (32);	/* name of submodel msf */
	dcl     some_relation_seen	 bit (1);		/* on => at least one relation name given */
	dcl     submodel_open	 bit (1);		/* on => submodel has been opened */
	dcl     sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
	dcl     temp_seg_ptr	 ptr;
	dcl     db_info_ptr		 ptr;		/* used to point to second copy of path info structure */
	dcl     work_area		 area (sys_info$max_seg_size) based (area_ptr);
						/* space for temp storage */
	dcl     vfile		 bit (1);		/* set for a vfile database */
	dcl     vfile_relmgr_$create_cursor entry (bit (36) aligned, ptr, ptr, fixed bin (35));
	dcl     vfile_relmgr_$destroy_cursor entry (ptr, ptr, fixed bin (35));
	dcl     vfile_relmgr_$get_count entry (ptr, ptr, fixed bin (35), fixed bin (35));
	dcl     vfile_relmgr_$get_duplicate_key_count entry (ptr, bit (36) aligned, fixed bin (17), fixed bin (35), fixed bin (35));
	dcl     vfile_relmgr_$open	 entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     vfile_relmgr_$close	 entry (bit (36) aligned, fixed bin (35));
	dcl     vfile_status_	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     (addr, empty, fixed, null, substr, ptr, rel, rtrim) builtin;
	dcl     1 relation		 based (relation_ptr), /* saved relation name for -relation options */
		2 next		 ptr,		/* points to next in list */
		2 name_length	 fixed bin (21),	/* length of the relation name */
		2 name		 char (relation_name_length_init refer (relation.name_length));
						/* relation's name */
%page;
%include mdbm_db_model;
%page;
%include mdbm_file_model;
%page;
%include mrds_dsm_rel_block;
%page;
%include mrds_dsm_relation_names;
%page;
%include mrds_model_relations;
%page;
%include mrds_path_info;
%page;
%include mrds_authorization;
%page;
%include mrds_database_state;
%page;
     end;




		    display_mrds_db_status.pl1      10/23/86  1024.2r w 10/23/86  1009.0      318636



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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



display_mrds_db_status: dmdbs: proc;


/*
   .                       BEGIN_DESCRIPTION
   This commands provides the DBA with  (semi)  current  information
   about  the  status  of a data base obtained from the dbc segment.
   The information about dead processes reflects status  as  of  the
   last time the data base was opened.
   .                       END_DESCRIPTION
*/

/*
   .                       HISTORY
   Written by Oris Friesen, Summer 1978.

   Modified by Al Kepner, Feb  14,  1979  to  improve  diagnosis  of
   invalid control arguments.

   Modified by Al Kepner, Feb 14, 1979 to  accomodate  MR7.0  fscope
   mechanism.

   Modified by Jim Gray - - 21-June-80, to return no model,  instead
   of no model/submodl error message.

   80-12-08 Jim Gray : changed scope  mode  display  to  handle  r-u
   modes   for   version   4   dbc,  and  new  read/modify_attr  and
   append/delete_tuple  modes  for  version  5  dbc   and   fil_list
   structures.  It  also  can  now  get a pointer to either "dbc" or
   "db,control" named segment for finding the dbc structure. This is
   done   via   the  new  mu_concurrency_control$get_control_segment
   routine. Also added dbc structure version to header output.

   80-12-12 Jim Gray : Improved control  arg  information  in  usage
   message.

   81-01-31      Jim      Gray      :       added       use       of
   mrds_dsl_get_version$get_path_info,  and new interface overcoming
   short comings of the dsl_$get_db_version interface.

   81-02-03 Jim Gray :  changed  format  of  output  display  to  be
   arranged with the colons columnized for easier reading.

   81-02-04 Jim Gray : made default display  equivalent  to  Lindsey
   Spratt's  -terse  option,  that displays things that are not in a
   normal state, with info inbetween the -brief and -long option.

   81-02-11 Jim Gray : extended, to allow submodel paths to be given
   to this command, in which case, the actual db path is gotten from
   the submodel header, and only the relations in the submodel  view
   have their scope modes shown.

   81-02-12 Jim Gray : added check to see that when the database  is
   in  the  secured  state,  that if the user is not a DBA, that his
   path given is to a submodel residing in the  submodel  dir  under
   the database.

   81-06-03 Davids: changed the  calls  of  mrds_dsm_dsmd$*  to  the
   appropriate mrds_dsm_* calls, also changed the corresponding data
   structures (user interface to internal mrds interface).  Modified
   the  call  dmdbs_v1 to occur only if the input path was that of a
   version 3 datamodel and to report an error if it was a  submodel,
   (v1   does   not  support  submodels).  Removed  declarations  of
   unreferenced variables.

   82-05-07 Woodka: Changed to indicate if database is inconsistent,
   and give an appropriate error message. Changed to indicate if the
   trouble switch is set.

   82-07-01  Roger Lackey : Modified the calls to mu_db_inconsistent to use
   mdbm_util_$inconsistent_* for binding.

   83-06-21 Davids: Removed check for old version database and the call
   to v1 code if it was an old version db (old version dbs can no longer
   be opened)
*/

	num_filns = 0;
	user_flag, proc_flag, brief_flag, long_flag = "0"b;

/* BEGIN CHANGE 81-02-11 ********************************************** */

	submodel_open, db_model_open = "0"b;
	area_ptr = null ();

	on cleanup call clean_up ();

	call get_temp_segment_ (caller_name, area_ptr, code);
	if code ^= 0 then do;
		area_ptr = null ();
		call clean_up ();
		call com_err_ (code, caller_name, "^/^a",
		     "Unable to get a temporary segment.");
		return;
	     end;

	area_ptr -> work_area = empty ();

/* END CHANGE 81-02-11 ********************************************** */

	call cu_$arg_count (nargs);

	if nargs < 1 then do;
		call com_err_ (0, caller_name,
		     "^/Usage:  display_mrds_db_status db_path {-bf|-lg} {-proc_id PID|-user PERSON}");
		call clean_up ();
		return;

	     end;

	db_dir = copy (" ", 168);
	call cu_$arg_ptr (1, dbp_ptr, dbp_len, code);	/* get data base path */
	if code ^= 0 then do;
		call com_err_ (code, caller_name, "data base pathname");
						/* exit with com_err_ message */
		call clean_up ();
		return;

	     end;

/* BEGIN CHANGE 81-01-31 *************************************************** */

	in_path = dbp;
	call mrds_dsl_get_version$get_path_info (in_path, area_ptr,
	     mrds_path_info_structure_version, mrds_path_info_ptr, code);

	if mrds_path_info_ptr = null () then
	     db_path = in_path;
	else db_path = mrds_path_info.absolute_path;

	if code ^= 0 then do;
		if code = mrds_error_$no_model_submodel then
		     code = mrds_error_$no_database;
		call com_err_ (code, caller_name, "^/^a", dbp);
		call clean_up ();
		return;

	     end;

/* BEGIN CHANGE 81-02-11 **************************************************** */

	submodel = "0"b;
	if mrds_path_info.type.submodel then do;

/* if submodel path given, need to get real db path,
   then a list of relations available in this view of the db */

		sm_abs_path = db_path;

		call mrds_dsm_open$read (sm_abs_path, submodel_iocb_ptr, code);
						/* path is really to submodel */
		if code ^= 0 then do;
			call com_err_ (code, caller_name, "^/^a ^a",
			     "Unable to open the submodel:", sm_abs_path);
			call clean_up ();
			return;

		     end;

		submodel_open = "1"b;		/* remember, so clean up can close */

/* now get the real db path from the submodel header */

		call mrds_dsm_read_header$db_path (submodel_iocb_ptr, db_path, code);
		if code ^= 0 then do;
			call com_err_ (code, caller_name, "^/^a ^a",
			     "Unable to get the header for the submodel:", sm_abs_path);
			call clean_up ();
			return;

		     end;

		call mrds_dsm_get_relation_names (area_ptr, mrds_dsm_relation_names_ptr, submodel_iocb_ptr, code);
		if code ^= 0 then do;
			call com_err_ (code, caller_name, "^/^a ^a",
			     "Unable to get the list for relations for the submodel:", sm_abs_path);
			call clean_up ();
			return;
		     end;

/* get the details on the real db */

		call mrds_dsl_get_version$get_path_info (db_path, area_ptr,
		     mrds_path_info_structure_version, mrds_path_info_ptr, code);
		if mrds_path_info_ptr = null () then ;
		else db_path = mrds_path_info.absolute_path;

		if code ^= 0 then do;
			call com_err_ (code, caller_name, "^/^a ^a",
			     "Unable to get information on the database path:", db_path);
			call clean_up ();
			return;

		     end;

		submodel = "1"b;			/* rememeber we started with a submodel */

	     end;

/* END CHANGE 81-02-11 **************************************************** */

/* END CHANGE 81-01-31 ***************************************************** */

/* BEGIN CHANGE 81-02-12 *************************************************** */

/* check for a secured database */

	call mrds_dm_open (db_path, 2 /* retrieval mode */,
	     data_model_ptr, code);
	if code ^= 0 then do;
		call com_err_ (code, caller_name, "^/^a ^a",
		     "Unable to open the data model for database:", db_path);
		call clean_up ();
		return;
	     end;

	db_model_open = "1"b;			/* remember for clean up */

	call mrds_dm_db_secured$get_secured_status (data_model_ptr, area_ptr,
	     database_state_structure_version, database_state_ptr, code);
	if code ^= 0 then do;
		call com_err_ (code, caller_name, "^/^a ^a",
		     "Unable to get the secured state for the database:", db_path);
		call clean_up ();
		return;
	     end;

	if ^database_state.secured then ;
	else do;

/* secure database, check the user class - DBA or peon */

		call mrds_dm_authorization$get_user_class (rtrim (db_path), area_ptr,
		     mrds_authorization_structure_version, mrds_authorization_ptr, code);
		if code ^= 0 then do;
			call com_err_ (code, caller_name, "^/^a ^a",
			     "Unable to get the user class for the database:", db_path);
			call clean_up ();
			return;
		     end;

		if mrds_authorization.administrator then ;
		else do;

/* user is a peon, not a DBA, check that he is using a secured submodel */

			if ^submodel then
			     secured_submodel = "0"b;
			else do;			/* submodel path given */

				call expand_pathname_ (sm_abs_path, sm_dir, sm_name, code);
				if code ^= 0 then do;
					call com_err_ (code, caller_name, "^/^a ^a",
					     "Unable to expand the submodel pathname:", sm_abs_path);
					call clean_up ();
					return;
				     end;

				secured_submodel = mrds_dm_secured_submodel (db_path, sm_dir, sm_name);

			     end;

/* not secured submodel, tell user and get out */

			if ^secured_submodel then do;
				if ^submodel then
				     call com_err_ (mrds_error_$inc_secure_open, caller_name, "^/^a^a^a ^a",
					"The database """, db_path, """ has been secured,",
					"but the caller is not a DBA, and must use a submodel to reference it.");
				else call com_err_ (mrds_error_$inc_secure_open, caller_name, "^/^a^a^a^a^a  ^a^a^a",
					"The submodel """, sm_abs_path, """ refers to a database """,
					db_path, """ that has been secured,",
					"but the submodel itself is not in the databases inferior directory """,
					mrds_data_$submodel_dir_name, """.");

				call clean_up ();
				return;
			     end;

		     end;

	     end;

/* END CHANGE 81-02-12 ************************************************* */

	call expand_pathname_ (db_path, db_dir, db_ent, code);
	if code ^= 0
	then do;
		call com_err_ (code, caller_name, "^a", dbp);
						/* call clean_up () ;
						   return to command level */ call clean_up ();
		return;

	     end;

	if length (rtrim (db_path)) > 164
	then do;
		call com_err_ (error_table_$pathlong, caller_name, "^a", db_path);
		call clean_up ();
		return;

	     end;

	if nargs >= 2 then do;

		call cu_$arg_ptr (2, arg_ptr, arg_len, code);
		if arg = "-brief" | arg = "-bf"
		then brief_flag = "1"b;

		else if arg = "-long" | arg = "-lg"
		then long_flag = "1"b;

		else if arg = "-proc_id" | arg = "-pid"
		then proc_flag = "1"b;

		else if arg = "-user"
		then user_flag = "1"b;
		else do;
			call com_err_ (error_table_$badopt, caller_name, """^a""", arg);
			call clean_up ();
			return;

		     end;
	     end;

	call mu_concurrency_control$get_control_segment (db_path, dbc_ptr, dbc_bit_count, code);
	if code ^= 0 then do;
		call com_err_ (code, caller_name, "^/^a", "Unable to get a pointer to the database control segment.");
		call clean_up ();
		return;

	     end;


	call mdbm_util_$inconsistent_get_info (data_model_ptr, incon_value, incon_name, incon_message, undo_request);
						/* get consistency information */


	hdr.message = incon_message;
						/* set inconsistency message */
	if hdr.message = " "
	then hdr.message = "No reason for the inconsistency was given ";

	if ^user_flag & ^proc_flag
	then call db_report;			/* report is driven by contents of data base control segment */
	else call user_report;			/* report is driven by user name or by process id...
						   either of which are supplied by command string */

	call clean_up ();




	return;
db:  entry;
	dcl     dbs		 bit (1) int static init ("0"b);
	dbs = ^dbs;
	return;

db_report: proc;

	hdr.dbp = db_path;
	if long_flag then
	     call ioa_ ("^/Concurrency control version:  ^d", dbc.version);
	call ioa_ ("^13xData base path:  ^a", hdr.dbp);
	if long_flag then
	     call ioa_ ("^20xVersion:  ^d", mrds_path_info.mrds_version);
	if incon_value then
	     hdr.state = "Inconsistent";
	else hdr.state = "Consistent";
	if long_flag | incon_value then
	     call ioa_ ("^22xState:  ^a", hdr.state);
	if incon_value then
	     call ioa_ ("^21xReason:  ^a", hdr.message);

	if dbc.trouble_switch then
	     hdr.switch = "trouble switch on";
	else hdr.switch = "trouble switch off";
	if long_flag | dbc.trouble_switch then
	     call ioa_ ("^13xTrouble Switch:  ^a", hdr.switch);


	if dbc.quiesce_sw | dbc.quiesce_db | dbc.quiesce_files
	then do;
		go to quiesce_case (fixed (substr (string (dbc.flags), 3, 3)));
quiesce_case (1):	;
		call ioa_$nnl ("^30xQuiesce request queued for selected files");
		goto end_quiesce_case;

quiesce_case (2):	;
		call ioa_$nnl ("^30xQuiesce request queued");
		goto end_quiesce_case;

quiesce_case (3):	;
		call ioa_$nnl ("^30xInvalid combination of quiesce flags");
		goto end_quiesce_case;

quiesce_case (4):	;
		call ioa_$nnl ("^30xInvalid combination of quiesce flags");
		goto end_quiesce_case;

quiesce_case (5):	;
		call ioa_$nnl ("^30xData base is quiesced for selected files");
		goto end_quiesce_case;

quiesce_case (6):	;
		call ioa_$nnl ("^30xData base is quiesced");
		goto end_quiesce_case;

quiesce_case (7):	;
		call ioa_$nnl ("^30xInvalid combination of quiesce flags");
		goto end_quiesce_case;

end_quiesce_case:	;
		if live_process (dbc.quiesce_lock) | (dbc.quiesce_lock = "0"b)
		then call ioa_ (".");
		else call ioa_ (" by a dead process.");
		if dbs then do;
			call ioa_ ("db: Quiesce lock_id = ^12o", fixed (dbc.quiesce_lock));
		     end;
	     end;
	if dbc.dead_proc_flag
	then call ioa_ ("^15xAvailability:  Active scope set by dead process");
	hdr.nopen = dbc.open_users;
	call ioa_ ("^17xOpen users:  ^d", hdr.nopen);
	if dbc.open_users > 0 then do;
		hdr.nact = dbc.active_users;
		hdr.npact = dbc.wakeup_waiters;
		hdr.nwait = dbc.waiting_users;

		call ioa_ ("^/^16xScope users:  ^d  Active", hdr.nact);
		if long_flag | hdr.npact > 0 then
		     call ioa_ ("^30x^d  Awakening", hdr.npact);
		if long_flag | hdr.nwait > 0 then
		     call ioa_ ("^30x^d  Queued", hdr.nwait);
	     end;
	if ^brief_flag | long_flag then do;

		ul_ptr = convert (dbc_ptr, dbc.open_users_ofs);

		do idx = 1 to hdr.nopen while (ul_ptr ^= null);
		     call do_user;
		     ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);
		end;
	     end;
     end db_report;

user_report: proc;

/* this report format is driven by user supplied arguments
   consisting of user names and/or process ids
*/


	arg_count = 3;
	do while (arg_count <= nargs);

	     call cu_$arg_ptr (arg_count, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		     call com_err_ (code, caller_name, "argument nbr ^d", arg_count);
		     call clean_up ();
		     return;

		end;

	     if user_flag then do;
		     found = "0"b;
		     comp_len = index (arg, "*") - 1;	/* eliminate anything following and including an asterisk */
		     if comp_len <= 0 then comp_len = arg_len;
		     ul_ptr = convert (dbc_ptr, dbc.open_users_ofs);

		     comp_ptr = addr (user_list.group_id);
		     do while (ul_ptr ^= null);
			if before (arg, "*") = addr (user_list.group_id) -> comp_string
			then do;
				call do_user;
				found = "1"b;
			     end;

			ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);
		     end;

		     if ^found then do;
			     call com_err_ (mrds_error_$user_not_found, caller_name, "^a", arg);
			     call clean_up ();
			     return;

			end;

		end;				/* end of processing for a given user name */
	     else if proc_flag then do;
		     found = "0"b;
		     call ascii_to_bit (arg, bit_var);	/* convert process id from ascii string to bit string */
		     ul_ptr = convert (dbc_ptr, dbc.open_users_ofs);
		     do while (ul_ptr ^= null & ^found);/* halt after first one is found...
						   cannot be duplicate process ids */
			if bit_var = user_list.process_id then do;
				call do_user;
				found = "1"b;
			     end;
			ul_ptr = convert (dbc_ptr, user_list.next_open_ofs);
		     end;

		     if ^found then do;
			     call com_err_ (mrds_error_$process_not_found, caller_name, "^a", arg);
			     call clean_up ();
			     return;

			end;
		end;				/* end of processing for a given process id */

	     else do;
		     call com_err_ (error_table_$badopt, caller_name, "^a", "control arg");
		     call clean_up ();
		     return;

		end;

	     ok = "0"b;
	     if arg_count < nargs then do while (^ok);
						/* get next control arg */
		     call cu_$arg_ptr (arg_count + 1, arg_ptr, arg_len, code);
		     if code ^= 0 then do;
			     call com_err_ (code, caller_name, "^a", "control arg");
			     call clean_up ();
			     return;

			end;

		     if arg = "-bf" | arg = "-brief" | arg = "-lg" | arg = "-long"
		     then arg_count = arg_count + 1;	/* ignore */
		     else ok = "1"b;
		end;
	     if arg_count >= nargs then return;
	     if arg = "-user" then do;
		     user_flag = "1"b;
		     proc_flag = "0"b;
		end;
	     else if arg = "-proc_id" | arg = "-pid" then do;
		     proc_flag = "1"b;
		     user_flag = "0"b;
		end;
	     else do;
		     call com_err_ (error_table_$badopt, caller_name, """^a""", arg);
		     call clean_up ();
		     return;

		end;
	     arg_count = arg_count + 2;

/* now go back up and get a name */
	end;
						/* have reached end of command string */

     end user_report;

do_user: proc;

	usr.id = user_list.group_id;
	call ioa_ ("^/^12xUser process id:  ^a", usr.id);
	call bit_to_ascii (user_list.process_id, usr.pid);
	if long_flag | user_flag | proc_flag then
	     call ioa_ ("^13xProcess number:  ^a", usr.pid);
	if ^brief_flag then do;
		if user_list.dead_proc
		then usr.state = "Dead";
		else if live_process (user_list.db_lock_id)
		then usr.state = "Alive";
		else usr.state = "Dead";
		if long_flag | user_flag | proc_flag | usr.state = "Dead" then
		     call ioa_ ("^14xProcess state:  ^a", usr.state);
		usr.mode = "";
		if user_list.open_mode = mdbm_data_$normal_mode then usr.mode = "Normal";
		else if user_list.open_mode = mdbm_data_$quiesce_mode then usr.mode = "Quiesce";
		if long_flag | user_flag | proc_flag | usr.mode ^= "Normal" then
		     call ioa_ ("^17xUsage mode:  ^a", usr.mode);
		if dbs then do;
			call ioa_ ("db: lock_id = ^12o", fixed (user_list.db_lock_id));
			call ioa_ ("db: ul_ptr = ^p", ul_ptr);
		     end;

		if user_list.open_mode < 3 then do;	/* only for shared openings */
			if user_list.active_sw then do;
				usr.scope = "Active";
				if user_list.queue_activ then usr.activate = "Queue";
				else usr.activate = "Normal";
				if long_flag | user_flag | proc_flag then
				     call ioa_ ("^22xScope:  ^a", usr.scope);
				if long_flag | user_flag | proc_flag | usr.activate = "Queue" then
				     call ioa_ ("^17xActivation:  ^a", usr.activate);
			     end;

			else if user_list.waiting_sw then do;
				usr.scope = "Waiting";
				if user_list.priority_high then usr.pri = "High";
				else pri = "Normal";
				usr.allow = user_list.allowance_count;
				usr.bypass = user_list.bypass_count;
				call ioa_ ("^22xScope:  ^a", usr.scope);
				call ioa_ ("^19xPriority:  ^a", usr.pri);
				if user_list.dead_proc_conflict
				then call ioa_ ("^13xConflict state:  Blocked by dead process");

				call ioa_ ("^12xAllowance count:  ^d", usr.allow);
				call ioa_ ("^15xBypass count:  ^d", usr.bypass);
			     end;

			else if long_flag | user_flag | proc_flag then do;
						/* no scope is currently in effect and none has been requested */
				usr.scope = "None";
				call ioa_ ("^22xScope:  ^a", usr.scope);
			     end;
		     end;

		if user_list.open_mode < 3 then do;	/* only for shared openings */

			if ^submodel then do;

				fl_ptr = convert (dbc_ptr, user_list.fil_list_ofs);

				if fl_ptr ^= null () then do;
					call ioa_ ("^/^19xRelation^27xPermits^3xPrevents^/");
				     end;

				do while (fl_ptr ^= null);
				     fila.name = fil_list.name;
				     call display_permits_prevents ();

				     fl_ptr = convert (dbc_ptr, fil_list.next_ofs);
				end;
			     end;

/* BEGIN CHANGE 81-02-11 *************************************************** */

			else do;			/* submodel path supplied, only show relations in users view */

/* look up each relation in the submodel view, in the dbc relation list */

				code = 0;
				header_output = "0"b;
				do i = 1 to mrds_dsm_relation_names.nrels while (code = 0);

/* get the model name for this submodel relation */

				     call mrds_dsm_read_relation (mrds_dsm_relation_names.relation (i),
					area_ptr, str_ptr, submodel_iocb_ptr, code);
				     if code ^= 0 then do;
					     call com_err_ (code, caller_name, "^/^a ^a",
						"Unable to get the model name for submodel relation:",
						mrds_dsm_relation_names.relation (i));
					     call clean_up ();
					     return;
					end;

/* find the relation in the scope list */

				     done = "0"b;
				     fl_ptr = convert (dbc_ptr, user_list.fil_list_ofs);
				     do while (^done);
					if fl_ptr = null () then
					     done = "1"b;
					else if fil_list.name = str_ptr -> relation_block.dm_rel_name then
					     done = "1"b;
					else fl_ptr = convert (dbc_ptr, fil_list.next_ofs);

				     end;

				     if fl_ptr = null () then ; /* scope not set for this rel */
				     else do;

/* output the scope display, using the submodel name */

					     fila.name = mrds_dsm_relation_names.relation (i);

					     if header_output then ;
					     else do;
						     header_output = "1"b;
						     call ioa_ ("^/^19xRelation^27xPermits^3xPrevents^/");
						end;

					     call display_permits_prevents ();

					end;

				end;


			     end;

		     end;

/* END CHANGE 81-02-11 ******************************************************* */

	     end;
     end do_user;

display_permits_prevents: procedure ();

/* routine to display permitted/prevented scope modes for this file/relation,
   with the  modes presented based on the version of the dbc structure */

	permit_string, prevent_string = "";		/* init */

	if dbc.version ^= 4 & dbc.version ^= 5 then do;
		call com_err_ (mrds_error_$version_not_supported, caller_name,
		     "^/^a ^d", "Unknown database control segment version =", dbc.version);
		call clean_up ();
		return;

	     end;

	else if dbc.version = 4 then do;

/* old r-u mode version dbc permits */

		if fil_list.permits.read_attr then
		     permit_string = "r";
		if fil_list.permits.update then
		     permit_string = permit_string || "u";
		if permit_string = "" then
		     permit_string = "n";

/* r-u prevents */

		if fil_list.prevents.read_attr then
		     prevent_string = "r";
		if fil_list.prevents.update then
		     prevent_string = prevent_string || "u";
		if prevent_string = "" then
		     prevent_string = "n";

	     end;

/* for version 5 dbc structures, display the new form of the r-s-m-d scope modes
   These are now read_attr-append_tuple-modify_attr-delete_tuple, in order
   to be consistent with the submodel security MRDS acl keywords. */

	else do;					/* new version 5 dbc, r-s-m-d modes */

		if fil_list.permits.read_attr then
		     permit_string = permit_string || "r";

		if fil_list.permits.append_tuple then
		     permit_string = permit_string || "a";

		if fil_list.permits.modify_attr then
		     permit_string = permit_string || "m";

		if fil_list.permits.delete_tuple then
		     permit_string = permit_string || "d";

		if permit_string = "" then do;
			permit_string = "n";
		     end;

/* r-s-m-d prevent modes */

		if fil_list.prevents.read_attr then
		     prevent_string = prevent_string || "r";

		if fil_list.prevents.append_tuple then
		     prevent_string = prevent_string || "a";

		if fil_list.prevents.modify_attr then
		     prevent_string = prevent_string || "m";

		if fil_list.prevents.delete_tuple then
		     prevent_string = prevent_string || "d";

		if prevent_string = "" then do;
			prevent_string = "n";
		     end;


	     end;

/* output the constructed mode strings */

	call ioa_ ("^21x^32a^3x^4a^6x^4a", fila.name, permit_string, prevent_string);



	declare (permit_string, prevent_string) char (128) varying; /* mode display  temp strings */
	declare mrds_error_$version_not_supported fixed bin (35) ext; /* not known dbc version */

     end;

ascii_to_bit: proc (asc, bit_var);

/* convert ascii representation of octal number to bit string */

	dcl     asc		 char (*);	/* octal number in ascii */
	dcl     charr		 (12) char (1) unal based (ch_ptr); /* array of ascii characters representing an octal id */
	dcl     ch_ptr		 ptr;		/* ptr to character array */
	dcl     bit_var		 bit (36) varying;	/* result bit string */
	dcl     i			 fixed bin;	/* index variable */

	dcl     1 nine_bit		 unal based,	/* structure of bits for each ascii character */
		2 fill		 bit (6) unal,	/* bits to be discarded */
		2 last_3		 bit (3) unal;	/* relevant bits in each ascii character */

	bit_var = ""b;				/* initialize */
	ch_ptr = addr (asc);

	do i = 1 to 12;
	     if length (asc) + i <= 12
	     then bit_var = bit_var || "000"b;		/* take care of missing leading zeroes */

	     else bit_var = bit_var || addr (charr (i)) -> nine_bit.last_3;

	end;

     end ascii_to_bit;

bit_to_ascii: proc (bits, asc);

/* convert a 12 octal digit to ascii representation */

	dcl     bits		 bit (36) unal;	/* input bit string */
	dcl     asc		 char (12);	/* output ascii representation of octal string */
	dcl     thr_bit_asc		 (36) bit (3) unal based; /* three bit array for ascii string */
	dcl     thr_bit_bit		 (12) bit (3) unal based; /* three bit array for bit string */
	dcl     i			 fixed bin;

	asc = "000000000000";			/* initialize with ocatl sixties */
	do i = 1 to 12;
	     addr (asc) -> thr_bit_asc (3 * i) = addr (bits) -> thr_bit_bit (i);
	end;

     end bit_to_ascii;

convert: proc (a_ptr, ofs) returns (ptr);

/* this procedure function converts an offset from "0"b to null
   or from the offset value to a pointer value within the segment denoted by a_ptr
*/

	dcl     result		 ptr;		/* the reultant pointer value */
	dcl     a_ptr		 ptr;		/* ptr to the segment to which the offset refers */
	dcl     ofs		 bit (18) unal;	/* the bit offset */

	dcl     (null, ptr)		 builtin;

	if ofs ^= NULL_OFS
	then result = ptr (a_ptr, ofs);
	else result = null;

	return (result);

     end convert;

live_process: proc (lock_id) returns (bit (1));

/* This function returns "1"b if the lock_id (input parameter)
   corresponds to a live process.  Otherwise "0"b is returned. */
	l = lock_id;
	call set_lock_$lock (l, 0, icode);
	return (icode = error_table_$lock_wait_time_exceeded |
	     icode = error_table_$locked_by_this_process);
	dcl     icode		 fixed bin (35);
	dcl     l			 bit (36) aligned;
	dcl     lock_id		 bit (36) aligned parm;
     end live_process;

/* BEGIN CHANGE 81-02-11 ************************************************* */

clean_up: procedure ();

/* routine to close any open submodel, or model
   and get rid of temp storage space */

	if submodel_open then do;

		call mrds_dsm_close$force (submodel_iocb_ptr);
		submodel_open = "0"b;

	     end;

	if area_ptr ^= null then do;

		call release_temp_segment_ (caller_name, area_ptr, discard);

		area_ptr = null ();

	     end;

	if db_model_open then do;

		call mrds_dm_close (data_model_ptr, discard);

		db_model_open = "0"b;

		data_model_ptr = null ();

	     end;

     end;

/* END CHANGE 81-02-11 *********************************************** */

	dcl     (user_flag,				/* denotes -user option */
	        proc_flag,				/* denotes -process_id or -pid option */
	        brief_flag,				/* denotes -brief option */
	        long_flag,				/* denotes -long option */
	        found)		 bit (1) unal init ("0"b); /* a user_list entry was found if ON */

	dcl     (nargs,				/* nbr of aruments passed by user */
	        dbp_len,				/* length of data base pathname */
	        comp_len,				/* length of group_id compare string */
	        arg_count,				/* nbr of arguments processed */
	        arg_len)		 fixed bin;	/* length of each argument */

	dcl     code		 fixed bin (35);	/* status code */
	dcl     idx		 fixed dec (6);	/* index */

	dcl     (comp_ptr,				/* ptr to group_id compare string */
	        arg_ptr,				/* ptr to control arg */
	        dbp_ptr)		 ptr;		/* ptr to data base pathname */


	dcl     db_dir		 char (168);	/* containing directory pathname of the data base */
	dcl     db_ent		 char (32);	/* entry name of the data base */

	dcl     in_path		 char (168);	/* db pathname suitable for passing */
	dcl     db_path		 char (168);	/* absolute pathname of data base */

	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     dbp		 char (dbp_len) based (dbp_ptr);



	dcl     1 hdr,				/* report data for the data base control segment */
		2 dbp		 char (168),	/* data base pathname expanded */
		2 state		 char (24),	/* data base state: consistent or not consistent */
		2 message		 char (500),	/* explanation of data base state if inconsistent */
		2 switch		 char (24),	/* status of the trouble switch */
		2 nopen		 fixed dec (6),	/* nbr of users with data base currently open */
		2 nact		 fixed dec (6),	/* nbr users with scopes currently in effect */
		2 npact		 fixed dec (6),	/* nbr users awakened but not yet with active scope */
		2 nwait		 fixed dec (6);	/* nbr users queued waiting for a scope setting */


	dcl     1 usr,				/* report data for each open user of data base */
		2 id		 char (32),	/* group id of the user */
		2 pid		 char (12),	/* process id of the user */
		2 mode		 char (19),	/* open mode : r, u, er, eu */
		2 state		 char (5),	/* dead process or is it alive */
		2 scope		 char (7),	/* active, waiting or in between scope usage */
		2 pri		 char (6),	/* normal or high priority */
		2 activate	 char (6),	/* was user activated from set_scope or from queue */
		2 allow		 fixed dec (6),	/* allowance count of bypasses */
		2 bypass		 fixed dec (6);	/* nbr times user was bypassed */


	dcl     1 fila,
		2 name		 char (32),	/* name of file which has a scope set */
		2 prm		 char (2) unal,	/* permit scope: n or combination of r and u */
		2 prv		 char (2) unal;	/* prevent scope: n or combination of r and u */


	dcl     1 three_bits	 aligned,
		2 one_bit		 bit (1) unal init ("0"b), /* structure for binary representation of scope bits */
		2 two_bit		 bit (2) unal;

	dcl     ok		 bit (1) unal;	/* ON => control arg is ok */

	dcl     comp_string		 char (comp_len) based (comp_ptr); /* group_id to be compared, without the asterisks */

	dcl
	        bit_var		 bit (36) varying;	/* process id string */

	dcl     (addr,
	        null,
	        before,
	        length,
	        fixed,
	        index,
	        copy,
	        empty,
	        rel,
	        rtrim,
	        string,
	        substr)		 builtin;

	dcl     ioa_		 entry options (variable);
	dcl     ioa_$nnl		 entry options (variable);
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	declare mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* get path details */
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed bin, fixed bin (35));
	dcl     sys_info$max_seg_size	 fixed bin ext;

	dcl     mdbm_data_$normal_mode fixed bin ext;
	dcl     mdbm_data_$quiesce_mode fixed bin ext;

	dcl     mrds_error_$user_not_found fixed bin (35) ext;
	declare mrds_error_$no_database fixed bin (35) ext; /* no model */
	declare dbc_bit_count	 fixed bin (24);	/* unused */
	declare mu_concurrency_control$get_control_segment entry (char (168), ptr, fixed bin (24), fixed bin (35)); /* gets control seg ptr */
	dcl     mdbm_util_$inconsistent_get_info entry (ptr, bit (1) unal, char (*), char (*), char (*));
						/* gets consistency status for database */
	dcl     incon_value		 bit (1);		/* true ==> db is inconsistent */
	dcl     incon_name		 char (32);	/* name of request associated with the message */
	dcl     incon_message	 char (500);	/* explanation of inconsistency */
	dcl     undo_request	 char (100);	/* request that will make db consistent */
	dcl     caller_name		 char (32) init ("display_mrds_db_status"); /* name of calling routine */
	dcl     mrds_error_$no_model_submodel fixed bin (35) ext; /* path not to mrds object */
	declare str_ptr		 ptr;		/* points to submodel relation info */
	declare submodel		 bit (1);		/* on => submodel pathname given */
	declare (get_temp_segment_, release_temp_segment_) entry (char (*), ptr, fixed bin (35)); /* gets/returns temp storage */
	declare submodel_open	 bit (1);		/* on => submodel currently open */
	declare work_area		 area (sys_info$max_seg_size) based (area_ptr); /* temp storage */
	declare area_ptr		 ptr;		/* to temp storage */
	declare cleanup		 condition;
	declare discard		 fixed bin (35);	/* unused error code */
	declare done		 bit (1);		/* on => name found in model concurrency list */
	declare header_output	 bit (1);		/* on => header for permits/prevents output */
	declare i			 fixed bin;	/* loop index */
	declare data_model_ptr	 ptr;		/* pointer to database model */
	declare mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin, ptr, fixed bin (35)); /* gets secured bit */
	declare mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35)); /* open database model */
	declare mrds_dm_close	 entry (ptr, fixed bin (35)); /* closes database model */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* finds if user a DBA */
	declare mrds_dm_secured_submodel entry (char (*), char (*), char (*)) returns (bit (1)); /* returns true if submodel in sm dir */
	dcl     mrds_dsm_close$force	 entry (ptr);
	dcl     mrds_dsm_get_relation_names entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mrds_dsm_open$read	 entry (char (*), ptr, fixed bin (35));
	dcl     mrds_dsm_read_header$db_path entry (ptr, char (168), fixed bin (35));
	dcl     mrds_dsm_read_relation entry (char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     submodel_iocb_ptr	 ptr init (null ());
	declare mrds_data_$submodel_dir_name char (16) ext; /* name of submodel dir */
	declare mrds_error_$inc_secure_open fixed bin (35) ext; /* attempt to open thru non-secure submodel */
	declare secured_submodel	 bit (1);		/* on => submodel in submodel dir */
	declare sm_name		 char (32);	/* entryname of submodel */
	declare sm_dir		 char (168);	/* containing dir of submodel */
	declare sm_abs_path		 char (168);	/* absolute path to submodel */
	declare db_model_open	 bit (1);		/* on => database model opened */
	dcl     mrds_error_$process_not_found fixed bin (35) ext;

	dcl     error_table_$badopt	 fixed bin (35) ext;
	dcl     error_table_$locked_by_this_process fixed bin (35) ext;
	dcl     error_table_$lock_wait_time_exceeded fixed bin (35) ext;
	dcl     error_table_$pathlong	 fixed bin (35) ext;

%include mdbm_dbc;
%page;
%include mdbm_users;
%page;
%include mrds_path_info;
%page;
%include mrds_dsm_rel_block;
%page;
%include mrds_dsm_relation_names;
%page;
%include mrds_database_state;
%page;
%include mrds_authorization;


     end display_mrds_db_status;




		    display_mrds_db_version.pl1     04/18/85  1424.3re  04/18/85  0906.2       46116



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

/* HISTORY:

   Originally written by Jim Gray - - February 1980
   Modified by Jim Gray - - April 1980, to add submodel capability.

   81-01-22 Jim Gray : changed to take advantage of extended interface of
   mrds_dsl_get_version$get_path_info, replacing the $header entry.

   83-01-18  Roger Lackey : added mrds_error_$no_model_submodel to handle
   the case where mrds_dsl_get_version$get_path_info
   returns mrds_error_$no_database.  Also declared undeclared variables.

*/

display_mrds_db_version: dmdv: procedure ();

/* DESCRIPTION:

   This routine is to be called from command level,
   to display the version number of a MRDS database,
   given it's pathname, and the expanded pathname of that
   database with a possible ".db" suffix, whether or not
   the input pathname had the suffix.
   NOTE: the user must have at least read access to the database model.

*/

/* PARAMETERS:

   database_path - - (input) the relative pathname of the database,
   with or without the ".db" suffix if the database has one.

   database_version - - (output) the version of the software and architecture
   of the database whose pathname was given.
   Additional information, such as creator, and time created are also given.

*/
%page;
	call cu_$arg_count (nargs);
	if nargs ^= 1 then
	     call com_err_ (error_table_$wrong_no_of_args, caller_name,
		"^/Usage: display_mrds_db_version  database_pathnname^/");
	else do;

		call cu_$arg_ptr (1, arg_ptr, arg_len, code);
		if code ^= 0 then
		     call com_err_ (code, caller_name,
			"^/Unable to get pathname argument.^/");
		else do;

			area_ptr = addr (work_area);
			call mrds_dsl_get_version$get_path_info (database_path, area_ptr,
			     mrds_path_info_structure_version, mrds_path_info_ptr, code);
			if code ^= 0 then do;
				if code = mrds_error_$no_database then
				     code = mrds_error_$no_model_submodel;
				call com_err_ (code, caller_name,
				     "^/Unable to get database information using the path ""^a"".", mrds_path_info.absolute_path);
			     end;
			else do;

				if mrds_path_info.mrds_version > 1 | mrds_path_info.type.submodel then
				     call date_time_ (mrds_path_info.creation_time, time);
				else do;
					time = UNKNOWN;
					mrds_path_info.creator_id = UNKNOWN;
				     end;


				if mrds_path_info.type.submodel then
				     type = " Sub";
				else type = "Data";

				call ioa_ ("^/^a model: ^a^/^3xversion: ^d^/^3xcreated: ^a^/^8xby: ^a^/",
				     type, mrds_path_info.absolute_path, mrds_path_info.mrds_version,
				     time, mrds_path_info.creator_id);

			     end;

		     end;

	     end;
%page;
	declare type		 char (4);	/* either Sub or Data for datamodels or submodels */
	declare ioa_		 entry options (variable); /* display to terminal subroutine */
	declare mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin,
				 ptr, fixed bin (35)); /* gets db get_path_info info */
	declare com_err_		 entry options (variable); /* does error i/o */
	declare code		 fixed bin (35);	/* error status encoding */
	declare database_path	 char (arg_len) based (arg_ptr); /* input pathname argument */
	declare date_time_		 entry (fixed bin (71), char (*)); /* converts time to character form */
	declare cu_$arg_count	 entry (fixed bin); /* gets number of arguments */
	declare nargs		 fixed bin;	/* argument count */
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); /* gets character string arguments */
	declare caller_name		 char (24) init ("display_mrds_db_version"); /* name of calling routine */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* arg count ^= 1 */
	dcl     mrds_error_$no_database fixed bin (35) ext static;
	dcl     mrds_error_$no_model_submodel fixed bin (35) ext static;
	declare arg_ptr		 ptr;		/* pointer to pathname argument */
	declare arg_len		 fixed bin (21);	/* length of pathname arg */
	declare time		 char (24);	/* converted form of time */
	declare UNKNOWN		 char (24) init ("Unknown in this version.");
	declare work_area		 area (1024);	/* space for get_path_info structure */
	declare area_ptr		 ptr;		/* pointer to work area */
	dcl     addr		 builtin;
	dcl     empty		 builtin;
%page;
%include mrds_path_info;

     end;




		    display_mrds_dm.pl1             10/23/86  1024.2rew 10/23/86  1007.6      271629



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */

display_mrds_dm: dmdm: proc;


/* .		     BEGIN_DESCRIPTION

   This procedure has two entry points:
   1) dmdm the display_mrds_dm command
   2) rmdb_rq_dmdm entry point called from rmdb (restructure_mrds_db) ssu_

   They both display of the data base model info and support the same control
   arguments.  The dmdm command can be used on pre version 4 type database
   where as the rmdb_rq_dmdm only works on version 4 databases.

   The dmdm command errors are displayed using com_err_ and the rmdb_rq_dmdm
   errors use ssu_$abort_line.

   Its purpose is to process the control arguments
   and to then calls the mrds_dm_display routine to do the display work.

   .		      END_DESCRIPTION
*/



/****^  HISTORY COMMENTS:
  1) change(85-12-03,Spitzer), approve(85-12-03,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     add new control arguments for unreferenced objects and crossreferences.
  2) change(86-08-21,Blair), approve(86-08-21,MCR7311),
     audit(86-09-15,Gilcrease), install(86-10-16,MR12.0-1187):
     Put in calls to check whether or not the model is inconsistent and require
     the user to make the database consistent before he can look at the model.
     This is necessary because restructuring may have left the database
     inconsistent.
  3) change(86-10-21,Blair), approve(86-10-21,PBF7311), audit(86-10-23,Dupuis),
     install(86-10-23,MR12.0-1199):
     Make the clean up on inconsistent database call mrds_rst_$execute_undo
     instead of rmdb_execute_undo so as to not violate the libraries rule.
                                                   END HISTORY COMMENTS */


/*  HISTORY
   82-05-15  Written by Roger Lackey
   83-01-10  Roger Lackey : Modified to call mdbm_util_$get_user_class  to not allow non-DBA
   from displaying a secured database.

   83-01-11  Roger Lackey : Added a call to dmd_$get_secured_state to determine
   if datbase was secured.

   83-06-21 Davids: Removed check for old version database and the call
   to v1 code if it was an old version db (old version dbs can no longer
   be opened)
*/
%page;
/*  display_mrds_dm or dmdm command */

	ep = COMMAND;				/* Multics command interface */

	call init;				/* Internal routine */
	delete_xref_file_flag = "1"b;

	on cleanup call tidy_up;			/* Establish a cleanup handler */

	rmdb_ctl_ptr = null;

	call cu_$arg_count (nargs);			/* Get the number of arguments supplied */
	if nargs < 1 then do;			/* Must have at least the db path */
		call com_err_ (0, my_name,
		     "^/Usage: display_mrds_dm  database_path {-control args}");

		call tidy_up ();
		return;
	     end;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);	/* Get db path */
	if code ^= 0 then call error (code, arg);

	if index (arg, "-") = 1 then call error (error_table_$noarg,
		"^/First argument must be the data base pathname.");

/*		Determine which version we have 	*/

	call get_temp_segment_ (my_name, temp_seg_ptr, code);
	if code ^= 0 then call error (code, "Getting temp segment.");

	work_area_ptr = temp_seg_ptr;
	wa = empty ();				/* Make it an area */

	call mrds_dsl_get_version$get_path_info (arg, work_area_ptr,
	     mrds_path_info_structure_version, mrds_path_info_ptr, code);

	if mrds_path_info_ptr = null () then
	     dbp = arg;
	else dbp = mrds_path_info.absolute_path;
	absolute_database_path = dbp;

	if code ^= 0 then do;
		if code = mrds_error_$no_model_submodel then /* not db found */
		     code = mrds_error_$no_database;

		call error (code, "^/" || absolute_database_path);
	     end;

	if mrds_path_info.type.submodel then do;	/* not usable via submodels */
		call com_err_ (error_table_$badcall, my_name,
		     "^/Data submodels are not supported by this command.  ^a", dbp);
		call tidy_up ();
		goto exit;
	     end;

	else do;
		call mdbm_util_$get_user_class ((mrds_path_info.absolute_path), work_area_ptr,
		     mrds_authorization_structure_version, mrds_authorization_ptr, code);
		if code ^= 0
		then do;
			call ioa_$rs ("Unable to determine if you are a DBA for ^a", err_msg,
			     length (err_msg), mrds_path_info.absolute_path);
			call error (code, err_msg);
		     end;

		if ^mrds_authorization.administrator
		then do;
			structure_version = 1;
			call dmd_$get_secured_state ((mrds_path_info.absolute_path),
			     work_area_ptr, structure_version, database_state_ptr, code);
			if code ^= 0 then do;
				err_msg = "Unable to determine data base secured state.";
				call error (code, err_msg);
			     end;
			else if database_state.secured then do;

				code = error_table_$insufficient_access;
				err_msg = "^/The user must be a database administrator to perform this operation on a secured database.";
				call error (code, err_msg);
			     end;
		     end;

	     end;

	call initiate_file_ (dbp, "db_model", R_ACCESS, dbm_ptr, (0), code); /* Assume it is a version 4 or later */
	if code = error_table_$moderr then do;
		call mrds_dm_authorization$set_needed_access (rtrim (dbp), code); /* fails if user not DBA */
		if code ^= 0 then
		     code = mrds_error_$no_model_access;
		else call initiate_file_ (dbp, "db_model", R_ACCESS, dbm_ptr, (0), code); /* Assume it is a version 4 or later */
	     end;
	if dbm_ptr = null then call error (mrds_error_$no_database, "^/" || dbp);
	else terminate_file_flag = "1"b;

	allocate mrds_dm_display_info in (wa) set (mrds_dm_display_info_ptr);

	mrds_dm_display_info.version = MRDS_DM_DISPLAY_INFO_VERSION_1;
	mrds_dm_display_info.output_iocb_ptr = iox_$user_output; /* May get changed with -of control arg */
	mrds_dm_display_info.db_path = absolute_database_path;

/* A temp dir will be created  either under this dir or under the dir supplied
   by the -temp_dir control arg */

	temp_dir_father_dir = mrds_dsl_resultant_storage$get_temp_dir ();

	mrds_dm_display_info.work_area_ptr = work_area_ptr;
	mrds_dm_display_info.dbm_ptr = dbm_ptr;

	string (mrds_dm_display_info.sw) = "0"b;	/* Turn off all swiches */
	mrds_dm_display_info.sw.default = "1"b;
	mrds_dm_display_info.dom_name_list_ptr = null;
	mrds_dm_display_info.attr_name_list_ptr = null;
	mrds_dm_display_info.rel_name_list_ptr = null;
	mrds_dm_display_info.index_name_list_ptr = null;
	mrds_dm_display_info.xref_iocb_ptr = null;

	first_arg_number = 2;			/* Cause we had a db pathname */

	goto common;
%page;
/* ******************  rmdb_rq_dmdm   entry point      *******************   */

rmdb_rq_dmdm: entry (I_sci_ptr, I_rmdb_ctl_ptr);

/*      rmdb_rq_dmdm PARAMETERS     */

	dcl     I_sci_ptr		 ptr parameter;	/* Pointer to ssu info structure */
	dcl     I_rmdb_ctl_ptr	 ptr parameter;	/* Pointer to restructuring control structure */

	sci_ptr = I_sci_ptr;
	rmdb_ctl_ptr = I_rmdb_ctl_ptr;
	ep = REQUEST;

	call init;				/* Internal routine */
	delete_xref_file_flag = "0"b;

	on cleanup call tidy_up;			/* Establish a cleanup handler */

	if rmdb_ctl.version ^= RMDB_CTL_VERSION_1 then
	     call error (error_table_$unimplemented_version, "rmdb_create_rel_info.incl.pl1");

	if rmdb_ctl.absolute_db_path = " " then call error (mrds_error_$no_db_path, "");

	work_area_ptr = rmdb_ctl.work_area_ptr;		/* Set wa pointer */

	allocate mrds_dm_display_info in (wa) set (mrds_dm_display_info_ptr);

	mrds_dm_display_info.version = MRDS_DM_DISPLAY_INFO_VERSION_1;
	mrds_dm_display_info.output_iocb_ptr = iox_$user_output; /* May get changed with a -of cotrol arg */
	mrds_dm_display_info.db_path = rmdb_ctl.absolute_db_path;
	mrds_dm_display_info.temp_dir_path = rmdb_ctl.temp_dir_path;
	mrds_dm_display_info.work_area_ptr = rmdb_ctl.work_area_ptr;
	mrds_dm_display_info.dbm_ptr = rmdb_ctl.db_model_ptr;
	mrds_dm_display_info.xref_iocb_ptr = rmdb_ctl.crossref_file_info.iocb_ptr;
	mrds_dm_display_info.xref_name = rmdb_ctl.crossref_file_info.name;

	string (mrds_dm_display_info.sw) = "0"b;	/* Turn off all swiches */
	mrds_dm_display_info.sw.default = "1"b;
	mrds_dm_display_info.dom_name_list_ptr = null;
	mrds_dm_display_info.attr_name_list_ptr = null;
	mrds_dm_display_info.rel_name_list_ptr = null;
	mrds_dm_display_info.index_name_list_ptr = null;

	call ssu_$arg_count (sci_ptr, nargs);

	first_arg_number = 1;			/* No pathname arg for this entry point */
	goto common;

%page;
common:

	mrds_control_arg_found = "0"b;

	call mdbm_util_$inconsistent_get_info (mrds_dm_display_info.dbm_ptr,
	     incon_flag, incon_name, incon_message, undo_request);           /* See if db is inconsistent */

	if incon_flag then          /* DB is inconsistent */
	     if ep = COMMAND
	     then do;
		code = mrds_error_$inconsistent_database;
		err_msg = incon_message;
		call error (code, err_msg);
		end;
	     else call mrds_rst_$execute_undo (sci_ptr,
		"display_data_model", mrds_dm_display_info.db_path,
		mrds_dm_display_info.dbm_ptr, incon_name, undo_request);

	do i = first_arg_number to nargs;		/* Process all the rest of the args */

	     if ep = COMMAND then do;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if code ^= 0 then call error (code, "Getting arg");
		end;
	     else call ssu_$arg_ptr (sci_ptr, i, arg_ptr, arg_len);

	     if index (arg, "-") = 1 then do;	/* Must be a control arg */

		     if arg = "-cmdb" | arg = "-create_mrds_db" then /*  *** -cmdb  */
			cmdb_arg_found, mrds_dm_display_info.sw.cmdb = "1"b;


		     else if arg = "-bf" | arg = "-brief" then do; /*  *** -brief */
			     mrds_dm_display_info.sw.default = "0"b;
			     mrds_dm_display_info.sw.long = "0"b;
			     brief_flag = "1"b;
			end;


		     else if arg = "-xref" | arg = "-crossref" then do;
			     mrds_control_arg_found = "1"b;
			     if i + 1 > nargs then mrds_dm_display_info.sw.all_xref = "1"b;
			     else do;
				if ep = COMMAND
				then call cu_$arg_ptr (i+1, arg_ptr, arg_len, code);
				else call ssu_$arg_ptr (sci_ptr, i+1, arg_ptr, arg_len);
				if index (arg, "-") ^= 1 then do;
				     if arg = "all"
				     then mrds_dm_display_info.sw.all_xref = "1"b;
				     else if arg = "dom" | arg = "domain" | arg = "domains"
					then mrds_dm_display_info.sw.domain_xref = "1"b;
				     else if arg = "attr" | arg = "attribute" | arg = "attributes"
					then mrds_dm_display_info.sw.attribute_xref = "1"b;
				     else call error (error_table_$bad_arg, "Following -crossref: " || arg);
				     i = i + 1;	/* swallow this arg */
				     end;
				else mrds_dm_display_info.sw.all_xref = "1"b;
				end;
			end;

		     else if arg = "-lg" | arg = "-long" then do; /*  ***  -long */
			     mrds_dm_display_info.sw.default = "0"b;
			     mrds_dm_display_info.sw.long = "1"b;
			end;


		     else if arg = "-of" | arg = "-output_file" then do; /*  ** -output_file */
			     if i + 1 > nargs then call error (error_table_$noarg,
				     "^/No output file name specified.");
			     else do;

				     i = i + 1;	/* Cause we used an argument */
				     if ep = COMMAND then do;
					     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
					     if code ^= 0 then call error (code, "Getting arg");
					end;
				     else call ssu_$arg_ptr (sci_ptr, i, arg_ptr, arg_len);
				     if index (arg, "-") = 1 then
					call error (error_table_$bad_subr_arg, arg);
				     else call expand_pathname_ (arg, of_dir, of_ent, code);
				     if code ^= 0 then call error (code, arg);
				     of_path = rtrim (of_dir) || ">" || of_ent;
				     of_flag = "1"b;
				end;
			end;			/* End output file arg */


		     else if arg = "-nof" | arg = "-no_output_file" then /*  *** -no_output_file */
			of_flag = "0"b;

		     else if arg = "-rel" | /*  *** -relations  */
			arg = "-relation" |
			arg = "-relations" then do;
			     mrds_dm_display_info.sw.relation = "1"b;
			     mrds_control_arg_found = "1"b;
			     if i + 1 <= nargs then do;
				     call build_name_list (i, args_used, mrds_dm_display_info.rel_name_list_ptr);

				     i = i + args_used;
				end;
			end;


		     else if arg = "-rn" | arg = "-rel_names" then do; /*  *** -rel_names
						   THIS is for compatibility with old display_mrds_dm */

			     mrds_dm_display_info.sw.relation = "1"b;
			     mrds_dm_display_info.sw.names_only = "1"b;
			     mrds_control_arg_found = "1"b;

			     if i + 1 <= nargs then do;
				     call build_name_list (i, args_used, mrds_dm_display_info.rel_name_list_ptr);

				     i = i + args_used;
				end;
			end;


		     else if arg = "-nm" | /*   ***  -names  */
			arg = "-name" |
			arg = "-names" then
			mrds_dm_display_info.sw.names_only = "1"b;

		     else if arg = "-dom" | /*   *** -domains */
			arg = "-domains" |
			arg = "-domain" then do;
			     mrds_control_arg_found, mrds_dm_display_info.domains = "1"b;

			     if i + 1 <= nargs then do;
				     call build_name_list (i, args_used, mrds_dm_display_info.dom_name_list_ptr);

				     i = i + args_used;
				     if arg = "-unref" | arg = "-unreferenced"
				     then if mrds_dm_display_info.dom_name_list_ptr ^= null
					then call error (error_table_$inconsistent, "-unreferenced and a name list following -domain");
				          else do;
					     mrds_dm_display_info.sw.unreferenced_domains = "1"b;
					     i = i + 1;
					     end;
				end;
			end;


		     else if arg = "-attr" | /*  *** -attributes */
			arg = "-attributes" |
			arg = "-attribute" then do;
			     mrds_dm_display_info.attribute = "1"b;
			     mrds_control_arg_found = "1"b;

			     if i + 1 <= nargs then do;
				     call build_name_list (i, args_used, mrds_dm_display_info.attr_name_list_ptr);

				     i = i + args_used;
				     if arg = "-unref" | arg = "-unreferenced"
				     then if mrds_dm_display_info.attr_name_list_ptr ^= null
					then call error (error_table_$inconsistent, "-unreferenced and a name list following -attribute");
				          else do;
					     mrds_dm_display_info.sw.unreferenced_attributes = "1"b;
					     i = i + 1;
					     end;
				end;
			end;


		     else if arg = "-ix" | arg = "-index" then do; /*  *** -index */
			     mrds_dm_display_info.index = "1"b;
			     mrds_control_arg_found = "1"b;

			     if i + 1 <= nargs then do;
				     call build_name_list (i, args_used, mrds_dm_display_info.index_name_list_ptr);

				     i = i + args_used;
				end;
			end;


		     else if arg = "-hist" | arg = "-history" then /*  *** -history */
			mrds_control_arg_found, mrds_dm_display_info.sw.history = "1"b;

		     else if arg = "-header" | arg = "-he" then do; /*  **** -header */
			     mrds_dm_display_info.sw.header = "1"b;
			     mrds_control_arg_found = "1"b;
			end;

		     else if arg = "-no_header" | arg = "-nhe" then do; /*  **** -no_header */
			     mrds_dm_display_info.sw.header = "0"b;
			     no_header_flag = "1"b;
			end;

		     else if arg = "-td" | arg = "-temp_dir" then do; /*  *** -temp_dir  */
			     if i + 1 > nargs then call error (error_table_$noarg,
				     "^/No temporary directory path specified.");
			     else do;

				     i = i + 1;	/* Cause we used an argument */
				     if ep = COMMAND then do;
					     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
					     if code ^= 0 then call error (code, "Getting arg");
					end;
				     else call ssu_$arg_ptr (sci_ptr, i, arg_ptr, arg_len);
				     if index (arg, "-") = 1 then
					call error (error_table_$bad_subr_arg, arg);
				     else call expand_pathname_ (arg, td_dir, td_ent, code);
				     if code ^= 0 then call error (code, arg);
				     temp_dir_father_dir = rtrim (td_dir) || ">" || td_ent;
				     temp_dir_flag = "1"b;
				end;
			end;			/* End -temp_dir arg */


		     else call error (error_table_$badopt, arg); /* Bad control arg */
		end;				/* End must be a control arg */

	     else call error (error_table_$bad_arg, arg);

	end;					/* End process args */
%page;
/*   Check for compatible control argument */

	if mrds_dm_display_info.names_only then do;
		if brief_flag then call error (error_table_$inconsistent,
			"^/-names and -brief");
		if mrds_dm_display_info.sw.long then call error (error_table_$inconsistent,
			"^/-names and -long");
	     end;

	if of_flag then do;				/* IF -output_file */
		of_switch_name = unique_chars_ ("0"b) || ".rmdb.dmdm_of";
		of_attach_desc = "vfile_ " || of_path;

		call iox_$attach_name (of_switch_name, out_iocb_ptr,
		     of_attach_desc, null, code);
		if code ^= 0 then
		     call error (code, "^/Attaching output file: " || of_path);
		call iox_$open (out_iocb_ptr, STREAM_OUTPUT, "0"b, code);
		if code ^= 0 then call error (code, "^/Opening output file: " || of_path);
		mrds_dm_display_info.output_iocb_ptr = out_iocb_ptr;
	     end;

/* To make compatible with the old dmdm command
   if only -rel and -long then force the -he */

	if (^mrds_dm_display_info.sw.domains |
	     ^mrds_dm_display_info.sw.attribute |
	     ^mrds_dm_display_info.sw.index |
	     ^mrds_dm_display_info.sw.relation |
	     ^mrds_dm_display_info.sw.domain_xref |
	     ^mrds_dm_display_info.sw.attribute_xref |
	     ^mrds_dm_display_info.sw.all_xref) &
	     ^no_header_flag & ^mrds_control_arg_found &
	     mrds_dm_display_info.sw.long then mrds_dm_display_info.sw.header = "1"b;

	if ^mrds_control_arg_found & ^cmdb_arg_found then /* Default is -relation */
	     mrds_dm_display_info.sw.relation = "1"b;

	if cmdb_arg_found & mrds_control_arg_found then /* -cmdb connot be used with anyother mrds control arg */
	     call error (error_table_$inconsistent,
		"^/The -cmdb can only be used with -long, -brief and -output_file control arguments.");

	if temp_dir_flag | ep = COMMAND then call create_temp_dir; /* Internal proc */

	call mrds_dm_display (mrds_dm_display_info_ptr, err_msg, code); /* Go do the work */

	if code ^= 0 then call error (code, err_msg);

	if ep = REQUEST & mrds_dm_display_info.xref_iocb_ptr ^= null then do;
	     rmdb_ctl.crossref_file_info.iocb_ptr = mrds_dm_display_info.xref_iocb_ptr;
	     rmdb_ctl.crossref_file_info.name = mrds_dm_display_info.xref_name;
	     delete_xref_file_flag = "0"b;
	     end;

	if of_flag then /* If output file */
	     call adjust_bit_count_ ((of_dir), (of_ent), "1"b, bcnt, code);
	if code ^= 0 then call error (code, rtrim (of_dir) || ">" || of_ent);

	call tidy_up;				/* Clean up after our self */
exit:	return;
%page;
/*  * * * * * * * * * * * * *      init     * * * * * * * * * * * * * *    */

init: proc;

	my_name = "display_mrds_dm";			/* Init for cleanup */
	out_iocb_ptr = null;
	mrds_dm_display_info_ptr = null;
	temp_seg_ptr = null;
	temp_dir_flag = "0"b;
	of_flag = "0"b;
	cmdb_arg_found = "0"b;
	brief_flag = "0"b;
	no_header_flag = "0"b;
	err_flag = "0"b;
	we_made_temp_dir_flag = "0"b;
	terminate_file_flag = "0"b;

     end init;
%page;
/* * * * * * * * * * * *  create_temp_dir   * * * * * * * * * * * * * * *   */

create_temp_dir: proc;

/* Create a temporary directory for use by the display routine.
   Also create a segment under the temparory dir and make it an area for use by
   the display routine.  */

	temp_dir_name = unique_chars_ ("0"b) || ".mrds.dmdm";

	we_made_temp_dir_flag = "1"b;			/* Remember we created it */

	call hcs_$append_branchx (temp_dir_father_dir, temp_dir_name, 01011b, /* sma acl's */
	     rings, get_group_id_$tag_star (),
	     1 /* directory */,
	     0 /* copy sw */,
	     0 /* bit count */,
	     code);
	if code ^= 0 then
	     call error (code, "^/Temporary directory:  " || temp_dir_father_dir);

	mrds_dm_display_info.temp_dir_path = rtrim (temp_dir_father_dir) || ">" ||
	     temp_dir_name;

     end create_temp_dir;
%page;
/*  * * * * * * * * * * * *        build_name_list      * * * * * * * * *   */

build_name_list: proc (start_arg, number_args_used, assigned_name_list_ptr);

	dcl     assigned_name_list_ptr ptr parameter;
	dcl     number_args_used	 fixed bin parameter;
	dcl     start_arg		 fixed bin parameter;

	last_arg_num = start_arg;
	name_list_ptr = null;
	number_args_used = 0;

	if start_arg + 1 <= nargs then do;

		if ep = COMMAND then do;
			call cu_$arg_ptr (last_arg_num + 1, arg_ptr, arg_len, code);
			if code ^= 0 then call error (code, "Getting arg");
		     end;
		else call ssu_$arg_ptr (sci_ptr, last_arg_num + 1, arg_ptr, arg_len);
		if index (arg, "-") ^= 1 then do;	/* Not a control arg */

			num_names_alloc = nargs - start_arg;
			allocate name_list in (wa) set (name_list_ptr);
			name_list.num_names = 0;
			no_more_names = "0"b;

			do while (^no_more_names & last_arg_num + 1 <= nargs);

			     if ep = COMMAND then do;
				     call cu_$arg_ptr (last_arg_num + 1, arg_ptr, arg_len, code);
				     if code ^= 0 then call error (code, "Getting arg");
				end;
			     else call ssu_$arg_ptr (sci_ptr, last_arg_num + 1, arg_ptr, arg_len);
			     if index (arg, "-") = 1 then no_more_names = "1"b;
			     else do;
				     if arg_len > 32 then call error (mrds_error_$rst_name_too_long, "^/" || arg ||
					     "^/Names are limited to 32 characters.");
				     name_list.num_names = name_list.num_names + 1;
				     name_list.name (name_list.num_names) = arg;
				     last_arg_num = last_arg_num + 1; /* Cause we used an argument */
				     number_args_used = number_args_used + 1;
				end;
			end;

		     end;				/* Not a control arg */

	     end;					/* End if last_arg_num+1 >nargs */

	assigned_name_list_ptr = name_list_ptr;

     end build_name_list;
%page;
/*  * * * * * * * * * * * *       error       * * * * * * * * * * * * * */

error: proc (err_code, err_message);			/* Error procedure for rmdb_create_relation.pl1 */

	dcl     err_code		 fixed bin (35);
	dcl     err_message		 char (*);
	dcl     saved_code		 fixed bin (35);
	dcl     ssu_$abort_line	 entry () options (variable);

	err_flag = "1"b;
	saved_code = err_code;

	call tidy_up;
	if ep = REQUEST then
	     call ssu_$abort_line (sci_ptr, saved_code, err_message);

	else call com_err_ (saved_code, my_name, err_message);
	goto exit;


     end error;

%page;
/*  * * * * * * * * * * * *       tidy_up       * * * * * * * * * * * * * */

tidy_up: proc;
						/* Cleanup request allocations if any */

	if ep = REQUEST & mrds_dm_display_info_ptr ^= null then do;

		if mrds_dm_display_info.dom_name_list_ptr ^= null then
		     free mrds_dm_display_info.dom_name_list_ptr -> name_list;
		if mrds_dm_display_info.attr_name_list_ptr ^= null then
		     free mrds_dm_display_info.attr_name_list_ptr -> name_list;
		if mrds_dm_display_info.rel_name_list_ptr ^= null then
		     free mrds_dm_display_info.rel_name_list_ptr -> name_list;
		if mrds_dm_display_info.index_name_list_ptr ^= null then
		     free mrds_dm_display_info.index_name_list_ptr -> name_list;

		free mrds_dm_display_info;

	     end;

	if delete_xref_file_flag & mrds_dm_display_info_ptr ^= null
	then if ep = COMMAND
	     then call mu_db_xref$xref_destroy (mrds_dm_display_info_ptr, mrds_dm_display_info.temp_dir_path,
		     mrds_dm_display_info.xref_name, (""), (0));
	     else call mu_db_xref$xref_destroy (rmdb_ctl.crossref_file_info.iocb_ptr,
		     rmdb_ctl.temp_dir_path, rmdb_ctl.crossref_file_info.name, (""), (0));

	if temp_seg_ptr ^= null then
	     call release_temp_segment_ (my_name, temp_seg_ptr, (0));

	if we_made_temp_dir_flag then do;		/* If we created it we need to delete it */

		call hcs_$del_dir_tree (temp_dir_father_dir, temp_dir_name, code); /* Remove entries below it */
		if code = error_table_$notadir | code = 0 then
		     call hcs_$delentry_file (temp_dir_father_dir, temp_dir_name, (0));
	     end;

	if out_iocb_ptr ^= null then do;		/* Output file cleanup */

	          call close_file (out_iocb_ptr);
		if err_flag then /* If an error occured delete it too */
		     call delete_$path (of_dir, of_ent, "100100"b, "rmdb_rq_dmdm", (0));
	     end;

	if dbm_ptr ^= null & terminate_file_flag then do; /* db_model file cleanup */
	     call terminate_file_ (dbm_ptr, 0, TERM_FILE_TERM, (0));
	     terminate_file_flag = "0"b;
	     end;

	return;

close_file:
	proc (p);

dcl  p ptr parameter;

	if p ^= null then do;
	     call iox_$close (p, (0));
	     call iox_$detach_iocb (p, (0));
	     call iox_$destroy_iocb (p, (0));
	     end;

	return;
     end close_file;

     end tidy_up;
%page;
	dcl     absolute_database_path char (168);
	dcl     adjust_bit_count_	 entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35));
	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     args_used		 fixed bin;
	dcl     arg_len		 fixed bin (21);
	dcl     arg_ptr		 ptr;
	dcl     bcnt		 fixed bin (35);
	dcl     brief_flag		 bit (1);
	dcl     cleanup		 condition;
	dcl     cmdb_arg_found	 bit (1);
	dcl     code		 fixed bin (35);
	dcl     COMMAND		 fixed bin static options (constant) init (1);
	dcl     com_err_		 entry () options (variable);
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     dbm_ptr		 ptr;
	dcl     dbp		 char (168);
	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));
	dcl     delete_xref_file_flag	 bit (1) aligned;
	dcl     dmd_$get_secured_state entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     empty		 builtin;
	dcl     ep		 fixed bin;
	dcl     error_table_$insufficient_access fixed bin (35) ext static;
	dcl     error_table_$badcall	 fixed bin (35) ext static;
	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$bad_subr_arg fixed bin (35) ext static;
	dcl     error_table_$inconsistent fixed bin (35) ext static;
	dcl     error_table_$moderr	 fixed bin (35) ext static;
	dcl     error_table_$noarg	 fixed bin (35) ext static;
	dcl     error_table_$notadir	 fixed bin (35) ext static;
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;
	dcl     err_flag		 bit (1);
	dcl     err_msg		 char (256);
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     first_arg_number	 fixed bin;
	dcl     get_group_id_$tag_star entry () returns (char (32));
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     hcs_$append_branchx	 entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
	dcl     hcs_$delentry_file	 entry (char (*), char (*), fixed bin (35));
	dcl     hcs_$del_dir_tree	 entry (char (*), char (*), fixed bin (35));
	dcl     i			 fixed bin;
          dcl     incon_flag             bit (1);
          dcl     incon_message          char (200);
          dcl     incon_name             char (32);
          dcl     index		 builtin;
	dcl     initiate_file_	 entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
	dcl     ioa_$rs		 entry () options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     iox_$user_output	 ptr ext static;
	dcl     last_arg_num	 fixed bin;
	dcl     length		 builtin;
	dcl     mdbm_util_$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
          dcl     mdbm_util_$inconsistent_get_info entry options(variable);
	dcl     mrds_control_arg_found bit (1);
	dcl     mrds_dm_authorization$set_needed_access entry (char (*), fixed bin (35));
	dcl     mrds_dm_display	 entry (ptr, char (*), fixed bin (35));
	dcl     mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_dsl_resultant_storage$get_temp_dir entry () returns (char (168));
          dcl     mrds_error_$inconsistent_database fixed bin (35) ext static;
	dcl     mrds_error_$no_database fixed bin (35) ext static;
	dcl     mrds_error_$no_db_path fixed bin (35) ext static;
	dcl     mrds_error_$no_model_access fixed bin (35) ext static;
	dcl     mrds_error_$no_model_submodel fixed bin (35) ext static;
	dcl     mrds_error_$rst_name_too_long fixed bin (35) ext static;
	dcl     mu_db_xref$xref_destroy entry (ptr, char (*), char (*), char (*), fixed bin (35));
	dcl     my_name		 char (16);
	dcl     nargs		 fixed bin;
	dcl     no_header_flag	 bit (1);
	dcl     no_more_names	 bit (1);
	dcl     null		 builtin;
	dcl     of_attach_desc	 char (200);
	dcl     of_dir		 char (168);
	dcl     of_ent		 char (32);
	dcl     of_flag		 bit (1);
	dcl     of_path		 char (168);
	dcl     of_switch_name	 char (32);
	dcl     out_iocb_ptr	 ptr;
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     REQUEST		 fixed bin static options (constant) init (2);
	dcl     rings		 (3) fixed bin (3) init ((3) 7);
          dcl     mrds_rst_$execute_undo entry (ptr, char (32), char (168), ptr, char (32), char (100));
	dcl     rtrim		 builtin;
	dcl     sci_ptr		 ptr;
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     STREAM_OUTPUT	 int static options (constant) init (2);
	dcl     string		 builtin;
	dcl     structure_version	 fixed bin;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     td_dir		 char (168);
	dcl     td_ent		 char (32);
	dcl     temp_dir_father_dir	 char (168);
	dcl     temp_dir_flag	 bit (1);
	dcl     temp_dir_name	 char (32);
	dcl     temp_seg_ptr	 ptr;
	dcl     terminate_file_	 entry (ptr, fixed bin(24), bit(*), fixed bin(35));
	dcl     terminate_file_flag	 bit (1) aligned;
          dcl     undo_request           char (100);
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     wa		 area (sys_info$max_seg_size) based (work_area_ptr);
	dcl     we_made_temp_dir_flag	 bit (1);
	dcl     work_area_ptr	 ptr;

%page;
%include access_mode_values;
%page;
%include mrds_rmdb_ctl;
%page;
%include mrds_dm_display_info;
%page;
%include mrds_path_info;
%page;
%include mrds_authorization;
%page;
%include mrds_database_state;
%page;
%include terminate_file;

     end display_mrds_dm;




		    display_mrds_dsm.pl1            03/08/88  1538.8rew 03/08/88  1530.1      159831



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



/****^  HISTORY COMMENTS:
  1) change(88-01-18,Blair), approve(88-02-25,MCR7840), audit(88-03-03,Dupuis),
     install(88-03-08,MR12.2-1034):
     Don't expand the pathname arg if it is just an entryname because we want
     to find it using the "mrds" searchlist".  SCP 6366.
                                                   END HISTORY COMMENTS */


display_mrds_dsm: dmdsm: proc;

/* DESCRIPTION:

   This  procedure  implements the display_mrds_dsm command which provides the
   capability  to display an existing MRDS data submodel.  Various options are
   provided,  allowing  the user to display information varying in detail from
   relation names only, to all information contained in the data submodel plus
   information from the corresponding data model.  It is also possible for the
   user to display this information for only specified relations.



   HISTORY:

   81-05-18 Rickie E. Brinegar:  Completely rewritten.

   81-06-04 Davids:  removed  the  use  of  the  mrds_dsm_header_str
   include  file.  Replaced  the  call  to mrds_dsm_read_header with
   mrds_dsm_read_header$db_path. Added code to increment the counter
   in the control arg processing loop.

   81-06-05 Rickie E. Brinegar: Made some auditing changes.

   81-06-09     Rickie     E.      Brinegar:     Modified     to    set    the
   mrds_dsm_display_info.submodel_secured bit for secured databases.

   83-06-17 Davids: Modified so that mrds_dsl_get_version$get_path_info is called
   to determine the version of the submodel instead of just opening the submodel
   and looking at the header structure. This was done so that version checking is 
   localized to 1 module. Also an error is now reported if a version 1 submodel
   is referenced (actually error code is returned by mrds_dsl_get_version). The
   code to generate a call to dmdsm_v1 has been deleted.
*/

%include mrds_path_info;
%page;
%include mrds_authorization;
%page;
%include mrds_database_state;
%page;
%include mrds_dsm_display_info;
%page;
%include mrds_dsm_relation_names;

/* AUTOMATIC */

	dcl     output_file_switch	 char (26);	/* iocb switch name for output */
          dcl     suffixed_name          char (32);         /* entryname with suffix */  
	dcl     submodel_entry	 char (168) init (""); /* for use with expand_pathname_ and
						   mrds_dm_secured_submodel */
	dcl     submodel_directory	 char (168) init (""); /* for use with expand_pathname_ and
						   mrds_dm_secured_submodel */

	dcl     (arg_len,				/* length of current arg */
	        i,				/* internal index */
	        nargs)		 fixed bin;	/* no. of input arg */

	dcl     code		 fixed bin (35);	/* status code */

	dcl     (arg_ptr		 init (null),	/* pointer to current arg */
	        submodel_iocb_ptr	 init (null),	/* pointer to the open submodel */
	        wa_ptr		 init (null)) ptr;	/* pointer to work area */

	dcl     (db_path,				/* database path from mrds_dsl_get_version */
	        output_file		 init (""),	/* path name of the output file */
	        output_file_attach,			/* absolute pathname of output file */
	        sm_path)		 char (168);	/* absolute sm_path */

/* BASED */

	dcl     work_area		 area (sys_info$max_seg_size) based (wa_ptr);
						/* scratch space */
	dcl     arg		 char (arg_len) based (arg_ptr);
						/* current argument */

/* BUILTINS */

	dcl     (empty,
	        null,
	        rtrim,
                  search,
	        substr)		 builtin;


/* CONDITIONS */

	dcl     cleanup		 condition;


/* CONSTANTS */

	dcl     DSM_SUFFIX		 init ("dsm") char (3) internal static options (constant);
          dcl     MRDS_SEARCHLIST        init ("mrds") char (4) internal static options (constant);


/* EXTERNAL */

	dcl     (error_table_$badcall,
	        error_table_$badopt,
	        error_table_$not_act_fnc,
	        error_table_$wrong_no_of_args,
	        mrds_error_$missing_relation_name,
	        mrds_error_$no_model_submodel,
	        mrds_error_$version_1_dsm,
	        sys_info$max_seg_size) fixed bin (35) ext;

	dcl     iox_$user_output	 ptr ext;


/*  ENTRIES */

	dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35));
          dcl     absolute_pathname_$add_suffix entry (char (*), char(*), char(*), fixed bin(35));
	dcl     com_err_		 entry options (variable);
	dcl     cu_$af_arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_dm_db_secured$get_secured_state entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_dm_secured_submodel entry (char (*), char (*), char (*)) returns (bit (1));
	dcl     mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	dcl     mrds_dsm_close$force	 entry (ptr);
	dcl     mrds_dsm_dmdsm	 entry (ptr, fixed bin (35));
	dcl     mrds_dsm_open$read	 entry (char (*), ptr, fixed bin (35));
	dcl     mrds_dsm_read_header$db_path entry (ptr, char (168), fixed bin (35));
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
          dcl     suffixed_name_$make    entry (char(*), char(*), char(32), fixed bin(35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));


/* ****************************************************************************
   INITIALIZATION
   **************************************************************************** */

	on cleanup call tidy_up;

	call get_temp_segment_ ("dmdsm", wa_ptr, code);	/* This temp segment should be in a lower ring
						   to preclude subversion of security */
	if code ^= 0 then
	     call error (code, "^/Trying to get a temp segment");

	work_area = empty;

	mrds_dsm_display_info_ptr,
	     mrds_dsm_relation_names_ptr = null;



/* ****************************************************************************
   Get information about the control arguments
   **************************************************************************** */

	call cu_$af_arg_count (nargs, code);		/* get no. of args  and insure not called as an
						   active function */
	if code ^= error_table_$not_act_fnc then do;
		if code = 0 then
		     call error (error_table_$badcall, "display_mrds_dsm may not be called as an active function.");
		else
		     call error (code, "^/Finding the number of arguments");
	     end;

	if nargs < 1 then /* give him a hint */
	     call error (error_table_$wrong_no_of_args, "^/Usage:  dmdsm dsm_path {-control_args}" ||
		"^/Where -control_args may be: -access -bf -cmdsm -lg -no_acess -no_output_file" ||
		"^/^29t-of -rel_names -relation REL_1 ... REL_N");



/* ****************************************************************************
   Get the datasubmodel version
   **************************************************************************** */

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);	/* get data submodel relative path */
	if code ^= 0 then
	     call error (code, "^/Getting data submodel relative path");

	if search (arg, "<>") = 0 then do;
	     call suffixed_name_$make (arg, DSM_SUFFIX, suffixed_name, code);
	     if code ^= 0 then
		call error (code, "^/Getting entryname of the data submodel: " || arg);
	     sm_path = suffixed_name;
	     end;
	else do;
	     call absolute_pathname_$add_suffix (arg, DSM_SUFFIX, sm_path, code);
						/* get absolute data submodel path */
	     if code ^= 0 then
		call error (code, "^/Getting absolute path of the data submodel: " || sm_path);
	     end;
	call mrds_dsl_get_version$get_path_info (sm_path, wa_ptr, mrds_path_info_structure_version,
	     mrds_path_info_ptr, code);
	if code ^= 0
	then do;
		if code = mrds_error_$no_model_submodel
		then call error (code, "^/Unable to open the submodel at: " || sm_path);
		else if code = mrds_error_$version_1_dsm
		then call error (code, "^/" || sm_path);
		else call error (code, "^/Unable to get the version of the data submodel: " || sm_path);
	     end;
	else sm_path = mrds_path_info.absolute_path;
	
	call mrds_dsm_open$read (sm_path, submodel_iocb_ptr, code);
	if code ^= 0 then
	     call error (code, "^/Unable to open the submodel: " || sm_path);


/* ****************************************************************************
   Initialize the control structure for mrds_dsm_dmdsm and process the control
   arguments to be used in filling in the control structure
   **************************************************************************** */

	allocate mrds_dsm_display_info in (work_area);

	mrds_dsm_display_info.version = MRDS_DSM_DISPLAY_INFO_VERSION;
	mrds_dsm_display_info.rel_names_array_ptr = null;
	mrds_dsm_display_info.output_iocb_ptr = iox_$user_output;
	mrds_dsm_display_info.submodel_iocb_ptr = submodel_iocb_ptr;
	mrds_dsm_display_info.submodel_pathname = sm_path;
	mrds_dsm_display_info.format = "b";
	mrds_dsm_display_info.access = "1"b;

	i = 2;
	do while (i ^> nargs);			/* look at all args */
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);/* get this arg */
	     if code ^= 0
	     then call error (code, "control arg");

	     if arg = "-access" | arg = "-acc" then
		mrds_dsm_display_info.access = "1"b;
	     else
		if arg = "-brief" | arg = "-bf" then
		mrds_dsm_display_info.format = "b";
	     else
		if arg = "-cmdsm" then
		mrds_dsm_display_info.format = "c";
	     else
		if arg = "-long" | arg = "-lg" then
		mrds_dsm_display_info.format = "l";
	     else
		if arg = "-no_access" | arg = "-nacc" then
		mrds_dsm_display_info.access = "0"b;
	     else
		if arg = "-no_output_file" | arg = "-nof" then
		output_file = "";
	     else
		if arg = "-output_file" | arg = "-of" then do;
		     if i ^< nargs then
			call error (error_table_$wrong_no_of_args,
			     "^/A path must be given with the -of control argument");
		     i = i + 1;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if code ^= 0 then
			call error (code, "^/Getting output file name");
		     output_file = arg;
		end;
	     else
		if arg = "-rel_names" | arg = "-rn" then
		mrds_dsm_display_info.format = "r";
	     else
		if arg = "-relation" | arg = "-rel" then do;
		     call build_rel_list;		/* build mrds_dsm_relation_names structure */
		     mrds_dsm_display_info.rel_names_array_ptr = mrds_dsm_relation_names_ptr;
		end;
	     else
		call error (error_table_$badopt, "^/Bad argument is: " || arg);

	     i = i + 1;

	end;					/* control arg loop */



/* ****************************************************************************
   If an ouput file is to be used (-of was specified) then open the output file
   else use the user's user_output switch
   **************************************************************************** */

	if output_file ^= "" then do;
		call absolute_pathname_ (output_file, output_file_attach, code);
		if code ^= 0 then
		     call error (code, "^/Getting absolute path_name of output file: " || output_file);

		output_file_switch = unique_chars_ ("0"b) || ".mrds.dmdsm";

		call iox_$attach_name (output_file_switch, mrds_dsm_display_info.output_iocb_ptr,
		     "vfile_ " || rtrim (output_file_attach), null, code);
		if code ^= 0 then
		     call error (code, "^/Attaching output file: " || output_file_attach);

		call iox_$open (mrds_dsm_display_info.output_iocb_ptr, 2, "0"b, code);
		if code ^= 0 then
		     call error (code, "^/Opening output file: " || output_file_attach);
	     end;
	else
	     mrds_dsm_display_info.output_iocb_ptr = iox_$user_output;



/* ****************************************************************************
   Set the security switches.
   **************************************************************************** */

	call mrds_dsm_read_header$db_path (mrds_dsm_display_info.submodel_iocb_ptr, db_path, code);
						/* Get the absolute pathname of the data model
						   from the submodel */
	if code ^= 0 then
	     call error (code, "^/Getting the header record of submodel: " || mrds_dsm_display_info.submodel_pathname);

	call mrds_dm_authorization$get_user_class (db_path, wa_ptr,
	     mrds_authorization_structure_version, mrds_authorization_ptr, code);

	if code ^= 0 then
	     call error (code, "^/Getting datamodel authorization information from submodel: "
		|| mrds_dsm_display_info.submodel_pathname);

	mrds_dsm_display_info.administrator = mrds_authorization.administrator;

	call mrds_dm_db_secured$get_secured_state (db_path, wa_ptr,
	     database_state_structure_version, database_state_ptr, code);
	if code ^= 0 then
	     call error (code, "^/Getting database security state for submodel: "
		|| mrds_dsm_display_info.submodel_pathname);

	mrds_dsm_display_info.db_secured = database_state.secured;

	call expand_pathname_ (mrds_dsm_display_info.submodel_pathname,
	     submodel_directory, submodel_entry, code);
	if code ^= 0 then
	     call error (code, "^/Calling expand_pathname_ with " ||
		mrds_dsm_display_info.submodel_pathname);
	mrds_dsm_display_info.submodel_secured = mrds_dm_secured_submodel (db_path,
	     submodel_directory, submodel_entry);

	if mrds_dsm_display_info.db_secured & ^mrds_dsm_display_info.administrator &
	     mrds_dsm_display_info.format = "c" then
	     call error (0, "^/The -cmdsm argument is only useable by administrators for secured databases");

	call mrds_dsm_dmdsm (mrds_dsm_display_info_ptr, code);
	if code ^= 0 then
	     call error (code, "^/Creating the display for submodel: "
		|| mrds_dsm_display_info.submodel_pathname);



/* ****************************************************************************
   All done, one way or another. Time to clean up and leave.
   **************************************************************************** */

exit:
	call tidy_up;				/* clean up our mess */
	return;


/* ****************************************************************************
   Process the -relation control argument, building a list of relations to be
   displayed by mrds_dsm_dmdsm.
   **************************************************************************** */

build_rel_list:
     proc;

	if mrds_dsm_relation_names_ptr ^= null then /* -relation is not additive */
	     mrds_dsm_relation_names.nrels = 0;
	else do;
		mrds_dsm_relation_names_nrels_alloc = nargs - i; /*  can't have more rels
						   than the number of arguments left */
		allocate mrds_dsm_relation_names in (work_area);
		mrds_dsm_relation_names.nrels = 0;	/* initialize */
	     end;

	call cu_$arg_ptr (i + 1, arg_ptr, arg_len, code); /* get first rel name */
	if code ^= 0 then
	     call error (code, "^/Attempting to get a relation name");

	do while (i < nargs & substr (arg, 1, 1) ^= "-"); /* for all relatins names */

	     mrds_dsm_relation_names.nrels = mrds_dsm_relation_names.nrels + 1;
						/* keep count of rels */
	     mrds_dsm_relation_names.relation (mrds_dsm_relation_names.nrels) = arg;
						/* save rel name */
	     i = i + 1;
	     if i < nargs then do;
		     call cu_$arg_ptr (i + 1, arg_ptr, arg_len, code);
						/* get next arg */
		     if code ^= 0 then
			call error (code, "^/Getting an additional relation name");
		end;
	end;					/* relation name loop */

	if mrds_dsm_relation_names.nrels <= 0 then
	     call error (mrds_error_$missing_relation_name, "^/-relation");

     end build_rel_list;


/* ****************************************************************************
   Print any diagnostics and leave the command, which cleans up on exit.
   **************************************************************************** */

error:
     proc (code, string);

	dcl     code		 fixed bin (35);
	dcl     string		 char (*);

	call com_err_ (code, "display_mrds_dsm", string);
	go to exit;

     end error;


/* ****************************************************************************
   Clean up anything that was left laying around.
   **************************************************************************** */

tidy_up:
     proc;

	if wa_ptr ^= null then do;
		if mrds_dsm_display_info_ptr ^= null then do;
			if output_file ^= "" & mrds_dsm_display_info.output_iocb_ptr ^= null then do;
				call iox_$close (mrds_dsm_display_info.output_iocb_ptr, code);
				call iox_$detach_iocb (mrds_dsm_display_info.output_iocb_ptr, code);
				call iox_$destroy_iocb (mrds_dsm_display_info.output_iocb_ptr, code);
			     end;
			if submodel_iocb_ptr ^= null then
			     call mrds_dsm_close$force (submodel_iocb_ptr);
			free mrds_dsm_display_info;
		     end;
		if mrds_dsm_relation_names_ptr ^= null then
		     free mrds_dsm_relation_names;
		call release_temp_segment_ ("dmdsm", wa_ptr, code);
	     end;
     end tidy_up;

     end display_mrds_dsm;




		    display_mrds_open_dbs.pl1       04/18/85  1424.3re  04/18/85  0906.3       46602



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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



display_mrds_open_dbs: dmod: procedure ();

/* DESCRIPTION:

   this routine is to be called from command level,  to  display  on
   the terminal the database pathnames and opening indexes for those
   databases that are open by this process.  the  opening  may  have
   been  either  a  model  or  submodel  openings, but must be a new
   architecture(post MR6 style) database.

*/

/* PARAMETERS:

   (input) none

   (output) a formatted list of database opening  indexes,  and  the
   model or submodel path of the opening.

   command_error - - (output) condition, signaled upon occurence  of
   an error

*/

/* HISTORY:

   79-07-01 Jim Gray: Initially written.

   80-12-08 Rickie E. Brinegar: The display of the opening mode  was
   added. Also changed the call to ioa_ to take a conditional clause
   in the ioa_ edit string rather than  having  an  if-then-else  in
   pl1.

   81-01-30 Jim Gray : changed  underlying  routine  being  used  to
   dsl_$list_openings to take advantage of better interface.

   81-04-25 Jim Gray : changed based_area declaration to  have  it's
   size  depend  on  current  value  of  mrds_data_$max_dbs, so that
   changing it's value automatically changes the number of  openings
   allowed

*/

/* initialize an area for the parameter structure, and establish a clean up handler */

	area_ptr = null ();
	clean_up_condition = OFF;
	on cleanup begin;
		clean_up_condition = ON;
		call clean_up ();
	     end;

	call get_temp_segment_ (caller_name, area_ptr, error_code);
	if error_code ^= 0 then
	     call com_err_ (error_code, caller_name, "^/^a",
		"Unable to create a temporary segment for the list of open databases.");
	else do;

		based_area = empty ();		/* initialize area */


/* get the database list structure filled in */

		call mrds_dsl_db_openings$list_openings (area_ptr, mrds_database_openings_structure_version,
		     mrds_database_openings_ptr, error_code);

		if error_code ^= 0 then
		     call com_err_ (error_code, caller_name, "^/^a",
			"Unable to get the list of open databases.");
		else do;

			if mrds_database_openings.number_open = 0 then
			     call ioa_ ("^/No databases are currently open.^/");
			else do;

				call ioa_ ("^/Open database^[ is^;s are^]:", (mrds_database_openings.number_open = 1));

				do i = 1 by 1 to mrds_database_openings.number_open;

				     call ioa_ ("^d^-^a^/^-^a", mrds_database_openings.db (i).index,
					mrds_database_openings.db (i).path,
					mrds_database_openings.db (i).mode);

				end;

				call ioa_ ("^/");
			     end;

		     end;

	     end;

/* get rid of the temp segment */

	call clean_up ();

	return;

clean_up: procedure ();

/* remove the temporary segment when done, or when cleanup signaled */

	if area_ptr = null () then ;
	else do;

		call release_temp_segment_ (caller_name, area_ptr, error_code);
		area_ptr = null ();
		if error_code = 0 | clean_up_condition then ;
		else call com_err_ (error_code, caller_name, "^/^a",
			"Unable to release the temporary segment used for the database list.");

	     end;

     end;

	dcl     cleanup		 condition;	/* signaled upon quit/release */
	dcl     OFF		 bit (1) init ("0"b); /* false value */
	dcl     ON		 bit (1) init ("1"b); /* true value */
	dcl     area_ptr		 ptr;		/* points to parameter area */
	dcl     based_area		 area (60 * mrds_data_$max_dbs) based (area_ptr); /* parameter area */
	dcl     com_err_		 entry options (variable); /* reports errors */
	dcl     clean_up_condition	 bit (1);		/* on => cleanup signaled */
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* gets temporary segments */
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* deletes temporary segments */
	dcl     error_code		 fixed bin (35);	/* error status encoding */
	dcl     caller_name		 char (21) init ("display_mrds_open_dbs"); /* name of calling routine */
	dcl     mrds_dsl_db_openings$list_openings entry (ptr, fixed bin, ptr, fixed bin (35)); /* gets list of open dbs */
	dcl     i			 fixed bin;	/* loop control */
	dcl     ioa_		 entry options (variable);
	dcl     mrds_data_$max_dbs	 fixed bin (35) ext;/* max number of openings allowed */
	dcl     empty		 builtin;
	dcl     null		 builtin;

%include mrds_database_openings;

     end;




		    display_mrds_scope_settings.pl1 08/01/88  1408.1r w 08/01/88  1313.8       69453



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

/*
	     BEGIN_DESCRIPTION
   This command will display, for all open MRDS databases
   in the users process, the current scope (concurrncy control mode)
   settings for all relations in the users view of the
   databse for that opening.

   It also gives the details of the type of opening, submodel or model,
   the paths of the submodel and model, and the versions
   of the submodel and model.

   The concurrency control version is displayed.
   1 => r-s-m-d scope mdoes.
   2-3 => never released
   4 => r-u scope modes.
   5 => r-a-m-d scope modes.

   Old version databases can not display whether
   the opening was via a submodel or not.
	     END_DESCRIPTION
*/

/* HISTORY:

   Originally written by Jim Gray - - January 1981

   83-02-15 Davids: explicitly declared variables that were
   declared by context or implication and deleted declarations
   to variables that were not referenced.

   83-06-21 Davids: Removed check for old version database and the call
   to v1 code if it was an old version db (old version dbs can no longer
   be opened)
*/

display_mrds_scope_settings: dmss: procedure ();

/* PARAMETERS:

   (input) none

   (output) display by opening index, and by relation,
   the currenct scope settings in the users process,
   plus info on the type/version of the opening.

*/

/* initialize */

	number_of_openings = mu_database_index$get_number_open_dbs ();
	number_found = 0;

	if number_of_openings = 0 then
	     call ioa_ ("^/No databases are currently open.^/");
	else do;

/* display the process information for the caller */

		call ioa_ ("^/Scope settings for process:  ^a^/^12xprocess number:  ^o",
		     get_group_id_ (), get_process_id_ ());

/* find all current valid database indexs */

		do db_index = 1 by 1 to mrds_data_$max_dbs while (number_found < number_of_openings);

		     call mu_database_index$get_resultant_model_pointer (db_index, dbcb_ptr);
		     if dbcb_ptr = null () then ;	/* does not refer to an open database */
		     else do;

/* good opening index found, display details */

			     number_found = number_found + 1;

			     rdbi_ptr = dbcb.rdbi_ptr;
			     dbc_ptr = dbcb.dbc_ptr;

			     call display_opening_info ();

			     call display_new_scope ();

			end;

		end;

/* finish up */

		call ioa_ ("^/");


	     end;

display_opening_info: procedure ();

/* routine to display the path(s) of the open data/sub model,
   the opening mode and index, and their versions */

/* get opening mode */

	if fixed (dbcb.open_mode) = 0 then
	     open_mode_display = "Unknown open mode";
	else if fixed (dbcb.open_mode) = 1 then
	     open_mode_display = "retrieval";
	else if fixed (dbcb.open_mode) = 2 then
	     open_mode_display = "update";
	else if fixed (dbcb.open_mode) = 3 then
	     open_mode_display = "exclusive_retrieval";
	else if fixed (dbcb.open_mode) = 4 then
	     open_mode_display = "exclusive_update";
	else open_mode_display = "Illegal open mode";

	call ioa_ ("^/Opening index:  ^d^/^9xmode:  ^a^/", db_index, open_mode_display);

/* output db path and version info */

	call ioa_ ("^-Concurrency control version:  ^d^/^-^8xdatabase model path:  ^a^/^-^10x database version:  ^d",
	     dbc.version, rm_db_info.db_path, rm_db_info.db_version);

/* display submodel info, if submodel opening */

	if dbcb.dsm_sw then do;
		call ioa_ ("^/^-^8xOpened via submodel:  ^a^/^-^11xsubmodel version:  ^d",
		     rm_db_info.sm_path, rm_db_info.sm_version);
	     end;

     end;

display_new_scope: procedure ();

/* routine to display r-a-m-d type scope from new version databases */

	scope_ptr = dbcb.scope_ptr;
	if scope_ptr = null () then
	     call com_err_ (mrds_error_$non_scope_ready, caller_name,
		"^/Unable to get scope info for opening index ^d^/", db_index);
	else do;

		if scope_info.active_scopes = 0 then
		     call ioa_ ("^/^-No scope currently set for this opening.^/");
		else do;

			call ioa_ ("^/^-Relation^26xPermits^3xPrevents^/");

			do i = 1 to scope_info.nfiles;

			     if scope_info.scope (i).flags.touched then do;

				     prevent_string, permit_string = "";

				     if scope_info.scope (i).flags.permits.read_attr then
					permit_string = permit_string || "r";

				     if scope_info.scope (i).flags.permits.append_tuple then
					permit_string = permit_string || "a";

				     if scope_info.scope (i).flags.permits.modify_attr then
					permit_string = permit_string || "m";

				     if scope_info.scope (i).flags.permits.delete_tuple then
					permit_string = permit_string || "d";

				     if permit_string = "" then
					permit_string = "n";

				     if scope_info.scope (i).flags.prevents.read_attr then
					prevent_string = prevent_string || "r";

				     if scope_info.scope (i).flags.prevents.append_tuple then
					prevent_string = prevent_string || "a";

				     if scope_info.scope (i).flags.prevents.modify_attr then
					prevent_string = prevent_string || "m";

				     if scope_info.scope (i).flags.prevents.delete_tuple then
					prevent_string = prevent_string || "d";

				     if prevent_string = "" then
					prevent_string = "n";

				     call ioa_ ("^-^32a^4x^4a^6x^4a",
					scope_info.scope (i).sm_name, permit_string, prevent_string);
				end;

			end;

		     end;
%include mdbm_scope_info;

	     end;

     end;

	declare db_index		 fixed bin (35);	/* database opening index */
	declare open_mode_display	 char (24) varying; /* output form of opening mode */
	declare mrds_data_$max_dbs	 fixed bin (35) ext;/* maximum number of open databases */
	declare number_of_openings	 fixed bin;	/* current number of open dbs */
	declare number_found	 fixed bin;	/* number already displayed */
	declare mu_database_index$get_resultant_model_pointer entry (fixed bin (35), ptr); /* gets ptr from index */
	declare mu_database_index$get_number_open_dbs entry returns (fixed bin); /* get count of dbs currently open */
	declare ioa_		 entry options (variable); /* does output reporting */
	declare mrds_error_$non_scope_ready fixed bin (35) ext; /* rel not readied for scope concurrency */
	declare com_err_		 entry options (variable); /* reports errors */
	declare caller_name		 char (32) init ("display_mrds_scope_settings"); /* name of calling routine */
	declare (permit_string, prevent_string) char (4) varying; /* for displaying scope settings */
	declare work_area		 area (4096);	/* space for scope info */
	declare i			 fixed bin;	/* loop index into array */
	declare get_group_id_	 entry returns (char (32)); /* gets person.project.tag */
	declare get_process_id_	 entry returns (bit (36)); /* gets identifier of process */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
	declare (fixed, addr, rel,
	        empty, null)	 builtin;

%include mrds_dbcb;

%include mdbm_dbc;

%include mdbm_rm_db_info;

     end;




		    display_mrds_temp_dir.pl1       04/18/85  1424.3re  04/18/85  0906.3       58599



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

/* HISTORY:

   Originally written by Jim Gray - - August 1979
   Modified by Jim Gray - - 80,9-24, to make use of the new common
   routine dsl_$get_opening_temp_dir, for getting the temp dir of a particular opening.

*/

display_mrds_temp_dir: dmtd: procedure ();

/* DESCRIPTION:

   this routine is called from command level with one argument,
   to display either the temporary storage that is being
   used by a currently open MRDS database by giving the
   database index returned by the call to dsl_$open,
   or the current temporary directory that would be used
   by the next call to dsl_$open by giving "-cur"
   or "-current" as the argument, instead of a database index.
   the display is a pathname down the temporary directory.
   the current pathname can be changed by a call to the command
   set_mrds_temp_dir, giving the new path as the argument.

*/

/* PARAMETERS:

   database_index - - (input) an integer between 1 and 64, that was returned by
   a call to dsl_$open, for that particular database opening.
   both a database index and the "-current" argument can not be given.

   option - - (input) either "-current" or "-cur" may be given in place of a database
   index, but not both.

   temporary_directory - - (output) pathname donw to the directory where temporary storage will/is to be stored.
   if a database index was the input, the temporary storage directory
   for that opening is dislayed, for the -current option, the temporary directory
   that would be used for the next open will be displayed.

   error_messages - - (output) via com_err_, in case unrecogizable, insufficient,
   or invalid arguments are given

*/

/* check for only one argument */

	call cu_$arg_count (nargs);
	if nargs ^= 1 then
	     call com_err_ (error_table_$wrong_no_of_args, caller_name, "^/^a ^d ^a",
		"The number of arguments =", nargs, "was not 1, either a database index, or ""-current"" option.");
	else do;

/* get the argument, and check for option or index */

		call cu_$arg_ptr (1, arg_ptr, arg_len, error_code);
		if error_code ^= 0 then
		     call com_err_ (error_code, caller_name, "^/^a", "Unable to obtain the given argument.");
		else do;
			if argument = "-current" | argument = "-cur" then do;

/* get current status of temporary directory pathname */

				pathname = mrds_dsl_resultant_storage$get ();
				call display_path (ON);
			     end;
			else do;

/* check for a valid database index */

				valid_index = ON;
				if verify (argument, "0123456789") ^= 0 | length (argument) > 2 then valid_index = OFF;
				else do;
					database_index = fixed (argument);
					if database_index < 1 | database_index > mrds_data_$max_dbs then valid_index = OFF;
				     end;
				if ^valid_index then call com_err_ (error_table_$bad_arg, caller_name, "^/^a^a^a ^d^a",
					"The database index argument """, argument,
					""" is not an integer between 1 and", mrds_data_$max_dbs, ".");
				else do;

/* good index, get a pathname from the dbcb segment pointer */

					pathname = mrds_dsl_resultant_storage$get_opening_temp_dir (database_index, error_code);
					if error_code ^= 0 then
					     call com_err_ (error_code, caller_name, "^/^a^d^a",
						"The database index """, database_index,
						""" could not be expanded into a temporary directory pathname.");
					else call display_path (OFF);
				     end;
			     end;
		     end;
		return;
	     end;

display_path: procedure (current_option);

/* output the temporary directory pathname obtained */

	if pathname = BLANK then do;

		call ioa_ ("^/The temporary directory is not set, it will default to the user's process directory.^/");

	     end;

	else do;

		if current_option then
		     call ioa_ ("^/The current temporary directory is:^/");
		else call ioa_ ("^/The temporary directory for database index ^d is:^/", database_index);

		call ioa_ ("^a^/", pathname);

	     end;



	declare current_option	 bit (1);		/* on => -current option, else database index */

     end;

	declare BLANK		 char (1) init (" "); /* space character */
	declare mrds_dsl_resultant_storage$get_opening_temp_dir entry (fixed bin (35), fixed bin (35))
				 returns (char (168)); /* gets temp dir for db index */
	declare database_index	 fixed bin (35);	/* opening index */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare caller_name		 char (21) init ("display_mrds_temp_dir"); /* name of calling routine */
	declare pathname		 char (168);	/* temp dir path to be displayed */
	declare error_table_$bad_arg	 fixed bin (35) ext;/* bad command argument */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* arg count ^= 1 */
	declare nargs		 fixed bin;	/* current argument count */
	declare cu_$arg_count	 entry (fixed bin); /* gets number of arguments */
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); /* gets argument */
	declare arg_ptr		 ptr;		/* points to argument */
	declare arg_len		 fixed bin (21);	/* length of argument */
	declare argument		 char (arg_len) based (arg_ptr); /* input argument */
	declare com_err_		 entry options (variable); /* reports errors */
	declare mrds_dsl_resultant_storage$get entry returns (char (168)); /* gets current temp dir */
	declare ioa_		 entry options (variable); /* displays/formats pathname */
	declare (verify, length, fixed) builtin;
	declare ON		 bit (1) init ("1"b); /* true value */
	declare OFF		 bit (1) init ("0"b); /* false value */
	declare valid_index		 bit (1);		/* on => good db index value */
	declare mrds_data_$max_dbs	 fixed bin (35) ext;/* most open dbs at one time */


     end;




		    dmd_.alm                        08/15/86  1553.5rew 08/15/86  1437.1       19494



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1981 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-06-13,Dupuis), approve(86-08-05,MCR7491),
"     audit(86-08-08,Blair), install(86-08-15,MR12.0-1127):
"     Made available so that an unbound version of mrds could be created
"     easily. (phx20405, mrds #157)
"                                                      END HISTORY COMMENTS

"HISTORY:
"
"Modified by Jim Gray - - 80-11-04, to add secure_bit interface entries
"
"81-01-23 Jim Gray : changed secure bit entries to module mrds_dm_db_secured
"		 and added mrds_dm_authorization entries
"
"81-02-01 Jim Gray : removed set entries from dmd_ for mrds_dm_authorization
"and mrds_dm_db_secured, as the dmd_dsl_changes proposal indicates only the get's
"be available entries
"
"81-02-10 Jim Gray : moved get_user_class and get_secured_status entries
"from dmd_ to new mmi_ interface
"
"81-04-22 Jim Gray : removed get_files and get_file_rels entries,
"as these are not documented dmd_ interfaces, and are unused.
"
"81-05-26 Jim Gray : added check_path and set_needed_access entries so that CMDB
"can call it from a separate bound segment.
"
"
"83-01-10 Roger Lackey : Added get_secured_state so mrds would not be using mmi_.
	name	dmd_

	entry	check_path
check_path:
	tra	<mrds_dm_check_path>|[check_path]

	entry	create_db
create_db:
	tra	<mrds_dm_create_db>|[create_db]

	entry	close_dm
close_dm:
	tra	<mrds_dm_close>|[close_dm]

	entry	get_header
get_header:
	tra	<mrds_dm_get_header>|[get_header]

	entry	get_attributes
get_attributes:
	tra	<mrds_dm_get_attributes>|[get_attributes]

	entry	get_relations
get_relations:
	tra	<mrds_dm_get_relations>|[get_relations]

	entry	get_secured_state
get_secured_state:
	tra	<mrds_dm_db_secured>|[get_secured_state]

	entry open_dm
open_dm:
	tra	<mrds_dm_open>|[open_dm]

	entry	set_needed_access
set_needed_access:
	tra	<mrds_dm_authorization>|[set_needed_access]

	end




		    dsl_.alm                        08/15/86  1553.5rew 08/15/86  1436.7       47790



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

" HISTORY COMMENTS:
"  1) change(86-06-13,Dupuis), approve(86-08-05,MCR7491),
"     audit(86-08-08,Blair), install(86-08-15,MR12.0-1127):
"     Made available so that an unbound version of mrds could be created
"     easily. (phx20405, mrds #157)
"                                                      END HISTORY COMMENTS
" 
" NOTES: 
"
" This is the transfer vector for the unbound version of dsl_
"
"
" HISTORY:
"
"80-04-01  Jim Gray : Modified to remove dsl_$define_area, and to canonize and
"sort the source
"
"80-09-24  Jim  Gray : Modified to add $get_opening_temp_dir entry so that the
"temp dir for a particular opening can be obtained.
"
"81-01-11  Jim Gray : added get_scope entry for new routine mrds_dsl_get_scope
"as part of implementing scope_vs_access proposal.
"
"81-01-13   Jim   Gray   :   added   get_access_info  entry  for  new  routine
"mrds_dsl_get_access_info as part of implementing scope_vs_access proposal
"
"81-01-14 Jim Gray : added get_attribute_list and get_relation_list entries as
"part of implementing the scope_vs_access proposal, and answering TR 7780
"
"81-01-23  Jim  Gray : deleted get_access_info, since this information will be
"part   of   the   get_relation/attribute_list   interface.   Also  added  the
"get_version extension get_path_info interface entry.
"
"81-01-30 Jim Gray : deleted list_db_with_modes, replacing it by list_openings
"and module mrds_dsl_list_dbs is now named mrds_dsl_db_openings
"
"81-03-26 Jim Gray : added entry for dsl_$get_population
"
"81-05-14 Rickie E.  Brinegar: added entry for dsl_$get_security_info.
"
"81-05-27   Jim   Gray   :   removed  unused  entries  eval_expr,  finish_all,
"finish_file, get_ready_files, get_scope_info, ready_all, ready_file
"
"81-06-16  Rickie  E.  Brinegar: renames get_file_names to get_rslt_rels while
"removing the file interfaces from LINUS.
"
"81-06-17 Rickie E.  Brinegar: added back get_scope_info entry in an effort to
"remove the internal static scope_data structure in LINUS.
"
"81-06-19   Rickie   E.   Brinegar:  removed  the  unused  entries  dl_fscope,
"dl_fscope_all,  get_file_relations,  get_rels,  get_rslt_desc, get_temp_desc,
"and set_fscope.

"83-05-19 Davids: Added the create_res_copy entry

"84-10-29 Benjamin: Added the compile entry
	
  	name 	dsl_

	entry	compile
compile:
	tra	<mrds_dsl_compile>|[compile]
  
	entry	close
close:
	tra	<mrds_dsl_close>|[close]

	entry	close_all
close_all:
	tra	<mrds_dsl_close_all>|[close_all]

	entry	create_res_copy
create_res_copy:
	tra	<mrds_dsl_create_res_copy>|[mrds_dsl_create_res_copy]

	entry	declare
declare:
	tra	<mrds_dsl_declare>|[declare]

	entry	define_temp_rel
define_temp_rel:
	tra	<mrds_dsl_define_temp_rel>|[define_temp_rel]
 
	entry	delete
delete:
	tra	<mrds_dsl_delete>|[delete]

	entry	dl_scope_all
dl_scope_all:
	tra	<mrds_dsl_set_scope>|[dl_scope_all]

  	entry	dl_scope
dl_scope:
	tra	<mrds_dsl_set_scope>|[dl_scope]
  
	entry	get_attribute_list
get_attribute_list:
	tra	<mrds_dsl_get_attribute_list>|[get_attribute_list]

	entry	get_db_version
get_db_version:
	tra	<mrds_dsl_get_version>|[get_db_version]

	entry	get_fn_info
get_fn_info:
	tra	<mrds_dsl_get_fn_info>|[get_fn_info]
 
	entry	get_opening_temp_dir
get_opening_temp_dir:
	tra	<mrds_dsl_resultant_storage>|[get_opening_temp_dir]

	entry	get_path_info
get_path_info:
	tra	<mrds_dsl_get_version>|[get_path_info]

	entry	get_population
get_population:
	tra	<mrds_dsl_get_population>|[get_population]

	entry	get_pn
get_pn:
	tra	<mrds_dsl_get_rslt_info>|[get_pn]
 
	entry	get_relation_list
get_relation_list:
	tra	<mrds_dsl_get_relation_list>|[get_relation_list]

	entry	get_rslt_info
get_rslt_info:
	tra	<mrds_dsl_get_rslt_info>|[get_rslt_info]

	entry	get_rslt_rels
get_rslt_rels:
	tra	<mrds_dsl_get_rslt_info>|[get_rslt_rels]
  
	entry	get_scope
get_scope:
	tra	<mrds_dsl_get_scope>|[get_scope]

	entry	get_scope_info
get_scope_info:
	tra	<mrds_dsl_get_rslt_info>|[get_scope_info]
	
	entry     get_security_info
get_security_info: 
	tra	<mrds_dsl_get_rslt_info>|[get_security_info]

	entry	get_temp_dir
get_temp_dir:
	tra	<mrds_dsl_resultant_storage>|[get_temp_dir]

	entry	get_temp_info
get_temp_info:
	tra	<mrds_dsl_get_rslt_info>|[get_temp_info]
 
	entry	list_dbs
list_dbs:
	tra	<mrds_dsl_db_openings>|[list_dbs]

	entry	list_openings
list_openings:
	tra	<mrds_dsl_db_openings>|[list_openings]
		
	entry	modify
modify:
	tra	<mrds_dsl_modify>|[modify]

	entry	open
open:
	tra	<mrds_dsl_open>|[open]
  
	entry	retrieve
retrieve:
	tra	<mrds_dsl_retrieve>|[retrieve]
  
	entry	set_scope_all
set_scope_all:
	tra	<mrds_dsl_set_scope>|[set_scope_all]

  	entry	set_scope
set_scope:
	tra	<mrds_dsl_set_scope>|[set_scope]
 
	entry	set_temp_dir
set_temp_dir:
	tra	<mrds_dsl_resultant_storage>|[set_temp_dir]

	entry	store
store:
	tra	<mrds_dsl_store>|[store]


  	end




		    dsmd_.alm                       08/15/86  1553.5rew 08/15/86  1436.7       13851



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

" HISTORY COMMENTS:
"  1) change(86-06-13,Dupuis), approve(86-08-05,MCR7491),
"     audit(86-08-08,Blair), install(86-08-15,MR12.0-1127):
"     Made available so that an unbound version of mrds could be created
"     easily. (phx20405, mrds #157)
"                                                      END HISTORY COMMENTS

" 
" NOTES:
"
" This is the transfer vector for the unbound version of dsmd_
"
"
" History:
"
" 81-01-05 Davids written.
"
" 81-02-06 Davids:  removed the entries force_close_dsm
"				get_mode
"				get_submodel_pn
"				validate_rel
"				validate_rel_close
"	changed mrds_dsm_dsmd_ to mrds_dsm_dsmd


  	name 	dsmd_

	entry 	close_dsm
close_dsm:
	tra	<mrds_dsm_dsmd>|[close_dsm]

	
	entry	get_dsm_header
get_dsm_header: 
	tra	<mrds_dsm_dsmd>|[get_dsm_header]


	
	
	entry 	get_dsm_relations
get_dsm_relations: 
	tra	<mrds_dsm_dsmd>|[get_dsm_relations]
	
	
	entry	get_relation
get_relation: 
	tra	<mrds_dsm_dsmd>|[get_relation]
	
	
	entry	open_dsm_read
open_dsm_read: 
	tra	<mrds_dsm_dsmd>|[open_dsm_read]
	
	
	end
				




		    mdbm_util_.alm                  10/16/86  1550.1rew 10/16/86  1142.6       70587



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

" HISTORY COMMENTS:
"  1) change(86-06-13,Dupuis), approve(86-08-05,MCR7491),
"     audit(86-08-08,Blair), install(86-08-15,MR12.0-1127):
"     Made available so that an unbound version of mrds could be created
"     easily. (phx20405, mrds #157)
"  2) change(86-09-02,Spitzer), approve(86-09-02,MCR7311),
"     audit(86-09-02,Blair), install(86-10-16,MR12.0-1187):
"     add mu_db_xref, more mu_temp_segments entries.
"                                                      END HISTORY COMMENTS

"
"
"NOTES:
"
"This is the transfer vector for the unbound version of
"mdbm_util_.
"
"
"HISTORY:
"
"Initially written by JA Weeldreyer -- September, 1978.
"Modified by Jim Gray - - March 1980, to expand utility
"level interface to include 14 more modules dealing
"with primitives not specific to MRDS or MIDS.
"Modified by Jim Gray - - 80-9-18, to add $get_data_pad_length entry to mu_data_length
"to enable mu_build_tuple to throw out padding bits that main contain garbage in aligned data types
"Modified by Jim Gray 80-10-20, to add all entries in mu_temp_segments as
"part of fix for managing space for tid arrays in the searching process.
"
"80-12-09 Jim Gray : removed init_dbc entry, and replaced with 4 entries
"in the new module mu_concurrency_control as part of r-u to r-s-m-d
"scope mode change.
"
"81-02-06 Jim Gray : added entries for mu_open_name_manager of
"define_open_name, delete_open_name, get_model_pointer, display_open_names
"list_all_open_names, delete_all_open_names
"
"81-04-03 Jim Gray : added get_relation_acl entry
"
"
"81-05-27 Jim Gray : removed all entries not used by LINUS,
"or by any mrds_rst_.. module or CMDB, as part of putting mrds
"in one bound segment, plus a bound segment for CMDB.
"
"82-07-01 Roger Lackey : added entry for mrds_dm_get_authorization 
"get_user_class
"		     added mu_db_inconsistent entries
"  get_info, set and reset
"
"82-07-02 Roger Lackey: added mrds_dm_display and rmdb_rq_dmdm
"
"82-07-06 Roger Lackey: added mu_data_length|mu_data_length for binding
"
"82-07-06 Roger Lackey: added mu_define_area and mrds_dsl_translate
"        mu_store$store_direct for binding
"
"82-07-06 R. Harvey: added scan_records_init and scan_records_next
"
"82-07-06 R. Harvey: added encd_attr and 
"
"83-01-30 R. Harvey: added define_temp_dir_area
"
"83-02-14 R. Harvey: deleted encd_attr, scan_records_init and scan_records_next
	name	mdbm_util_

	entry	align_data_item
align_data_item:
	tra	<mu_data_align>|[align_data_item]

	entry	binary_data_class
binary_data_class:
	tra	<mu_data_class>|[binary_data_class]

	entry	bit_data_class
bit_data_class:
	tra	<mu_data_class>|[bit_data_class]

	entry	character_data_class
character_data_class:
	tra	<mu_data_class>|[character_data_class]

	entry     cleanup_temp_dir
cleanup_temp_dir:
	tra	<mu_temp_segments>|[cleanup_temp_dir]

	entry	complex_data_class
complex_data_class:
	tra	<mu_data_class>|[complex_data_class]

	entry	create_control_segment
create_control_segment:
	tra	<mu_concurrency_control>|[create_control_segment]

	entry	define_temp_dir_area
define_temp_dir_area:
	tra	<mu_define_area>|[define_temp_dir_area]

	entry	delete_all_open_names
delete_all_open_names:
	tra	<mu_open_name_manager>|[delete_all_open_names]

	entry     delete_all_temp_segments
delete_all_temp_segments: 
	tra     	<mu_temp_segments>|[delete_all_temp_segments]	

	entry     delete_temp_segment
delete_temp_segment: 
	tra     	<mu_temp_segments>|[delete_temp_segment]

	entry	display_descriptor
display_descriptor:
	tra	<mu_display_descriptor>|[display_descriptor]

	entry	display_open_names
display_open_names:
	tra	<mu_open_name_manager>|[display_open_names]

	entry	fixed_data_class
fixed_data_class:
	tra	<mu_data_class>|[fixed_data_class]
	
	entry	free_all_temp_segments
free_all_temp_segments: 
	tra	<mu_temp_segments>|[free_all_temp_segments]

	
	entry	free_temp_segment
free_temp_segment: 
	tra	<mu_temp_segments>|[free_temp_segment]	
	
	entry	free_temp_segments
free_temp_segments: 
	tra	<mu_temp_segments>|[free_temp_segments]
	
	entry	get_data_bit_length
get_data_bit_length:
	tra	<mu_data_length>|[get_data_bit_length]

	entry	inconsistent_get_info
inconsistent_get_info:
	tra	<mu_db_inconsistent>|[inconsistent_get_info]

	entry	get_resultant_model_pointer
get_resultant_model_pointer:
	tra	<mu_database_index>|[get_resultant_model_pointer]

	entry	get_temp_segment
get_temp_segment: 
	tra	<mu_temp_segments>|[get_temp_segment]
		
	entry	get_temp_segment_path
get_temp_segment_path: 
	tra	<mu_temp_segments>|[get_temp_segment_path]

		entry	get_temp_segments
get_temp_segments: 
	tra	<mu_temp_segments>|[get_temp_segments]
		

	entry	get_temp_segments_path
get_temp_segments_path: 
	tra	<mu_temp_segments>|[get_temp_segments_path]

	entry 	get_user_class
get_user_class:
	tra	<mrds_dm_authorization>|[get_user_class]

	entry	inconsistent_reset
inconsistent_reset:
	tra	<mu_db_inconsistent>|[inconsistent_reset]

	entry	inconsistent_set
inconsistent_set:
	tra	<mu_db_inconsistent>|[inconsistent_set]

	entry	list_segnos
list_segnos:
	tra	<mu_temp_segments>|[list_segnos]

	entry	list_temp_segments
list_temp_segments:
	tra	<mu_temp_segments>|[list_temp_segments]

	entry	mrds_dm_display
mrds_dm_display:
	tra	<mrds_dm_display>|[mrds_dm_display]

	entry	mrds_dsl_translate
mrds_dsl_translate:
	tra	<mrds_dsl_translate>|[mrds_dsl_translate]

	entry	mu_data_length
mu_data_length:
	tra	<mu_data_length>|[mu_data_length]

	entry	mu_define_area
mu_define_area:
	tra	<mu_define_area>|[mu_define_area]

	entry	mu_get_tuple
mu_get_tuple:
	tra	<mu_get_tuple>|[mu_get_tuple]

	entry	number_data_class
number_data_class:
	tra	<mu_data_class>|[number_data_class]

	entry	quiesce_free
quiesce_free:
	tra	<mu_quiesce>|[quiesce_free]

	entry	quiesce_quiet
quiesce_quiet:
	tra	<mu_quiesce>|[quiesce_quiet]

	entry	release_all_temp_segments
release_all_temp_segments: 
	tra	<mu_temp_segments>|[release_all_temp_segments]

	entry	release_temp_segment
release_temp_segment: 
	tra	<mu_temp_segments>|[release_temp_segment]
	
	entry	release_temp_segments
release_temp_segments: 
	tra	<mu_temp_segments>|[release_temp_segments]
		
	entry	rmdb_rq_dmdm
rmdb_rq_dmdm:
	tra	<display_mrds_dm>|[rmdb_rq_dmdm]

	entry	string_data_class
string_data_class:
	tra	<mu_data_class>|[string_data_class]

	entry	store_direct
store_direct:
	tra	<mu_store>|[store_direct]

	entry	trim_descriptor
trim_descriptor:
	tra	<mu_trim_descriptor>|[trim_descriptor]

	entry	varying_data_class
varying_data_class:
	tra	<mu_data_class>|[varying_data_class]

	entry	xref_build
xref_build:
	tra 	<mu_db_xref>|[xref_build]

	entry 	xref_destroy
xref_destroy: 
	tra	<mu_db_xref>|[xref_destroy]
	
	entry	xref_reference
xref_reference: 
	tra 	<mu_db_xref>|[xref_reference]
	
	entry 	xref_dereference
xref_dereference: 
	tra	<mu_db_xref>|[xref_dereference]
	
	entry	xref_create_record
xref_create_record: 
	tra	<mu_db_xref>|[xref_create_record]
	
	entry	xref_delete_record
xref_delete_record: 
	tra	<mu_db_xref>|[xref_delete_record]
	
	entry	xref_modify_record_name
xref_modify_record_name: 
	tra	<mu_db_xref>|[xref_modify_record_name]
	
	entry	xref_modify_reference_name
xref_modify_reference_name: 
	tra 	<mu_db_xref>|[xref_modify_reference_name]

	entry	xref_find_record
xref_find_record: 
	tra 	<mu_db_xref>|[xref_find_record]
	
	entry	xref_statistics
xref_statistics: 
	tra	<mu_db_xref>|[xref_statistics]
	
	end




		    mmi_.alm                        03/08/88  1538.8rew 03/08/88  1531.6       18594



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1988                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1981 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-06-13,Dupuis), approve(86-08-05,MCR7491),
"     audit(86-08-08,Blair), install(86-08-15,MR12.0-1127):
"     Made available so that an unbound version of mrds could be created
"     easily. (phx20405, mrds #157)
"  2) change(88-02-16,Blair), approve(88-02-19,MCR7840),
"     audit(88-02-25,Dupuis), install(88-03-08,MR12.2-1034):
"     Add the missing entrypoints quiesce_db and unquiesce_db to facilitate
"     testing of unbound modules in exl.
"                                                      END HISTORY COMMENTS

"HISTORY:
"
"81-02-10 Jim Gray : originally created for the mrds model interface entries
"		 this is a transfer vector that allows running a broken apart mrds.
"84-10-23 Paul Benjamin : added quiesce_quiet and quiesce_free.
"
"
	name	mmi_

	entry	close_model
close_model:
	tra	<mrds_dm_close>|[close_model]

	entry	create_db
create_db:
	tra	<mrds_dm_create_db>|[create_db]

	entry	get_model_attributes
get_model_attributes:
	tra	<mrds_dm_get_attributes>|[get_model_attributes]

	entry	get_model_info
get_model_info:
	tra	<mrds_dm_get_header>|[get_model_info]

	entry	get_model_relations
get_model_relations:
	tra	<mrds_dm_get_relations>|[get_model_relations]

	entry	get_secured_state
get_secured_state:
	tra	<mrds_dm_db_secured>|[get_secured_state]

	entry	get_authorization
get_authorization:
	tra	<mrds_dm_authorization>|[get_authorization]

	entry	open_model
open_model:
	tra	<mrds_dm_open>|[open_model]

	entry     quiesce_db
quiesce_db: 
	tra       <quiesce_mrds_db>|[quiesce_db]

	entry	unquiesce_db
unquiesce_db: 
	tra       <quiesce_mrds_db>|[unquiesce_db]

	end




		    mrds_call.pl1                   04/18/85  1424.3re  04/18/85  0906.3      424935



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

/* DESCRIPTION:

		      BEGIN_DESCRIPTION
   This procedure provides a command interface to the Multics Relational Data Store (MRDS)
   Data Sub Language (DSL).  This interface is not intended to be a true End User Facility, but
   rather is intended to  be used as an instructional tool when introducing new users to the
   MRDS.  Also, mrds_call will be useful to data base application programmers as an experimental
   vehicle during the development of MRDS application programs.
		       END_DESCRIPTION
*/

/* PARAMETERS:

   operation - - (input) the first argument corresponding to the dsl routine
   to be called from command level, such as "open" for mrds_dsl_open

   operation_args - - (input) the second and succeeding arguments, this varies
   depending on the operation called, for example "ready_file database_index file_name file_ready_mode"
   are the arguments needed for ready_file
   most mrds_call operations and their arguments are documented in the MRDS manual AW53

   (output) error messages, ready/open lists, and terminal output of
   command results, such as tuples returned by retrieve
*/

mrds_call: mrc: proc;

/* HISTORY:

   76-08-01 J. A. Weeldreyer: Initially written.

   76-10-01  J.  A.  Weeldreyer:  Modified  to  fix  arg.  aquisition  problem   in
   define_temp_rel operation.

   77-09-01 O. D. Friesen and J. A. Weeldreyer: Modified for MR6.0.

   79-07-01 Jim Gray: Modified to  1)  correct  MR7  version  of  list_dbs  2)  add
   list_files   operation,   and  incorporate  in  ready_file  3)  improve  integer
   conversion error messages  4)  add  set_modes  operation  with  list  and  error
   suboperations 5) add the "-all" option to the close, ready_file, and finish_file
   operations 6) add operations listing to the "no operation given  error"  7)  put
   work area in temp segment, instead of system_free_

   80-01-01 Mary Ward: Modified to eliminate ready_file,  finish_file,  list_files,
   set_fscope,  set_fscope_all,  dl_fscope,  and  dl_fscope_all, to require the old
   open syntax, and to improve error messages.

   80-06-01 Jim Gray: Modified  to  change  method  of  remembering  open  database
   pathnames and opening modes to accommadate new opening order.

   80-12-08 Rickie E. Brinegar: Use of the internal variable mode_list removed  and
   replaced  with the new mrds_dbs_modes_list.incl.pl1 structures. At the same time
   val_str and hd_str were replaced with control strings in the ioa_ calls.

   80-12-11 Jim Gray : added use of mrds_new_scope_modes include file in process of
   changing  from  old  r-u to r-s-m-d type scope modes. Now a is acceptable for s,
   and u now means a+d+m, but with an integer conversion of 14, not 2.

   80-12-12 Jim Gray : Changed declaration of wait_time to fixed bin(35)  from  71,
   the  fact  that mrds_dsl_set_scope expects a fb35 was causing 0 wait times to be
   sent by mrds_call, because the upper (zero) part of  a  fb71  number  was  being
   sent.

   81-1-12 Jim Gray : added get_scope function to interface to dsl_$get_scope.

   81-01-30  Jim  Gray  :   added   get_population   function   to   interface   to
   mrds_dsl_define_temp_rel$get_temp_rel_population.  The  routine  for  permantent
   relations  is  not  yet  available.  It  will  be  part  of  a  common   routine
   dsl_$get_population.

   81-01-30  Jim  Gray  :  changed  open  database  listing  routine  called   from
   mrds_dsl_lsit_dbs$list_dbs_with_modes  to  mrds_dsl_db_openings$list_openings to
   take advantage of the improved interface.

   81-03-25 Jim Gray : extended get_population to call general  dsl_$get_population
   routine that handles perm rels as well as temp rels.

   81-07-19 Jim Gray :  added  a  new  set_modes  option  no_retrieve_output/nro  -
   retreieve_output/ro that turns the output of values from retrieve off and on. If
   the output values are turned off, then -all is forced, and a  number  of  tuples
   retrieved  is  returned instead. Also deleted all commented out code, as removal
   of blocked file stuff makes it unuseable.

   81-09-22 Davids: added code to set the  num_ptrs  variable  right
   after  a  pointer to the arg_list is obtained. Also added code in
   build_arg_list to make sure that the value of num_ptrs is the max
   of  the  number  of  pointers in the arg_list that mrc was called
   with and the arg_list that is generated to call the  dsl_  entry.
   See the comment in build_arg_list

   82-06-14 Mike Kubicar : Rewrote the dashed argument parser for retrieve
   to work the way the manual desribes it.  This fixes TR phx12237.

*/

/* initialize */

	a_ptr, filen_ptr,
	     num_ptr,
	     mode_ptr,
	     pm_ptr,
	     pv_ptr,
	     se_ptr,
	     rmode_ptr,
	     val_ptr = null;
	code = 0;
	ready_cnt = 0;
	on cleanup call cleanup_proc;
	on arg_err_ call arg_err_hndlr;
	if area_initialized then ;
	else do;
		call get_temp_segment_ ("mrds_call", wa_ptr, code);
		if code ^= 0 then do;
			call com_err_ (code, MRC, "Creating temp segment");
			go to Exit;
		     end;
		wa_ptr -> work_area = empty ();
		area_initialized = ON;
	     end;

	call cu_$arg_list_ptr (al_ptr);
	num_ptrs = arg_list.arg_count;		/* CHANGE 81-09-22 ********** */
	nargs = divide (arg_list.arg_count, 2, 17);

	on sub_error_
	     begin;
		if ^error_display_flag then ;		/* ignore, dont print extra info */
		else call continue_to_signal_ (handler_found_code);
	     end;

	call cu_$arg_ptr (1, f_ptr, f_len, code);	/* get operation name */

	if code ^= 0 then do;			/* nothing there */
		call com_err_ (code, MRC, " Usage: mrc opname {args} {control_args}.");
		if error_display_flag		/* if more info desired */
		then call com_err_ (0, MRC, "Valid opnames: ^/^- ^a,^/^- ^a,^/^- ^a,^/^- ^a",
			"open, o, close, c, store, s, modify, m, delete, d, retrieve, r",
			"list_dbs, ld, set_scope, ss, set_scope_all, ssa, set_modes, sm",
			"dl_scope, ds, dl_scope_all, dsa, define_temp_rel, dtr",
			"get_scope, gs, get_population, gp, declare, dcl");
	     end;

	else if operation = "o" | operation = "open" then do;

		call open_old_ver;

/* if nargs >= 3 then do;
   call cu_$arg_ptr (3, arg_ptr, arg_len, code); ** is mode present? **
   if code ^= 0 then
   call error (code, "open");
   do i = 1 to 8
   while (arg ^= ms_array (i));
   end;
   end;
   if i > 8 | nargs < 3 then
   call open_new_ver;
   else call open_old_ver;
   */

		al_ptr = a_ptr;
		nargs = divide (arg_list.arg_count, 2, 17);
		arg_list.arg_des_ptr (nargs) = addr (code);
		arg_list.arg_des_ptr (nargs + desc_off_o) = addr (fb_35_desc);

		call cu_$generate_call (mrds_dsl_open$open, al_ptr);

		if code ^= 0 then do;
			call com_err_ (code, MRC, "(From dsl_$open)");
			go to Exit;
		     end;

		free temp_mode_list in (work_area);
		tml_ptr = null ();

		if list_display_flag
		then call print_dbi;		/* tell user what he did */

		free arg_list in (work_area);
		free num in (work_area);
		free mode in (work_area);
	     end;					/* open */

	else if operation = "c" | operation = "close" then do;
		if nargs < 2			/* not enough */
		then call com_err_ (error_table_$wrong_no_of_args, MRC,
			"^/^- Usage: mrc close [dbi1 {... dbiN} | -all]"); /* give user hint */
		else do;
			call cu_$arg_ptr (2, arg_ptr, arg_len, code); /* get 1st arg to close */

			if code ^= 0		/* should never happen */
			then call com_err_ (code, MRC, "Getting second argument");

			else if arg = "-all" | arg = "-a" then do;
				call mrds_dsl_close_all (code); /* go doit toit */
				call free_open_lists; /* free work space */
				if code ^= 0	/* now put out error, if any */
				then call com_err_ (code, MRC, "(From dsl_$close_all)");
			     end;

			else do;
				on conversion begin;/* for certain argument errors */
					if a_ptr ^= null then free a_ptr -> arg_list in (work_area);
					if num_ptr ^= null then free num in (work_area);
					call com_err_ (0, MRC, "No data bases closed"); /* tell user no go */
					goto Exit;
				     end;

				call build_arg_list (nargs);

				open_cnt = nargs - 1;
				allocate num in (work_area);

				do i = 2 to nargs;
				     num (i - 1) = conv_int (i, DBI);
				     a_ptr -> arg_list.arg_des_ptr (i - 1) = addr (num (i - 1));
				     a_ptr -> arg_list.arg_des_ptr (desc_off_o + i - 1) = addr (fb_35_desc);
				end;


				al_ptr = a_ptr;
				arg_list.arg_des_ptr (nargs) = addr (code);
				arg_list.arg_des_ptr (nargs + desc_off_o) = addr (fb_35_desc);

				call cu_$generate_call (mrds_dsl_close$close, al_ptr);

				free arg_list in (work_area);
				free num in (work_area);

				call mrds_dsl_db_openings$list_dbs (wa_ptr, database_list_ptr);
				if database_list_ptr = null () then
				     call free_open_lists (); /* get rid of temp seg */
				else free database_list in (work_area);

				if code ^= 0	/* give out errors, if any */
				then call com_err_ (code, MRC, "(From dsl_$close)");
			     end;
		     end;
	     end;					/* close */

	else if operation = "ld" | operation = "list_dbs" then
	     call print_dbi;


	else if operation = "s" | operation = "store" then
	     call call_mod_fun (mrds_dsl_store$store, 3);


	else if operation = "d" | operation = "delete" | operation = "dl" then
	     call call_mod_fun (mrds_dsl_delete$delete, 1);


	else if operation = "m" | operation = "modify" then
	     call call_mod_fun (mrds_dsl_modify$modify, 2);


	else if operation = "set_modes" | operation = "sm" then do;
		if nargs < 2 then
		     call com_err_ (error_table_$wrong_no_of_args, MRC,
			"^/^- Usage: mrc set_modes {list | no_list} {long_err | short_err}");
		else do;
			do arg_cnt = 2 by 1 to nargs;

			     call cu_$arg_ptr (arg_cnt, mrc_mode_ptr, mrc_mode_len, code);
			     if code ^= 0 then
				call com_err_ (code, MRC, "Getting mode argument.");
			     else do;

				     if mrc_mode = "no_list" then
					list_display_flag = OFF;
				     else if mrc_mode = "list" then
					list_display_flag = ON;
				     else if mrc_mode = "long_err" then
					error_display_flag = ON;
				     else if mrc_mode = "short_err" then
					error_display_flag = OFF;

/* BEGIN CHANGE 81-07-19 ******************************************** */

				     else if mrc_mode = "no_retrieve_output" | mrc_mode = "nro" then
					no_output_mode = ON;
				     else if mrc_mode = "retrieve_output" | mrc_mode = "ro" then
					no_output_mode = "0"b;

/* END CHANGE 81-07-19 ************************************************ */

				     else call com_err_ (error_table_$bad_arg, MRC, "Invalid mode ^a.", mrc_mode);
				end;
			end;
		     end;
	     end;

	else if operation = "r" | operation = "retrieve" then do;

		if nargs < 4
		then call com_err_ (error_table_$wrong_no_of_args, MRC,
			"^/^- Usage: mrc retrieve nvals dbi ^/^2-{selection_expression} {se_values} {-segment path} {-all}");
		else do;
			n_vals = conv_int (2, NVALS);
			dbi = conv_int (3, DBI);
			se_seg_sw = 0;		/* init switches */
			all_sw = "0"b;
			done_scanning = "0"b;
			current_arg = nargs;
			se_path = "";

/* 
*
*  Now check for the possible command argument (all two of them).  They
*  (by the command definition) must appear as the last two control arguments
*  in the command line.  So, we just start at the end and scan backwords.
*  We check for -all, which is a single arg, or -sm which has to be two.
*  If we find the wrong thing or both -all and -sm, we assume we're done
*  and look no farther.  Thus, it is quite possible to have command lines of
*  the form:
*
* mrc retrieve 4 1 a b c d -all -all -sm foo -sm foo.input -all
*
*  since scanning for arguments will stop when it sees -sm foo.input -all.
*  This allows arbitrary and random things to be given for selection
*  expression values.
*
*/

			do while (^done_scanning);
			     call cu_$arg_ptr (current_arg, arg_ptr,
				arg_len, code);
			     if code ^= 0 then do;
				     call com_err_ (code, MRC,
					"^/Could not get command argument.");
				     go to Exit;
				end;
			     if ^all_sw & ((arg = "-all") | (arg = "-a")) /* All is easy, it's a single arg */
			     then if (se_seg_sw = 0) & se_path ^= "" /* Make sure we're not in the middle of a -segment argument */
				then done_scanning = "1"b; /* Impossible arg combination, must be se values */
				else do;		/* Saw a legal -all */
					all_sw = "1"b;
					nargs = nargs - 1;
					done_scanning = all_sw & (se_seg_sw ^= 0);
				     end;
			     else if (se_seg_sw = 0) &
				     ((arg = "-segment") | (arg = "-sm"))
			     then if se_path = "" then do; /* Must have seen pathname */
					call com_err_ (error_table_$noarg,
					     MRC, "^/A pathname must be given with the ^a argument.", arg);
					go to Exit;
				     end;
				else do;		/* Valid -segment arg */
					se_seg_sw = 1;
					call get_se (sea_ptr, sed_ptr);
					nargs = nargs - 1;
					done_scanning = all_sw;
				     end;
			     else if se_path ^= ""	/* End of arg scanning? */
			     then done_scanning = "1"b; /* Yes, two non-recognized args in a row */
			     else do;		/* Assume it's an se_path */
				     if length (arg) > length (se_path) then do;
					     se_path = substr (arg, 1, length (se_path));
					     se_len = length (se_path);
					end;
				     else do;
					     se_path = arg;
					     se_len = arg_len;
					end;
				end;
			     current_arg = current_arg - 1;
			end;

			call build_arg_list (nargs + n_vals - 1);
			allocate values in (work_area);

			if se_seg_sw > 0 then do;	/* if seg se. move in arg and desc. ptrs */
				a_ptr -> arg_list.arg_des_ptr (2) = sea_ptr;
				a_ptr -> arg_list.arg_des_ptr (desc_off_o + 2) = sed_ptr;
			     end;

			do i = 2 to nargs - 2 - se_seg_sw;
			     a_ptr -> arg_list.arg_des_ptr (i + se_seg_sw) = arg_list.arg_des_ptr (i + 2);
			     a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + se_seg_sw) =
				true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + i + 2));
			end;

			al_ptr = a_ptr;
			arg_list.arg_des_ptr (1) = addr (dbi);
			arg_list.arg_des_ptr (nargs + n_vals - 1) = addr (code);
			arg_list.arg_des_ptr (desc_off_o + 1),
			     arg_list.arg_des_ptr (desc_off_o + nargs + n_vals - 1) = addr (fb_35_desc);

			do i = nargs - 1 to nargs + n_vals - 2;
			     arg_list.arg_des_ptr (i) = addr (values (i - nargs + 2));
			     arg_list.arg_des_ptr (i + desc_off_o) = addr (char_desc);
			end;

			call cu_$generate_call (mrds_dsl_retrieve$retrieve, al_ptr);

			if code ^= 0 then do;
				call retr_cleanup;
				call com_err_ (code, MRC, "(From dsl_$retrieve)");
				go to Exit;
			     end;

/* BEGIN CHANGE 81-07-19 ******************************************** */

			if ^no_output_mode then do;
				call ioa_ ("^/Value^[ is^;s are^]:^/", (n_vals = 1));

				do i = 1 to n_vals;
				     call ioa_ ("^a", values (i));
				end;
			     end;
			else do;

/* for no_retrieve_output mode, force -all,
   and just prepare a count of the tuples retrieved */

				tuples_retrieved = 1;
				all_sw = "1"b;
			     end;

			if all_sw then do;		/* if auto anothers */
				arg_list.arg_des_ptr (2) = addr (anoth_str); /* change select. expr. to -another */
				arg_list.arg_des_ptr (desc_off_o + 2) = addr (anoth_desc);

				do while (code = 0);/* for as long as we find something */

				     call cu_$generate_call (mrds_dsl_retrieve$retrieve, al_ptr); /* $retrieve (-another) */

				     if code = 0 then do; /* if got something */
					     tuples_retrieved = tuples_retrieved + 1;
					     if ^no_output_mode then do;
						     call ioa_ ("^/******^/"); /* write separator */
						     do i = 1 to n_vals; /* write out all found values */
							call ioa_ ("^a", values (i));
						     end;
						end;
					end;
				end;
				if code = mrds_error_$tuple_not_found then do;
					if no_output_mode then
					     call ioa_ ("^/Tuples retrieved:  ^d^/", tuples_retrieved);
					else call ioa_ ("^/(END)^/"); /* let user know at end */
				     end;
				else call com_err_ (code, MRC, "(From dsl_$retrieve)"); /* otherwise give error */
			     end;			/* if auto anothers */

/* END CHANGE 81-07-19 **************************************************** */


			else call ioa_ ("^/");
			call retr_cleanup;

retr_cleanup: procedure;
	free arg_list in (work_area);
	free values in (work_area);
     end retr_cleanup;

		     end;				/* retrieve */
	     end;

	else if operation = "dtr" | operation = "define_temp_rel" then do;
		if nargs < 4 then do;		/* not enough */
			call com_err_ (error_table_$wrong_no_of_args, MRC,
			     "^/^- Usage: mrc define_temp_rel dbi ^/^2-^a^/^2-^a",
			     "[selection_expression {se_values} rel_index",
			     "| rel_index -sm path]");
			go to Exit;
		     end;

		dbi = conv_int (2, DBI);

		call cu_$arg_ptr (nargs - 1, arg_ptr, arg_len, code); /* see if separate sel. expr. */

		if code ^= 0 then do;
			call com_err_ (code, MRC, "Getting argument ^i", nargs - 1);
			go to Exit;
		     end;
		if arg = "-sm" | arg = "-segment" then do; /* if separate */
			call cu_$arg_ptr (nargs, arg_ptr, arg_len, code); /* get path */
			if code ^= 0 then do;
				call com_err_ (code, MRC, "Pathname for -segment");
				go to Exit;
			     end;

			se_path = arg;
			se_len = arg_len;
			call get_se (sea_ptr, sed_ptr); /* init and set ptrs for sel. expr. */
			nargs = nargs - 1;		/* dont look at ctl arg again */
			se_seg_sw = 1;		/* remember */
		     end;
		else se_seg_sw = 0;			/* if sel. expr in command line */

		rel_ind = conv_int (nargs - se_seg_sw, TRI);

		call build_arg_list (nargs);

		if se_seg_sw > 0 then do;		/* if se. in seg */
			a_ptr -> arg_list.arg_des_ptr (2) = sea_ptr; /* move in arg and desc ptrs */
			a_ptr -> arg_list.arg_des_ptr (desc_off_o + 2) = sed_ptr;
		     end;

		do i = 2 to nargs - 2 - se_seg_sw;
		     a_ptr -> arg_list.arg_des_ptr (i + se_seg_sw) = arg_list.arg_des_ptr (i + 1);
		     a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + se_seg_sw) =
			true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + i + 1));
		end;

		al_ptr = a_ptr;
		arg_list.arg_des_ptr (1) = addr (dbi);
		arg_list.arg_des_ptr (nargs - 1) = addr (rel_ind);
		arg_list.arg_des_ptr (nargs) = addr (code);
		arg_list.arg_des_ptr (desc_off_o + 1),
		     arg_list.arg_des_ptr (desc_off_o + nargs - 1),
		     arg_list.arg_des_ptr (desc_off_o + nargs) = addr (fb_35_desc);

		call cu_$generate_call (mrds_dsl_define_temp_rel$define_temp_rel, al_ptr);

		free arg_list in (work_area);

		if code ^= 0
		then call com_err_ (code, MRC, "(From dsl_$define_temp_rel)");
		else call ioa_ ("^/Temporary relation index is:  ^d.^/", rel_ind);

	     end;					/* retrieve */

	else if operation = "set_scope" | operation = "ss" then
	     call call_scope_fun (mrds_dsl_set_scope$set_scope, 1);

	else if operation = "ssa" | operation = "set_scope_all" then
	     call call_set_scope_all_fun (mrds_dsl_set_scope$set_scope_all);

	else if operation = "ds" | operation = "dl_scope" then
	     call call_scope_fun (mrds_dsl_set_scope$dl_scope, 2);

	else if operation = "dl_scope_all" | operation = "dsa" then do;
		if nargs ^= 2
		then call com_err_ (error_table_$wrong_no_of_args, MRC, " Usage: mrc dl_scope_all dbi");
		else do;
			dbi = conv_int (2, DBI);
			call mrds_dsl_set_scope$dl_scope_all (dbi, code);
			if code ^= 0
			then call com_err_ (code, MRC, "(From dsl_$dl_scope_all)");
		     end;
	     end;
	else if operation = "get_scope" | operation = "gs" then do;
		if nargs ^= 3 then
		     call com_err_ (error_table_$wrong_no_of_args, MRC, "^/    Usage: mrc get_scope dbi relation_name");
		else do;
			dbi = conv_int (2, DBI);
			call cu_$arg_ptr_rel (3, relation_name_ptr, relation_name_len, code, al_ptr);
			if code ^= 0 then
			     call com_err_ (code, MRC, "^/Cannot get relation name argument.");
			else do;
				call mrds_dsl_get_scope (dbi, relation_name, permits, prevents, scope_version, code);
				if code ^= 0 then
				     call com_err_ (code, MRC, "(From dsl_$get_scope)");
				else do;
					permit_requests_ptr = addr (permits);
					prevent_requests_ptr = addr (prevents);
					if scope_version < 5 then
					     store_scope = "s";
					else store_scope = "a";
					permit_string = "";
					if permit_requests.read_attr then permit_string = permit_string || "r";
					if permit_requests.append_tuple then permit_string = permit_string || store_scope;
					if permit_requests.modify_attr then permit_string = permit_string || "m";
					if permit_requests.delete_tuple then permit_string = permit_string || "d";
					if permit_string = "" then permit_string = "n";
					prevent_string = "";
					if prevent_requests.read_attr then prevent_string = prevent_string || "r";
					if prevent_requests.append_tuple then prevent_string = prevent_string || store_scope;
					if prevent_requests.modify_attr then prevent_string = prevent_string || "m";
					if prevent_requests.delete_tuple then prevent_string = prevent_string || "d";
					if prevent_string = "" then prevent_string = "n";
					call ioa_ ("^/Permits:  ^a ^-Prevents:  ^a^/", permit_string, prevent_string);
				     end;
			     end;
		     end;
	     end;

	else if operation = "get_population" | operation = "gp" then do;
		if nargs ^= 3 then
		     call com_err_ (error_table_$wrong_no_of_args, MRC,
			"^/    Usage: mrc get_population dbi rel_id");
		else do;
			dbi = conv_int (2, DBI);
			call cu_$arg_ptr_rel (3, relation_name_ptr, relation_name_len, code, al_ptr);
			if code ^= 0 then
			     call com_err_ (code, MRC, "^/Cannot get relation name argument.");
			else do;

				call mrds_dsl_get_population (dbi, relation_name, tuple_count, code);

				if code ^= 0 then
				     call com_err_ (code, MRC, "(From dsl_$get_population)");
				else do;

					call ioa_ ("^/Tuple count:  ^d^/", tuple_count);

				     end;

			     end;

		     end;

	     end;

	else if operation = "declare" | operation = "dcl" then do;
		if nargs ^= 3
		then call com_err_ (error_table_$wrong_no_of_args, "^/^- Usage: mrc declare dbi function_name");
		else do;
			dbi = conv_int (2, DBI);

			call cu_$arg_ptr_rel (3, fn_ptr, fn_len, code, al_ptr);

			if code ^= 0
			then call com_err_ (code, MRC, "Cannot get function_name");
			else do;
				call mrds_dsl_declare (dbi, fn_name, code);
				if code ^= 0
				then call com_err_ (code, MRC, "(From dsl_$declare)");
			     end;
		     end;
	     end;

	else call com_err_ (error_table_$bad_arg, MRC, operation);
Exit:
	if se_ptr ^= null				/* if any segment initiated */
	then call hcs_$terminate_noname (se_ptr, discard_code);
	return;

call_mod_fun: proc (dsl_entry, index);
	dcl     dsl_entry		 entry;
	dcl     index		 fixed bin;

	if nargs < 3 then do;			/* not right number */
		if index = 3			/* special call for store */
		then call com_err_ (error_table_$wrong_no_of_args, MRC,
			"^/^- Usage: mrc store dbi [rel_name | -another] new_values");
		else call com_err_ (error_table_$wrong_no_of_args, MRC,
			"^/^- Usage: mrc ^[delete^;modify^] dbi [selection_expression {se_values} ^[^;new_values^] | ^[^;new_values^] -sm path]", index, index, index);
	     end;

	else do;
		dbi = conv_int (2, DBI);
		se_seg_sw = 0;			/* init off */

		if index ^= 3 then do;		/* delete or modify */
			call cu_$arg_ptr (nargs - 1, arg_ptr, arg_len, code); /* see if -sm given */
			if code ^= 0 then do;
				call com_err_ (code, MRC, "Getting argument ^i", nargs - 1);
				go to Exit;
			     end;

			else if arg = "-segment" | arg = "-sm" then do;
				call cu_$arg_ptr (nargs, arg_ptr, arg_len, code);
				if code ^= 0 then do;
					call com_err_ (code, MRC, "Unable to get pathname for -segment");
					go to Exit;
				     end;
				else do;
					se_path = arg;
					se_len = arg_len;
					call get_se (sea_ptr, sed_ptr);
					nargs = nargs - 1;
					se_seg_sw = 1;
				     end;
			     end;
		     end;

		call build_arg_list (nargs);		/* build dsl_ arg list */

		if se_seg_sw > 0 then do;		/* if separate sel. expr. */
			a_ptr -> arg_list.arg_des_ptr (2) = sea_ptr; /* move in sel. expr. ptrs */
			a_ptr -> arg_list.arg_des_ptr (desc_off_o + 2) = sed_ptr;
		     end;
		do i = 2 to nargs - 1 - se_seg_sw;
		     a_ptr -> arg_list.arg_des_ptr (i + se_seg_sw) = arg_list.arg_des_ptr (i + 1);
		     a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + se_seg_sw) =
			true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + i + 1));
		end;

		al_ptr = a_ptr;
		arg_list.arg_des_ptr (1) = addr (dbi);
		arg_list.arg_des_ptr (nargs) = addr (code);
		arg_list.arg_des_ptr (desc_off_o + 1),
		     arg_list.arg_des_ptr (desc_off_o + nargs) = addr (fb_35_desc);

		call cu_$generate_call (dsl_entry, al_ptr);

		free arg_list in (work_area);

		if code ^= 0
		then call com_err_ (code, MRC,	/* give user error */
			"(From dsl_$^[delete^;modify^;store^])", index);
	     end;

     end call_mod_fun;

call_scope_fun: proc (dsl_entry, index);

	dcl     dsl_entry		 entry;
	dcl     index		 fixed bin;


	if nargs < 5
	then call com_err_ (error_table_$wrong_no_of_args, MRC,
		"^/^- Usage: mrc ^[set^;dl^]_scope dbi ^a ^/^2-^a ^[{wait_sec}^]",
		index,
		"rel_name1 permit_ops1 prevent_ops1",
		"{... rel_nameN permit_opsN prevent_opsN}",
		index);

	else do;
		dbi = conv_int (2, DBI);

		wait_time = mod (nargs - 2, 3);
		if wait_time ^= 0 then wait_time = conv_int (nargs, WT);

		call build_arg_list (nargs);

		scope_cnt = divide (nargs - 2, 3, 17);
		allocate perm_ops in (work_area);
		allocate prev_ops in (work_area);

		do i = 2 to nargs - 2 by 3;

		     a_ptr -> arg_list.arg_des_ptr (i) = arg_list.arg_des_ptr (i + 1);
		     a_ptr -> arg_list.arg_des_ptr (i + desc_off_o) =
			true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + i + 1));
		     perm_ops (divide (i + 1, 3, 17)) = conv_ops (i + 2);
		     prev_ops (divide (i + 1, 3, 17)) = conv_ops (i + 3);
		     a_ptr -> arg_list.arg_des_ptr (i + 1) = addr (perm_ops (divide (i + 1, 3, 17)));
		     a_ptr -> arg_list.arg_des_ptr (i + 2) = addr (prev_ops (divide (i + 1, 3, 17)));
		     a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + 1),
			a_ptr -> arg_list.arg_des_ptr (desc_off_o + i + 2) = addr (fb_17_desc);

		end;

		al_ptr = a_ptr;
		arg_list.arg_des_ptr (1) = addr (dbi);
		arg_list.arg_des_ptr (nargs) = addr (code);
		if wait_time ^= 0 then do;		/* wait time specified */
			arg_list.arg_des_ptr (nargs - 1) = addr (wait_time);
			arg_list.arg_des_ptr (desc_off_o + nargs - 1) = addr (fb_35_desc);
		     end;
		arg_list.arg_des_ptr (desc_off_o + 1),
		     arg_list.arg_des_ptr (desc_off_o + nargs) = addr (fb_35_desc);

		call cu_$generate_call (dsl_entry, al_ptr); /* call out */

		free perm_ops in (work_area);
		free prev_ops in (work_area);
		free arg_list in (work_area);

		if code ^= 0
		then call com_err_ (code, MRC,	/* give user sad story */
			"(From dsl_$^[set^;dl^]_scope)", index);
	     end;

     end call_scope_fun;

call_set_scope_all_fun: proc (dsl_entry);

	dcl     dsl_entry		 entry;

	if nargs < 4 | nargs > 5
	then call com_err_ (error_table_$wrong_no_of_args, MRC,
		"^/^- Usage: mrc set_scope_all dbi permit_ops prevent_ops {wait_sec}");
	else do;

		dbi = conv_int (2, DBI);

		if nargs = 5 then wait_time = conv_int (nargs, WT);

		call build_arg_list (nargs);

		scope_cnt = 1;
		allocate perm_ops in (work_area);
		allocate prev_ops in (work_area);

		perm_ops (1) = conv_ops (3);
		prev_ops (1) = conv_ops (4);
		a_ptr -> arg_list.arg_des_ptr (2) = addr (perm_ops (1));
		a_ptr -> arg_list.arg_des_ptr (3) = addr (prev_ops (1));
		a_ptr -> arg_list.arg_des_ptr (desc_off_o + 2),
		     a_ptr -> arg_list.arg_des_ptr (desc_off_o + 3) = addr (fb_17_desc);

		al_ptr = a_ptr;
		arg_list.arg_des_ptr (1) = addr (dbi);
		arg_list.arg_des_ptr (nargs) = addr (code);

		if nargs = 5
		then do;
			arg_list.arg_des_ptr (nargs - 1) = addr (wait_time);
			arg_list.arg_des_ptr (desc_off_o + nargs - 1) = addr (fb_35_desc);
		     end;
		arg_list.arg_des_ptr (desc_off_o + 1),
		     arg_list.arg_des_ptr (desc_off_o + nargs) = addr (fb_35_desc);

		call cu_$generate_call (dsl_entry, al_ptr); /* call out */

		free perm_ops in (work_area);
		free prev_ops in (work_area);
		free arg_list in (work_area);

		if code ^= 0 then
		     call com_err_ (code, MRC, "(From dsl_$set_scope_all)");
	     end;

     end call_set_scope_all_fun;

open_old_ver: proc;

	dcl     odd		 fixed bin;	/* to see if odd num of args */
	dcl     al_index		 fixed bin;	/* index for arg_list processing */

	odd = mod (nargs, 2);			/* see if odd num */

	if nargs < 3 | odd = 0 then do;		/* need odd num & at least 3 */
		call com_err_ (error_table_$wrong_no_of_args, MRC,
		     "^/^- Usage: mrc open path1 mode1 {... pathN modeN}");
		go to Exit;
	     end;

	num_open,
	     open_cnt = divide (nargs - 1, 2, 17);
	call build_arg_list (open_cnt * 3 + 1);

	allocate num in (work_area) set (num_ptr);
	allocate mode in (work_area) set (mode_ptr);
	if tml_ptr ^= null then free temp_mode_list in (work_area);
	allocate temp_mode_list set (tml_ptr) in (work_area);

	do i = 1 to (open_cnt);
	     al_index = (i - 1) * 3;

	     a_ptr -> arg_list.arg_des_ptr (al_index + 1) = arg_list.arg_des_ptr (2 * i);
	     a_ptr -> arg_list.arg_des_ptr (al_index + 2) = addr (num (i));
	     a_ptr -> arg_list.arg_des_ptr (al_index + 3) = addr (mode (i));

	     call cu_$arg_ptr (2 * i + 1, ms_ptr, ms_len, code);
	     if code ^= 0 then do;
		     call com_err_ (code, MRC, "Unable to get opening mode.");
		     go to Exit;
		end;

	     do j = 1 to 8 while (mode_string ^= ms_array (j)); /* look for specified mode */
	     end;
	     if j > 8 then do;
		     call com_err_ (code, MRC,
			"Invalid opening mode ^a. ^/^-Valid modes are: r, u, er, and eu", mode_string);
		     go to Exit;
		end;
	     else mode (i) = mv_array (j);		/* if valid, pick up corr. number */
	     a_ptr -> arg_list.arg_des_ptr (desc_off_o + al_index + 1) =
		true_ptr (al_ptr, arg_list.arg_des_ptr (desc_off_i + 2 * i));
	     a_ptr -> arg_list.arg_des_ptr (desc_off_o + al_index + 2),
		a_ptr -> arg_list.arg_des_ptr (desc_off_o + al_index + 3) = addr (fb_35_desc);

	     temp_mode_list (i) = ms_array (2 * mode (i) - 1); /* save expanded opening mode */

	     call cu_$arg_ptr (2 * i, arg_ptr, arg_len, code); /* get and save submodel path */
	     if code ^= 0 then do;			/* not there */
		     call com_err_ (code, MRC, "Unable to get pathname");
		     go to Exit;
		end;

	     if code ^= 0 then do;
		     call com_err_ (code, MRC, arg);	/* let user know */
		     go to Exit;			/* and get out */
		end;

	end;

     end open_old_ver;

build_arg_list: proc (count);

	dcl     count		 fixed bin;
	dcl     old_num_ptrs	 fixed bin;	/* CHANGE 81-09-22 ********** */

	old_num_ptrs = num_ptrs;			/* CHANGE 81-09-22 ********** */

	num_ptrs = 2 * count;
	allocate arg_list in (work_area) set (a_ptr);

	a_ptr -> arg_list.arg_count,
	     a_ptr -> arg_list.desc_count = 2 * count;
	a_ptr -> arg_list.code = 4;

	desc_off_o = count;
	desc_off_i = divide (arg_list.arg_count, 2, 17) + fixed (arg_list.code = 8);

/* BEGIN CHANGE 81-09-22 ******************************

   old_num_ptrs contains the number of pointers in the argument list
   that  mrds_call  was called with. num_ptrs contains the number of
   pointers that the corresponding dsl_ entry will be  called  with.
   Since  only  1 structure is used (arg_list) the value of num_ptrs
   after it leaves this procedure must be  the  larger  of  the  two
   numbers  to  prevent  subscriptrange conditions from occuring, of
   course this means that subscriptrange conditions can occur on the
   other   structure.  Ideally  two  separate  structures  with  two
   separate limits should be used. This has not been  done  at  this
   time becuase while it is a simple change it is also extensive and
   it would be easy to make a mistake at  the  same  time  the  test
   routines  cannot  be  run  becuase  almost  every  routine  has a
   stringrange or subscriptrange condition  in  it.  After  mrds  is
   again running this change should be made. */

	if old_num_ptrs > num_ptrs
	then num_ptrs = old_num_ptrs;

/* END   CHANGE 81-09-22 ****************************** */

     end build_arg_list;

conv_int: proc (index, argument_type) returns (fixed bin (35));

	declare argument_type	 char (*);
	dcl     i			 fixed bin;
	dcl     num_char		 char (nc_len) based (nc_ptr);
	dcl     nc_ptr		 ptr;
	dcl     (nc_len,
	        index)		 fixed bin;

	call cu_$arg_ptr_rel (index, nc_ptr, nc_len, code, al_ptr);

	if code ^= 0 then do;			/* can't find arg */
		call com_err_ (code, MRC, "Unable to get ^a", argument_type);
		go to Exit;			/* not much past this */
	     end;

	if argument_type = TRI
	then i = verify (num_char, "-0123456789");
	else i = verify (num_char, "0123456789");	/* no negatives allowed */

	if i ^= 0 then do;				/* not numeric */
		call com_err_ (error_table_$bad_arg, MRC,
		     "Non-numeric ^a: ^a", argument_type, num_char);
		if operation = "close" | operation = "c"/* special handling for close */
		then signal conversion;		/* so can clean up properly */
		else go to Exit;			/* otherwise, just die */
	     end;
	return (fixed (num_char));

     end conv_int;

conv_ops: proc (index) returns (fixed bin (35));

/* Internal procedure to create an operations number from a given scope operations string */

	dcl     st_ptr		 ptr;		/* points to input string */
	dcl     (st_len,				/* length of input str. */
	        index)		 fixed bin;	/* index of string arg. */
	dcl     string		 char (st_len) based (st_ptr); /* scope ops. string */
	dcl     op_num		 fixed bin (35);	/* scope ops number to be returned */

	call cu_$arg_ptr_rel (index, st_ptr, st_len, code, al_ptr); /* get input string */
	if code ^= 0 then do;
		call com_err_ (code, MRC, "Unable to get scope code");
		go to Exit;
	     end;
	op_num = 0;				/* initialize */

	if string ^= "n" then do;			/* if non-null op. */
		op_num = verify (string, "nrasudm");
		if op_num ^= 0 then do;		/* invalid code */
			call com_err_ (error_table_$bad_arg, MRC,
			     "Invalid scope code: ^a. ^/^-Valid codes are: n, r, a or s, d, m, and u = ""a+d+m""",
			     substr (string, op_num, 1));
			go to Exit;
		     end;
		if search (string, "r") ^= 0 then op_num = op_num + READ_ATTR; /* convert to number */
		if search (string, "s") ^= 0 | search (string, "a") ^= 0 then op_num = op_num + APPEND_TUPLE;
		if search (string, "d") ^= 0 then op_num = op_num + DELETE_TUPLE;
		if search (string, "m") ^= 0 then op_num = op_num + MODIFY_ATTR;
		if search (string, "u") ^= 0 then op_num = op_num + UPDATE_OPS;
	     end;

	return (op_num);

     end conv_ops;

print_dbi: proc;

/* Procedure to print open data bases, modes, and indices */


	call mrds_dsl_db_openings$list_openings (wa_ptr,
	     mrds_database_openings_structure_version, mrds_database_openings_ptr, code);
	if code ^= 0 then
	     call com_err_ (code, MRC, "(From dsl_$list_openings)");
	else do;

		if mrds_database_openings.number_open = 0 then
		     call ioa_ ("^/No data bases open.^/"); /* if we dont have list */

		else do;				/* print out list */
			call ioa_ ("^/Open data base^[ is^;s are^]:",
			     (mrds_database_openings.number_open = 1)); /* write out header */

			do i = 1 to mrds_database_openings.number_open; /* write out index,
						   mode, path of each db curr. open */

			     call ioa_ ("^d^-^a^/^-^a", mrds_database_openings.db.index (i),
				mrds_database_openings.db.path (i),
				mrds_database_openings.db.mode (i));
			end;
			call ioa_ ("^/");
		     end;

	     end;


	if mrds_database_openings_ptr ^= null () then
	     free mrds_database_openings in (work_area);

     end print_dbi;

get_se: proc (a_ptr, d_ptr);

/* Internal procedure to obtain selection expression if user has specified -segment.
   On output, a_ptr will point to the start of the selection expression, and d_ptr will point to a
   descriptor for the selection expression.
*/

	dcl     (a_ptr,				/* place to put arg ptr. for sel.exp. */
	        d_ptr)		 ptr;		/* place to put descr. ptr. for sel. exp. */
	dcl     dname		 char (168);	/* dir name of se. expr. */
	dcl     ename		 char (32);	/* entry name of se. expr. */
	dcl     bcount		 fixed bin (24);	/* se. expr. bit count */
	dcl     1 se_desc		 aligned,		/* descriptor template */
		2 const		 bit (12) unal init ("101010110000"b),
		2 len		 fixed bin (23) unal;

	call expand_path_ (addr (se_path), se_len, addr (dname), addr (ename), code);

	if code ^= 0 then do;
		call com_err_ (code, MRC, se_path);
		go to Exit;			/* can't do anything with it */
	     end;

	call hcs_$initiate_count (dname, ename, "", bcount, 0, se_ptr, code); /* get ptr and length of sel. expr. */

	if se_ptr = null then do;			/* couldn't init segment */
		call com_err_ (code, MRC, "Initiating ^a>^a", dname, ename);
		go to Exit;			/* can't go any farther now */
	     end;

	a_ptr = se_ptr;				/* arg ptr */
	d_ptr = addr (se_desc);			/* point to descriptor */
	se_desc.len = divide (bcount, 9, 17);		/* set length in descriptor */

     end get_se;

true_ptr: proc (a_ptr, d_ptr) returns (ptr);

/* Procedure to insure that descriptor pointers passed to dsl_ are its ptrs, rathher than offsets. */

	dcl     (a_ptr,				/* arg list ptr */
	        d_ptr)		 ptr;		/* descriptor ptr */
	dcl     1 its_wd1		 based (addr (d_ptr)),
		2 offset		 bit (18) unal,
		2 pad		 bit (12) unal,
		2 tag		 bit (6) unal;

	if its_wd1.tag = "100011"b then return (d_ptr);	/* is already its ptr */
	else return (ptr (a_ptr, its_wd1.offset));	/* otherwise make its ptr */

     end true_ptr;

cleanup_proc: proc;

/* cleanup procedure to free any temporary. storage */

	if a_ptr ^= null then free a_ptr -> arg_list in (work_area);
	if num_ptr ^= null then free num in (work_area);
	if mode_ptr ^= null then free mode in (work_area);
	if rmode_ptr ^= null then free rmode in (work_area);
	if val_ptr ^= null then free values in (work_area);
	if pm_ptr ^= null then free perm_ops in (work_area);
	if pv_ptr ^= null then free prev_ops in (work_area);

	if se_ptr ^= null then do;
		call hcs_$terminate_noname (se_ptr, code);
		se_ptr = null ();
	     end;


     end cleanup_proc;

arg_err_hndlr: proc;

	call com_err_ (error_table_$noarg, "mrds_call");
	call cleanup_proc;

     end arg_err_hndlr;

free_open_lists: procedure;

/* this procedure wipes out the temp seg used as a work area.  It is called
   whenever there is an error in open and after all data bases have
   been closed.  By deleting this area, we effectively free everything allocated
   in it. */

	if wa_ptr ^= null then do;			/* got something to get rid of */
		call release_temp_segment_ (MRC, wa_ptr, discard_code);
		area_initialized = OFF;		/* remember that its not there any more */
	     end;

     end free_open_lists;

%include mdbm_arg_list;
%page;
%include mdbm_scope_requests;
%page;
%include mrds_new_scope_modes;
%page;
%include mrds_database_list;
%page;
%include mrds_database_openings;

	dcl     (a_ptr,
	        arg_ptr,				/* ptr to arg. of interest */
	        f_ptr,
	        filen_ptr,
	        fn_ptr,
	        num_ptr,
	        mode_ptr,
	        ms_ptr,				/* ptr to input mode string */
	        pm_ptr,
	        pv_ptr,
	        rmode_ptr,
	        se_ptr,				/* ptr to selection expr to be passed to dsl_ */
	        sea_ptr,				/* arg ptr for seg se. */
	        sed_ptr,				/* desc ptr for seg se. */
	        val_ptr)		 ptr;

	dcl     (arg_len,				/* length of arg of interest */
	        desc_off_i,
	        desc_off_o,
	        f_len,
	        fn_len,
	        i,
	        j,				/* internal index */
	        ms_len,				/* length of mode string */
	        n_vals,
	        nargs,
	        open_cnt,
	        ready_cnt,
	        scope_cnt,
	        se_len,				/* length of se. seg. path */
	        se_seg_sw)		 fixed bin;	/* indicates if seg se. expr. */

	dcl     (code,
	        dbi,
	        rel_ind)		 fixed bin (35);

	dcl     all_sw		 bit (1) unal;	/* on => outo anothers */
	dcl     anoth_desc		 bit (36) aligned int static options (constant) init ("101010100000000000000000000000001000"b);
	dcl     anoth_str		 char (8) aligned int static options (constant) init ("-another");
	dcl     arg		 char (arg_len) based (arg_ptr); /* arg of current interest */
	dcl     current_arg		 fixed bin;	/* Used in retrieve argument scanning */
	dcl     done_scanning	 bit (1);		/* Are we done parsing the dashed args */
	dcl     fn_name		 char (fn_len) based (fn_ptr);
	dcl     mode		 (open_cnt) fixed bin (35) based (mode_ptr);
	dcl     mode_string		 char (ms_len) based (ms_ptr); /* opening mode */
	dcl     num		 (open_cnt) fixed bin (35) based (num_ptr);
	dcl     num_open		 fixed bin int static init (0); /* num. of open data bases */
	dcl     operation		 char (f_len) based (f_ptr);
	dcl     perm_ops		 (scope_cnt) fixed bin (35) based (pm_ptr);
	dcl     prev_ops		 (scope_cnt) fixed bin (35) based (pv_ptr);
	dcl     rmode		 (ready_cnt) fixed bin (35) based (rmode_ptr);
	dcl     se_path		 char (168) aligned;/* path name of selection expr. */
	dcl     values		 (n_vals) char (256) based (val_ptr);
	dcl     wa_ptr		 static pointer init (null); /* ptr to temp seg containing the above */
	dcl     wait_time		 fixed bin (35);	/* optional maximum wait time for scope setting */
						/* NOTE: this MUST be declared fixed bin 35 NOT 71,
						   since mrds_dsl_set_scope expects a fb35 number, and is documented that way for users */

	dcl     ms_array		 (8) char (20) int static options (constant) init (/* allowable opening modes */
				 "retrieval", "r",
				 "update", "u",
				 "exclusive_retrieval", "er",
				 "exclusive_update", "eu");

	dcl     mv_array		 (8) fixed bin int static options (constant) /* corresponding numeric values */
				 init (1, 1, 2, 2, 3, 3, 4, 4);

	dcl     char_desc		 bit (36) aligned init ("101010100000000000000000000100000000"b);
	declare fb_17_desc		 bit (36) aligned init ("100000100000000000000000000000010001"b);
	dcl     fb_35_desc		 bit (36) aligned init ("100000100000000000000000000000100011"b);

	dcl     work_area		 area (sys_info$max_seg_size) based (wa_ptr);

	dcl     (error_table_$bad_arg,
	        error_table_$noarg,
	        mrds_error_$tuple_not_found,
	        sys_info$max_seg_size) fixed bin (35) ext;

	dcl     (addr,
	        divide,
	        empty,
	        fixed,
	        length,
	        mod,
	        null,
	        ptr,
	        search,
	        substr,
	        verify)		 builtin;

	dcl     (arg_err_,
	        cleanup,
	        conversion,
	        sub_error_)		 condition;	/* signaled when sub_error_ called */

	dcl     (com_err_,
	        ioa_,
	        mrds_dsl_close$close,
	        mrds_dsl_define_temp_rel$define_temp_rel,
	        mrds_dsl_delete$delete,
	        mrds_dsl_modify$modify,
	        mrds_dsl_open$open,
	        mrds_dsl_retrieve$retrieve,
	        mrds_dsl_set_scope$dl_scope,
	        mrds_dsl_set_scope$set_scope,
	        mrds_dsl_set_scope$set_scope_all,
	        mrds_dsl_store$store)	 entry options (variable);

	dcl     mrds_dsl_declare	 entry (fixed bin (35), char (*), fixed bin (35));
	declare mrds_dsl_get_scope	 entry (fixed bin (35), char (*), fixed bin, fixed bin, fixed bin, fixed bin (35)); /* gets permits/prevents scope on rel */
	declare relation_name	 char (relation_name_len) based (relation_name_ptr);
	declare relation_name_ptr	 ptr;
	declare relation_name_len	 fixed bin;
	declare (permits, prevents)	 fixed bin;
	declare scope_version	 fixed bin;	/* 5 => r-a-m-d, < 5 => r-s-m-d */
	declare store_scope		 char (1);	/* either "s" or "a" */
	declare (permit_string, prevent_string) char (4) varying; /* for displaying scope */
	declare tuple_count		 fixed bin (35);	/* number of tuples in relation */
	declare mrds_dsl_get_population entry options (variable); /* get population of rels */
	dcl     mrds_dsl_set_scope$dl_scope_all entry (fixed bin (35), fixed bin (35));

	dcl     (DBI		 char (15) init ("data_base_index"),
	        MRC		 char (9) init ("mrds_call"),
	        NVALS		 char (5) init ("nvals"),
	        TRI		 char (14) init ("temp_rel_index"),
	        WT		 char (9) init ("wait_time")) static options (constant);

	dcl     arg_cnt		 fixed bin;	/* number of set_mode arguments + 1 */
	dcl     continue_to_signal_	 entry (fixed bin (35)); /* to keep signaling */
	dcl     error_display_flag	 bit (1) internal static init ("1"b); /* on => output sub error mesg */
	dcl     error_table_$wrong_no_of_args fixed bin (35) ext;
	dcl     handler_found_code	 fixed bin (35);
	dcl     list_display_flag	 bit (1) internal static init ("1"b); /* on => list open dbs, and ready files after open/ready */
	dcl     mrc_mode		 char (mrc_mode_len) based (mrc_mode_ptr); /* set_modes mode arg */
	dcl     mrc_mode_len	 fixed bin;	/* length of set_mode mode arg */
	dcl     mrc_mode_ptr	 ptr;		/* set_mode mode pointer */
	dcl     mrds_dsl_close_all	 entry (fixed bin (35)); /* close all open dbs */
	dcl     NL		 char (1) init ("
");						/* new line character */
	dcl     ON		 bit (1) init ("1"b); /* true value */
	dcl     OFF		 bit (1) init ("0"b); /* false value */

	dcl     area_initialized	 bit (1) internal static init ("0"b); /* on => work area created */
	dcl     discard_code	 fixed bin (35);	/* unused */
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* gets space for work area */
	dcl     mrds_data_$max_dbs	 fixed bin (35) ext;/* max num of open dbs */
	dcl     mrds_dsl_db_openings$list_dbs entry (ptr, ptr); /* gets list of open dbs */
	declare mrds_dsl_db_openings$list_openings entry (ptr, fixed bin, ptr, fixed bin (35)); /* extended open info */
	declare no_output_mode	 bit (1) int static init ("0"b); /* on => don't return retreived values */
	declare tuples_retrieved	 fixed bin (35);	/* number of values not seen */
	dcl     NA		 char (20) init ("Mode not available");
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35)); /* removes work space */
	dcl     temp_mode_list	 (1:mrds_data_$max_dbs) char (20) based (tml_ptr); /* temp store for opening modes */
	dcl     tml_ptr		 ptr init (null ());/* points to temp_mode_list */

	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
	dcl     cu_$generate_call	 entry (entry, ptr);
	dcl     expand_path_	 entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
	dcl     hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
	dcl     hcs_$terminate_noname	 entry (ptr, fixed bin (35));

     end mrds_call;






		    quiesce_mrds_db.pl1             04/18/85  1424.3rew 04/18/85  0906.3      158634



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

/* HISTORY:

   Originally written by Jim Gray - - May 1980

   80-12-14 Jim Gray : improved "unable to quiesce" error message.

   81-01-27 Jim Gray : added use of  dsl_$get_path_info  to  replace
   deficiencies   of   dsl_$get_version.   Also   added   usage   of
   dmd_$get_user_class as part of the DBA proposal implementation.

   81-04-29 Jim Gray : changed  declaration  of  work_area  size  to
   depend   on   the   current   value   of  mrds_data_$max_dbs  for
   extensibility.

   82-05-19 Mike Kubicar : Changed to permit only one database to be
   quiesced  per  command  invocation.   Also  removed all traces of
   quiesing files.

   82-06-24 Mike Kubicar : Changed conversion of -wait_time arguments
   so that it is compatible with the way it's done in
   rmdb_rq_ready_db.  This raises the maximum legal wait time and
   makes the error messages a little more friendly.

   84-10-19 Paul Benjamin : Added quiesce_db and unquiesce_db which are mmi_
   entrypoints.

   84-10-23 Paul Benjamin : Enabled size checking for one statment so that the
   change of 82-06-24 actually works.

*/

quiesce_mrds_db: qmdb: procedure ();

/* DESCRIPTION:

		      BEGIN_DESCRIPTION 

   this routine is a command and subroutine interface to
   mu_quiesce$quiesce_quiet/free.  It's purpose is to quiesce
   databases, for such activities as database backup, that is to grab
   control of the database so that non-passive users can not access
   the database, or hamper it's integrity.  It has two options, the
   quiesce option with optional wait time argument, and the free
   option which must be called when the quiescer is finished.  Both
   take database path names as their primary arguments, with the
   default option for the command being quiesce.

		       END_DESCRIPTION

*/

/* PARAMETERS:

   database_path - - (input) the relative pathname of the database(s) to be quiesced,
   there may be up to mrds_data_$max_dbs paths given.
   However, currently the quiescing module mu_quiesce$mu_quiesce called thru mdbm_util_
   only accepts one database quiescing per process in one or multiple calls.

   -quiet - - (input) the quiesce option to this command,
   it need not be given, as it is the default.

   -free - - (input) the free option to this command, it must be given after a call
   to quiesce a database, -quiesce and -free are mutually exclussive.

   -wait_time,-wt time - - (input) the wait time in seconds that the caller
   wishes to wait to obtain a quiescing of all databases given.
   This control argument may not be given with the -free option.
   The time must be convertible to fixed bin(35).
   If this control arg is not given, it defaults to 0 seconds.
   (see mdbm_data_$quiesce_wait)

*/

/* start up */

	code = 0;
	command = ON;
	
/* check for the minimum number of arguments */
	call cu_$arg_list_ptr (main_proc_arg_ptr);
	call cu_$arg_count (nargs);
	if nargs < 1 then do;
		code = error_table_$wrong_no_of_args;
		call com_err_ (code, caller_name, "^/^a^/",
		     "Usage:  quiesce_mrds_db database_pathname {-quiet {-wait_time xx} | -free}");
	     end;
	else do;

/* initialize */

		quiet_seen, free_seen, wait_time_seen = OFF;
		quiesce_control = ON;		/* the default is to quiesce */
		quiesce_wait_time = mdbm_data_$quiesce_wait; /* set default wait time */
		number_of_paths = 0;		/* none seen yet */

/* gather all the database pathnames given */

		arg_count = 1;
		args_finished = OFF;
		do while (^args_finished);

/* get the relative pathname */

		     call cu_$arg_ptr (arg_count, arg_ptr, arg_len, code);
		     if code ^= 0 then do;
			     args_finished = ON;
			     call com_err_ (code, caller_name, "^/^a ^d",
				"Unable to get argument number", arg_count);
			end;
		     else do;

			     if arg_len < 1 then do;
				     args_finished = ON;
				     code = error_table_$bad_arg;
				     call com_err_ (code, caller_name, "^/^a ^d",
					"A null character string argument was detected for argument number", arg_count);
				end;
			     else if substr (arg, 1, 1) = "-" then /* control arg */

/* control argument */

				call process_control_arg ();
			     else do;

/* database pathname argument */

				     supplied_db_path = arg;
				     call process_db_path_arg ();

				end;

/* go on to the next argument */

			     if arg_count < nargs then
				arg_count = arg_count + 1;
			     else args_finished = ON;

			end;

		end;

		if code ^= 0 then ;
		else do;

/* save count of pathnames seen */

			if number_of_paths = 0 then do;
				code = error_table_$wrong_no_of_args;
				call com_err_ (code, caller_name, "^/^a",
				     "No database pathname was given.");
			     end;
			else do;

/* call quiet or free according to control args seen, with the quiesce structure */

				if quiesce_control then
				     call mu_quiesce$quiesce_quiet (db_path, quiesce_wait_time, code);
				else call mu_quiesce$quiesce_free (db_path, code);

				if code = 0 then ;
				else call com_err_ (code, caller_name, "^/^a ^a^a^a",
					"Unable to complete the quiescing process on the control segment",
					"using the database path """,
					db_path, """.");

			     end;

		     end;

	     end;

	return;

process_db_path_arg: procedure ();

/* BEGIN CHANGE 81-01-27 ************************************************ */
/* get the version of the database at the given path */

          code = 0;
	
	call mrds_dsl_get_version$get_path_info (supplied_db_path, addr (local_area),
	     mrds_path_info_structure_version, mrds_path_info_ptr, code);

	if mrds_path_info_ptr = null () then
	     db_path = supplied_db_path;
	else db_path = mrds_path_info.absolute_path;

	if code ^= 0 then do;
		args_finished = ON;
		if code = mrds_error_$no_model_submodel then
		     code = mrds_error_$no_database;
		if command 
		     then call com_err_ (code, caller_name, "^/^a^a^a",
		     "The path """, db_path, """ does not refer to a mrds database.");
	     end;
	else do;

/* make sure it isn't a submodel */

		if mrds_path_info.type.submodel then do;
		     if command then do;
			args_finished = ON;
			code = error_table_$badcall;
			call com_err_ (code, caller_name, "^/^a ^a",
			     "Data submodels are not supported by this command.  ", db_path);
		     end;
		     else code = mrds_error_$bad_model;
		     end;
		else do;

/* check for old version databases */

			if mrds_path_info.mrds_version <= 3 then do;
				args_finished = ON;
				code = mrds_error_$version_not_supported;
				if command
				     then call com_err_ (code, caller_name, "^/^a^a^a ^d ^a",
				     "The database path """, db_path, """ refers to an older version",
				     mrds_path_info.mrds_version,
				     "database which this command does not support.");
			     end;

			else do;

/* 	make sure the caller is a DBA */

				call mrds_dm_authorization$get_user_class (db_path, addr (local_area),
				     mrds_authorization_structure_version, mrds_authorization_ptr, code);
				if code ^= 0 then do;
					args_finished = ON;
					if command
					     then call com_err_ (code, caller_name, "^/^a^a^a",
					     "Unable to get user class for database """, db_path, """.");
				     end;
				else if ^mrds_authorization.administrator then do;
					args_finished = ON;
					code = error_table_$insufficient_access;
					if command
					     then call com_err_ (code, caller_name, "^/^a^a^a",
					     "The user must be a database adminstrator to perform this operation on database """,
					     db_path, """.");
				     end;

/* END CHANGE 81-01-27 ************************************************** */

				else if command
				     then do;

/* good new version database path found, save it */

					number_of_paths = number_of_paths + 1;
					if number_of_paths > 1 then do;
						args_finished = ON;
						code = error_table_$too_many_args;
						call com_err_ (code, caller_name,
						     "^/^a",
						     "Only one database pathname can be specified in this command.");
					     end;
				     end;
			     end;
		     end;
	     end;
     end;

process_control_arg: procedure ();

/* check for the control arg options of -quiet, -wait_time or -free */

/* QUIET */
	if arg = "-quiet" then do;
		if free_seen then do;
			quiet_seen = ON;
			args_finished = ON;
			code = error_table_$inconsistent;
			call com_err_ (code, caller_name, "^/^a",
			     "The -quiet and -free control arguments are mutually exclusive.");
		     end;
		else if ^quiet_seen then do;
			quiet_seen = ON;
			quiesce_control = ON;
		     end;
		else do;
			args_finished = ON;
			code = mrds_error_$duplicate_opt;
			call com_err_ (code, caller_name, "^/^a",
			     "The -quiet control argument was given more than once.");
		     end;
	     end;

/* FREE */
	else if arg = "-free" then do;
		if quiet_seen then do;
			free_seen = ON;
			args_finished = ON;
			code = error_table_$inconsistent;
			call com_err_ (code, caller_name, "^/^a",
			     "The -free and -quiet control arguments are mutually exclusive.");
		     end;
		else if ^free_seen then do;
			free_seen = ON;
			quiesce_control = OFF;
		     end;
		else do;
			args_finished = ON;
			code = mrds_error_$duplicate_opt;
			call com_err_ (code, caller_name, "^/^a",
			     "The -free control argument was given more than once.");
		     end;
	     end;

/* WAIT_TIME */
	else if arg = "-wait_time" | arg = "-wt" then do;
		if free_seen then do;
			wait_time_seen = ON;
			code = error_table_$inconsistent;
			args_finished = ON;
			call com_err_ (code, caller_name, "^/^a",
			     "The -wait_time and -free control arguments are mutually exclusive.");
		     end;
		else if wait_time_seen then do;
			code = mrds_error_$duplicate_opt;
			args_finished = ON;
			call com_err_ (code, caller_name, "^/^a",
			     "The -wait_time control argument was given more than once.");
		     end;
		else do;				/* get the wait time in seconds */
			wait_time_seen = ON;
			if arg_count >= nargs then do;
				args_finished = ON;
				code = error_table_$bad_arg;
				call com_err_ (code, caller_name, "^/^a",
				     "No time in seconds was given for the -wait_time control argument.");
			     end;
			else do;
				arg_count = arg_count + 1;
				call cu_$arg_ptr_rel (arg_count, arg_ptr, arg_len, code, main_proc_arg_ptr);
				if code ^= 0 then do;
					args_finished = ON;
					call com_err_ (code, caller_name, "^/^a",
					     "Unable to get the wait_time seconds argument.");
				     end;
				else if substr (arg, 1, 1) = "-" &
					(verify (arg, "+-.0123456789") ^= 0) then do;
					args_finished = ON;
					code = error_table_$badopt;
					call com_err_ (code, caller_name,
					     "^/No time in seconds was given for the -wait_time control argument.");
				     end;
				else do;
					on size begin;
						code = error_table_$item_too_big;
						call com_err_ (code, caller_name,
						     "^/The quiesce wait time must be no greater than 131071 seconds.");
						go to couldnt_convert;
end;
(size):					quiesce_wait_time = cv_dec_check_ (arg,
					     code);
					if code ^= 0 then do;
						args_finished = ON;
						code = error_table_$badopt;
						call com_err_ (code, caller_name,
						     "^/""^a"" following the -wait_time argument is not a positive integer.", arg);
					     end;
					if quiesce_wait_time < 0 then do;
						args_finished = ON;
						code = error_table_$badopt;
						call com_err_ (code, caller_name,
						     "^/The quiesce wait time must not be negative;  it was ^a.", arg);
					     end;

couldnt_convert:
					revert size;
				     end;
			     end;
		     end;
	     end;

/* UNKNOWN */
	else do;
		args_finished = ON;
		code = error_table_$bad_arg;
		call com_err_ (code, caller_name, "^/^a^a^a",
		     "The control argument """, arg, """, is not supported by this command.");
	     end;
     end;

quiesce_db:
     entry (sq_path, sq_wait, sq_code);
     
/* External subroutine interface for quiescing databases.  Expands and 
   validates the input database pathname and calls mu_$quiesce_quiet. */

dcl  sq_path char (168) parameter;			/* (input) database pathname */
dcl  sq_wait fixed bin (17) parameter;			/* (input) quiesce wait time */
dcl  sq_code fixed bin (35) parameter;			/* (output) status code */

     supplied_db_path = sq_path;
     quiesce_wait_time = sq_wait;
     command = OFF;
     call process_db_path_arg;
     if code ^= 0
	then do;
	sq_code = code;
	return;
     end;
     call mu_quiesce$quiesce_quiet (db_path, quiesce_wait_time, code);
     sq_code = code;
     return;

unquiesce_db:
     entry (sf_path, sf_code);
     
/* External subroutine interface for freeing quiesced databases.  Expands and 
   validates the input database pathname and calls mu_$quiesce_free. */

dcl  sf_path char (168) parameter;			/* (input) database pathname */
dcl  sf_code fixed bin (35) parameter;			/* (output) status code */

     supplied_db_path = sf_path;
     command = OFF;
     call process_db_path_arg;
     if code ^= 0
	then do;
	sf_code = code;
	return;
     end;
     call mu_quiesce$quiesce_free (db_path, code);
     sf_code = code;
     return;

	declare (addr, empty, null, substr, verify) builtin;
	declare error_table_$badopt	 fixed bin (35) ext;/* unknown options */
	declare (free_seen, quiet_seen, wait_time_seen) bit (1); /* duplicate control arg flags */
	declare error_table_$inconsistent fixed bin (35) ext; /* incompatible control args */
	declare mrds_error_$duplicate_opt fixed bin (35) ext; /* control arg given > 1 times */
	declare mrds_error_$no_database fixed bin (35) ext; /* no db model */
	declare error_table_$bad_arg	 fixed bin (35) ext;/* illegal argument */
	declare error_table_$too_many_args fixed bin (35) ext; /* more args than quiesce structure can handle */
	declare args_finished	 bit (1);		/* on => arg processing done */
	declare code		 fixed bin (35);	/* error status encoding */
	declare main_proc_arg_ptr	 ptr;		/* Pointer to argument list of main procedure */
	declare ON		 bit (1) int static options (constant) init ("1"b); /* true value */
	declare OFF		 bit (1) int static options (constant) init ("0"b); /* false value */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* bad arg count */
	declare cu_$arg_list_ptr	 entry (ptr);
	declare cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
	declare cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); /* gets arg N */
	declare size		 condition;
	declare arg_count		 fixed bin;	/* current argument being looked at */
	declare arg		 char (arg_len) based (arg_ptr); /* current argument */
	declare arg_len		 fixed bin (21);	/* length of char string arg */
	declare arg_ptr		 ptr;		/* pointer to current arg */
	declare cu_$arg_count	 entry (fixed bin); /* gets argument count */
	declare nargs		 fixed bin;	/* total arg count */
	declare mu_quiesce$quiesce_quiet entry (char (168), fixed bin (17), fixed bin (35)); /* quiesces db */
	declare mu_quiesce$quiesce_free entry (char (168), fixed bin (35)); /* frees quiesced db */
	declare com_err_		 entry options (variable); /* reports errors */
	declare command		 bit (1);		/* ON = called as a command */
						/* OFF = called as a subroutine */
	declare db_path		 char (168);	/* absolute database pathname */
	declare supplied_db_path	 char (168);	/* path supplied by caller */
	declare mdbm_data_$quiesce_wait fixed bin (35) ext; /* default wait time */
	declare error_table_$item_too_big fixed bin (35) ext static; /* The item in question is larger than the largest legal value */
	declare error_table_$badcall	 fixed bin (35) ext;/* bad pathname syntax, submodel path given */
	declare quiesce_control	 bit (1);		/* on => call quiesce_quiet, the default */
	declare quiesce_wait_time	 fixed bin (17);	/* Time to wait on database */
	declare mrds_error_$version_not_supported fixed bin (35) ext; /* can't work with old versions */
	declare caller_name		 char (15) init ("quiesce_mrds_db"); /* name of calling routine */
	declare number_of_paths	 fixed bin;	/* db pathnames given in arg list */
	declare local_area		 area (1024);	/* space for path info and authorization structures */
	declare mrds_dsl_get_version$get_path_info entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* gets db version */
	declare mrds_dm_authorization$get_user_class entry (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* tells if user a DBA */
	declare error_table_$insufficient_access fixed bin (35) ext; /* process lacks access */
	declare mrds_error_$no_model_submodel fixed bin (35) ext; /* not a mrds path */
          declare mrds_error_$bad_model fixed bin(35) ext static; /* not a model */

%include mrds_authorization;

%include mrds_path_info;


     end;




		    secure_mrds_db.pl1              04/18/85  1424.3re  04/18/85  0906.3       81081



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

/* HISTORY:

   Originally written by Jim Gray - - November 1980

   81-01-20 Jim Gray : modified to take advantage of extended interface
   of mrds_dm_db_secured, replacing mrds_dm_get_secured_status, and mrds_dm_set_db_secured.

   83-02-03 Roger Lackey : Removed unreferenced variables and entries, added
   dcl for builtins.
*/

secure_mrds_db: smdb: procedure ();

/* DESCRIPTION:

   This routine is used to set/reset/display a "secured" bit in the database
   that affects how database security is handled.
   If the bit is not set, the databse operations are as per mr8.0 mrds.
   If the bit is set, the openings must be via new version
   security submodels, and model commands are only usable by a DBA.
   NOTE: use of this command requires "sma" access on the database directory,
   and "rw" access on the db_model segment.

*/

/* PARAMETERS:

   db_path - - (input) char(*), the relative or absolute pathname of
   a version 4 database(earlier versions are not supported by this command)

   control_arg - - (input) char(*), either "-set",  "-reset" or "-display"
   may be optionally given as a control argument(only 1).
   The action without control arguments is to set the secured bit to on,
   (i.e. -set is the default)
   the -reset control causes it to be set to off, and the -display
   control argument will display the current value of the secured bit.

*/
%page;
/* inititalize */

	code = 0;
	data_model_ptr = null ();
	on cleanup call clean_up ();

/* get the argument list */

	call cu_$arg_list_ptr (al_ptr);
	nargs = arg_list.arg_count / 2;
	num_ptrs = arg_list.arg_count;

	if nargs < 1 | nargs > 2 then
	     call com_err_ (error_table_$wrong_no_of_args, caller_name, "^/^a^/",
		"Usage:  smdb  db_path  [-set|-reset|-display]");
	else do;

/* get optional control arguments and set defaultts */

		secure, change = ON;		/* defaults */

		if nargs = 2 then do;		/* control arg supplied */

			call cu_$arg_ptr (2, arg_ptr, arg_len, code);
			if code ^= 0 then
			     call com_err_ (code, caller_name, "^/^a",
				"Unable to get the control argument.");
			else do;

				if arg = "-set" then ;
				else if arg = "-reset" | arg = "-rs" then
				     secure = OFF;
				else if arg = "-display" | arg = "-di" then
				     change = OFF;
				else do;
					code = error_table_$badopt;
					call com_err_ (code, caller_name, "^/^a^a^a",
					     "Unknown control argument """, arg, """ given.");
				     end;
			     end;
		     end;

		if code ^= 0 then ;
		else do;

/* get the database pathname argument */

			call cu_$arg_ptr (1, arg_ptr, arg_len, code);
			if code ^= 0 then
			     call com_err_ (code, caller_name, "^/^a",
				"Unable to get database pathname argument.");
			else do;

				call mrds_dsl_get_version$get_path_info ((arg), addr (local_area),
				     mrds_path_info_structure_version, mrds_path_info_ptr, code);

				if mrds_path_info_ptr = null () then
				     db_path = arg;
				else do;
					db_path = mrds_path_info.absolute_path;
					version = mrds_path_info.mrds_version;
				     end;

				if code ^= 0 then
				     call com_err_ (code, caller_name, "^/^a^a^a",
					"Unable to get version of the database using the path """, db_path, """.");
				else do;

/* check that we do not have a submodel, or database version < 4 */

					if mrds_path_info.type.submodel then do;
						code = error_table_$badcall;
						call com_err_ (code, caller_name, "^/^a ^a",
						     "Data submodels are not supported by this command. ", db_path);
					     end;
					else if version < 4 then do;
						code = mrds_error_$version_not_supported;
						call com_err_ (code, caller_name, "^/^a^a^a ^d ^a",
						     "The pathname """, db_path, """ referes to a version", version,
						     "database (< 4) not supported by this command.");
					     end;



/* if valid version 4 database path, process the command */

					if code ^= 0 then ;
					else call process_security ();

				     end;
			     end;
		     end;
	     end;

	call clean_up ();

	return;
%page;
process_security: procedure ();

/* routine to open data model, and change/display security bit
   now that we have a good database pathname */

	call mrds_dm_open (db_path, mode, data_model_ptr, code);
	if code ^= 0 then
	     call com_err_ (code, caller_name, "^/^a^a^a",
		"Unable to open the database model using the path """, db_path, """.");

	else do;

		if change then do;

/* change the database secured bit according to the option given */

			if secure then
			     call mrds_dm_db_secured$set_db_secured (data_model_ptr, code);
			else call mrds_dm_db_secured$reset_db_secured (data_model_ptr, code);

			if code ^= 0 then
			     call com_err_ (code, caller_name, "^/^a^a^a",
				"Unable to change the database security using the path """, db_path, """.");
		     end;

/* display the current secured bit status */

		if code = 0 then do;

			call mrds_dm_db_secured$get_secured_status (data_model_ptr, addr (local_area),
			     database_state_structure_version, database_state_ptr, code);
			if code ^= 0 then
			     call com_err_ (code, caller_name, "^/^a^a^a",
				"Unable to get the status of the security for database at """, db_path, """.");
			else do;

				if database_state.secured then
				     call ioa_ ("^/The database at ""^a"" has been secured.", db_path);
				else call ioa_ ("^/The database at ""^a"" is not secured.", db_path);

			     end;
		     end;
	     end;

     end;
%page;
clean_up: procedure ();

/* routine to clean up after error or normal termination */

	if data_model_ptr = null () then ;
	else do;

		call mrds_dm_close (data_model_ptr, code);
		data_model_ptr = null ();

	     end;

     end;
%page;
	declare code		 fixed bin (35);	/* error status encoding */
	declare cleanup		 condition;	/* signaled upon quit - release */
	declare error_table_$badopt	 fixed bin (35) ext;/* unknown control arg */
	declare data_model_ptr	 ptr;		/* points to database model */
	declare mrds_error_$version_not_supported fixed bin (35) ext; /* not version 4 db */
	declare mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35)); /* opens database model */
	declare mode		 fixed bin init (2);/* retrieval model opening mode */
	declare mrds_dm_close	 entry (ptr, fixed bin (35)); /* closes database model */
	declare ON		 bit (1) init ("1"b); /* true value */
	declare OFF		 bit (1) init ("0"b); /* false value */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* args ^= 1 or 2 */
	declare mrds_dsl_get_version$get_path_info entry
				 (char (*), ptr, fixed bin, ptr, fixed bin (35)); /* gets version of db */
	declare db_path		 char (168);	/* pathname of database */
	declare version		 fixed bin;	/* version number of dtabase */
	declare ioa_		 entry options (variable); /* reports secured bit status */
	declare change		 bit (1);		/* on => change existing secured bit status */
	declare secure		 bit (1);		/* on => set secured bit to on */
	declare cu_$arg_list_ptr	 entry (ptr);	/* gets argument list */
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); /* gets arg N */
	declare arg		 char (arg_len) based (arg_ptr); /* argument */
	declare arg_len		 fixed bin (21);	/* length of argument */
	declare arg_ptr		 ptr;		/* points to argument */
	declare com_err_		 entry options (variable); /* reports errors */
	declare caller_name		 char (32) init ("secure_mrds_db"); /* name of calling routine */
	declare mrds_dm_db_secured$get_secured_status entry (ptr, ptr, fixed bin,
				 ptr, fixed bin (35)); /* gets state of secured bit in db */
	declare local_area		 area (1024);	/* space for database state structure */
	declare mrds_dm_db_secured$set_db_secured entry (ptr, fixed bin (35)); /* sets secured bit to on */
	declare mrds_dm_db_secured$reset_db_secured entry (ptr, fixed bin (35)); /* resets secured bit */
	declare nargs		 fixed bin;	/* number of arguments */
	declare error_table_$badcall	 fixed bin (35) ext;/* submodel path given */
	declare (addr, empty, null)	 builtin;
%page;
%include mdbm_arg_list;
%page;
%include mrds_database_state;
%page;
%include mrds_path_info;

     end;




		    set_mrds_options.pl1            08/01/88  1406.1rew 08/01/88  1300.0       64287



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */



/****^  HISTORY COMMENTS:
  1) change(87-01-22,Hergert), approve(88-07-11,MCR7903),
     audit(88-07-11,Dupuis), install(88-08-01,MR12.2-1073):
     Changed design of the flags structure for use with the new parser.
                                                   END HISTORY COMMENTS */


set_mrds_options:
smo:
    proc;

/* DESCRIPTION

 smo {-pso -ot -pse -er on|off {-force}} | -reset -list

   The purpose of this procedure is to implement the set_mrds_options command.
   The options set here control the way MRDS will act.
   The various mrds options that can be set by this command are 
   print_search_order, and no_ot. Also controllable is error_report and
   print_selection_expression. error_report (er) causes the long form of 
   error reporting to be turned on or off. pse dumps the select expression
   in some human readable format. control options are -list and -reset.
   -list lists the current state of the switches. -reset causes all switches
   to be reset to their default values.

   HISTORY:

   85-08-23 Originally written by John Hergert (FMC)


   INPUT CONDITIONS:

   Some control arg must be supplied. If it is one of the options I.E.
   -er -pso -ot -pse then it must be followed by either "on" or "off".
   -force may be supplied, but only has effect on args that can be put in 
   selection expressions, as it is intended to force overriding default 
   values supplied in the sex.

*/

        code = 0;
        flags = OFF;


        call cu_$arg_count (nargs, code);
        if (code ^= 0) then call error (code);

        if nargs = 0 then do;
	  call com_err_ (0, program_name,
	      "^/^a^/",
	      "Usage: set_mrds_options {{{-pso on|off} | {-ot on|off} | {-pse on|off} | {-er on|off}} {-force}} | -reset -list"
	      );
	  goto exit;
        end;

        more_args = TRUE;
        i = 1;
        do while (more_args);

	  call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	  if (code ^= 0) then call error (code);

	  if arg = "-pso" | arg = "-print_search_order"
	  then do;
	      flags.selected.pso = TRUE;
	      call get_arg_flag (flags.value.pso, i);
	  end;
	  else if arg = "-ot" | arg = "-optimize"
	       then do;
		 flags.selected.ot = TRUE;
		 call get_arg_flag (flags.value.ot, i);
	       end;
	       else if arg = "-pse" | arg = "-print_selection_expression"
		  then do;
		      flags.selected.pse = TRUE;
		      call get_arg_flag (flags.value.pse, i);
		  end;
		  else if arg = "-er" | arg = "-error_report"
		       then do;
			 flags.selected.error = TRUE;
			 call get_arg_flag (flags.value.error, i);
		       end;
		       else if arg = "-rs" | arg = "-reset"
			  then if nargs = 1 then do;
				 flags.reset_sw = ON;
				 more_args = FALSE;
			       end;
			       else do;
				 call com_err_ (0,
				     program_name,
				     "^/^a^/",
				     "The -reset control argument is incompatible with any other control arguments."
				     );
				 goto exit;
			       end;
			  else if arg = "-ls" | arg = "-list"
			       then if nargs = 1 then do;
				      flags.list_sw = ON;
				      more_args = FALSE;
				  end;
				  else do;
				      call com_err_ (0,
					program_name,
					"^/^a^/",
					"The -list control argument is incompatible with any other control arguments."
					);
				      goto exit;
				  end;
			       else if arg = "-fc" | arg = "-force"
				  then if nargs ^= 1
				       then flags.selected.force,flags.value.force = ON;
				       else do;
					 call com_err_ (0,
					     program_name,
					     "^/^a^/",
					     "The -force control argument must be used with other control arguments."
					     );
					 goto exit;
				       end;
				  else do;
				      call com_err_ (
					error_table_$badopt,
					program_name,
					"^/^a^/",
					"Usage: set_mrds_options {-pso | -ot | -pse | -er {on|off} {-force}} | -reset -list"
					);
				      goto exit;
				  end;

	  i = i + 1;
	  if i > nargs then more_args = FALSE;
        end;


        if flags.reset_sw then do;
	  flags.selected.pse, flags.selected.pso, flags.selected.ot,
	      flags.selected.error, flags.selected.force = ON;
	  flags.value.pso, flags.value.pse, flags.value.force = OFF;
	  flags.value.error, flags.value.ot = ON;
        end;

        call mrds_dsl_translate$set_options (addr (flags));

        if flags.list_sw then do;
	  call ioa_ ("  MRDS Selection Expression Options:^/");
	  call ioa_ ("Print search order:^40t^[ON^;OFF^]", flags.value.pso);
	  call ioa_ ("Print selection expression:^40t^[ON^;OFF^]",
	      flags.value.pse);
	  call ioa_ ("Optimize selection expression:^40t^[ON^;OFF^]",
	      flags.value.ot);
	  call ioa_ ("Force override default values:^40t^[ON^;OFF^]",
	      flags.value.force);
	  call ioa_ ("Long error report:^40t^[ON^;OFF^]^/",
	      flags.value.error);
        end;

exit:
        return;

error:
    proc (cd);
dcl     cd		 fixed bin (35);
        call com_err_ (cd, program_name);
        goto exit;
    end;

get_arg_flag:
    procedure (flag, arg_index);

/* handle on or off args in the command line */

dcl     flag		 bit (1);
dcl     arg_index		 fixed bin;

        if arg_index = nargs then do;
	  call com_err_ (error_table_$wrong_no_of_args, program_name,
	      "^/^a^/",
	      "on or off must be specified after the control argument '"
	      || arg || "'."
	      );
	  goto exit;
        end;


        arg_index = arg_index + 1;			/* point to the next one */

        call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
        if (code ^= 0) then call error (code);

        if arg = "on"
        then flag = ON;
        else if arg = "off"
	   then flag = OFF;
	   else do;
	       call com_err_ (error_table_$badopt, program_name,
		 "^/^a^/",
		 "on or off must be specified after the control argument. Not '"
		 || arg || "'."
		 );
	       goto exit;
	   end;

    end get_arg_flag;

%include mrds_se_options;
%page;
/* local variables */

dcl     program_name	 char (27) internal static
			 options (constant) init ("set_mrds_options");
dcl     (nargs, i)		 fixed bin;
dcl     arg		 char (arg_len) based (arg_ptr);
dcl     arg_len		 fixed bin (21);
dcl     arg_ptr		 ptr;
dcl     more_args		 bit;

dcl     code		 fixed bin (35);
dcl     (OFF, FALSE)	 bit internal static options (constant)
			 init ("0"b);
dcl     (ON, TRUE)		 bit internal static options (constant)
			 init ("1"b);
dcl     1 flags		 aligned like mode_flags;

dcl     mrds_dsl_translate$set_options
			 entry (ptr);
dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21),
			 fixed bin (35));
dcl     ioa_		 entry () options (variable);
dcl     com_err_		 entry options (variable);

/* error codes */
dcl     (
        error_table_$wrong_no_of_args,
        error_table_$badopt
        )			 external fixed bin (35);

/* builtins */
dcl     addr		 builtin;

    end set_mrds_options;




		    set_mrds_temp_dir.pl1           04/18/85  1424.3re  04/18/85  0906.3       33039



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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

/* HISTORY:

   Originally written by Jim Gray - - August 1979

*/

set_mrds_temp_dir: smtd: procedure ();

/* DESCRIPTION:

   this is a command level interface, that is used to
   set the value of a pathname to a directory that will be
   used for temporary storage needed by the resultant database
   model created during database open time.
   normally the process directory is used for this temporary
   storage, but for large databases, a directory with more quota
   may be required, thus the need for this interface to
   specify that directory, and override the [pd] default.
   NOTE: the temp dir may be changed between calls to mrds_dsl_open.
*/

/* PARAMETERS:

   relative_path - - (input) the pathname, relative or absolute,
   of the directory under which temporary storage is to be placed.

   error_messages - - (output) via com_err_ in case a problem is discovered
   with the given pathname.

*/

/* check for correct number of arguments */

	call cu_$arg_count (nargs);
	if nargs ^= 1 then
	     call com_err_ (error_table_$wrong_no_of_args, caller_name, "^/^a ^d ^a",
		"The number of arguments =", nargs, "was not 1, the temporary directory pathname.");
	else do;

/* get the pathname argument */

		call cu_$arg_ptr (1, arg_ptr, arg_len, error_code);
		if error_code ^= 0 then
		     call com_err_ (error_code, caller_name, "^/^a",
			"Unable to obtain the temporary directory pathname argument.");
		else do;

/* pathname obtained, use the subroutine entry to set it */

			on sub_error_ ;		/* ignore sub_err_ messages */

			call mrds_dsl_resultant_storage$set (relative_path, error_code);
			if error_code = 0 then ;
			else call com_err_ (error_code, caller_name, "^/^a^a^a",
				"Unable to set the temporary directory to the pathname """, relative_path, """.");

		     end;

	     end;

	declare com_err_		 entry options (variable); /* reports errors */
	declare mrds_dsl_resultant_storage$set entry (char (*), fixed bin (35)); /* sets  temp dir */
	declare sub_error_		 condition;	/* signaled by calls to sub_err_ in set routine */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare caller_name		 char (20) init ("set_mrds_temp_dir"); /* name of calling routine */
	declare cu_$arg_count	 entry (fixed bin); /* gets number of arguments */
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); /* gets char(*) argument */
	declare arg_ptr		 ptr;		/* points to relative path argument */
	declare arg_len		 fixed bin (21);	/* length of input argument */
	declare relative_path	 char (arg_len) based (arg_ptr); /* temp dir path input */
	declare nargs		 fixed bin;	/* current arg count */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* arg count not 1 */

     end;




		    unpopulate_mrds_db.pl1          10/16/86  1550.1r w 10/16/86  1145.0      170244



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

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


/****^  HISTORY COMMENTS:
  1) change(85-11-08,Dupuis), approve(85-12-16,MCR7314),
     audit(86-02-04,Brunelle), install(86-02-05,MR12.0-1013):
     This entry is being made to cover the change made on 85-04-15 by Thanh
     Nguyen. (see mrds #136)
                                                   END HISTORY COMMENTS */


unpopulate_mrds_db:
umdb:
     procedure ();

/* DESCRIPTION:

   This module is primarily for use in testing  mrds  databases,  of
   any  version,  for  the  purpose  of deleting all data in a given
   database, so that subsequent tests will not be  affected  by  the
   results  of  previous tests. the major advantage of this utility,
   is not having to know the architecture of the database  involved,
   as  well  as  the  time  savings,  in  not  having  to delete the
   database, and do another cmdb, to get  an  unpopulated  database.
   the  command display_mrds_db_population can be used to verify the
   results. There is no required order to the arguments. The control
   arguments  are  over-ridable,  with  the  last  given  being  the
   accepted condition.



   PARAMETERS:

   database_path - - (input) character, the relative pathname of the
   database,  whose  data is to be deleted. The user will be queried
   before actual data deletion takes place. If there is no  data  in
   the  database,  no  error will occur. The user must a DBA for the
   given database. If it is a version 3 database, no other version 3
   database must be open.

   -force, -fc - - (input) optional  control  argument,  causes  the
   query as to whether data is to be delete, to be suppressed.

   -no_force, -nfc - - (input) optional control argument, causes the
   user  to  be quered as to whether he really intends to delete all
   data from the given database. This is the default.




   HISTORY:

   80-05-15 Jim Gray : Originally coded.

   81-04-11  Jim  Gray : got module in shape for being part of a MRDS release.
   Added  -force  and  -no_force control arguments, and restricted use of this
   command to a DBA.
   
   81-09-16  Rickie  E.   Brinegar:  The assignment of abs_path to db path was
   changed  to  be  done  via a rtrim of abs_path to avoid the substring range
   condition on compiling.   

   83-02-01 Davids: Modified the internal procedure delete_data to not have
   the deeply nested if-then-else structure. This was done by going to an
   exit_delete_data or finish_transaction label. The transaction include files
   were also added to the delete_data procedure. By puting the transaction
   in delete_data the rollback operation did not require the restoration of
   any significant data.

   83-02-03 Davids: added declarations for the fixed and rel builtins
   which are used in the mdbm_db_model include file.

   83-02-14 Davids: modified to use the new db_type_flags in the db_model
   structure instead of the old numeric db_type.

   83-05-23 Davids: Renamed the info_ptr variable to command_query_info_ptr.
   This was needed because the mrds_start_transaction include file now
   contains the condition_info include file. The condition_info include file
   declares a structure with a level 2 element of info_ptr. The
   mrds_start_transaction incl file is included in the delete_data internal
   procedure which is the same procedure that command_query_ is called in with
   the info_ptr variable. The info_ptr that points to the query structure is
   declared in the main procedure so what happens is that the info_ptr in
   the condition_info structure is incorrectly used.

   83-06-24 Davids: Modified so that an error is noot reported at the end
   of the finish transaction code if the mftxn_code has the same value
   as that of error_code since that error was already reported.
*/

	if recursive_call then do;			/* we can't allow recursion because of dsl_$open */
		error_code = mrds_error_$no_recursion;
		call
		     com_err_ (error_code, caller_name, "^/^a",
		     "A release or a start must be done before continuing.");
	     end;
	else do;

/* initialize */

		error_code = 0;
		area_ptr = null ();
		force_control = "0"b;		/* default to query user before deleting */
		all_relations = "1"b;		/* default to showing all relations in the view */
		path_seen = "0"b;
		data_model_ptr = null ();
		db_open = "0"b;
		command_query_info_ptr = addr (query_info);
		query_info.version = query_info_version_5;
		query_info.yes_or_no_sw = "1"b;
		on sub_error_ ;			/* ignore */
		call cu_$af_arg_count (nargs, error_code); /* make sure we weren't called as an active function */
		if error_code ^= error_table_$not_act_fnc then
		     call
			com_err_ (error_code, caller_name, "^/^a",
			"Command called as an active function, or unable to obtain argument count."
			);
		else do;

			error_code = 0;
			on cleanup call clean_up ();
			recursive_call = "1"b;	/* prevent recursion */

/* check for a good call */

			if nargs < 1 then do;
				error_code = error_table_$wrong_no_of_args;
				call
				     com_err_ (error_code, caller_name, "^/^a",
				     "Usage:  umdb  path  {-force|-no_force}");
			     end;
			else do;

/* get some work space */

				call get_temp_segment_ (caller_name, area_ptr, error_code);
				if error_code ^= 0 then
				     call
					com_err_ (error_code, caller_name, "^/^a",
					"Unable to get a temp segment.");
				else do;

					area_ptr -> work_area = empty ();

/* gather all the arguments */

					call gather_arguments ();

/* check that we got a  pathname argument */

					if error_code = 0 then do;

						if ^path_seen then do;
							error_code = error_table_$noarg;
							call
							     com_err_ (error_code, caller_name, "^/^a",
							     "No pathname argument was given.");
						     end;

/* now we can go delete the data */

						else call delete_data ();

					     end;
				     end;

			     end;


/* clean up after finishing */

			call clean_up ();

		     end;

	     end;

	return;

gather_arguments:
     procedure ();

/* routine to gather all arguments */

	arg_count = 1;
	args_finished = "0"b;
	do while (^args_finished);

/* get this argument, and decide if it is a control argument or not */

	     call cu_$arg_ptr (arg_count, arg_ptr, arg_len, error_code);
	     if error_code ^= 0 then do;
		     args_finished = "1"b;
		     call
			com_err_ (error_code, caller_name, "^/^a ^d",
			"Unable to get argument number", arg_count);
		end;
	     else do;

/* check for a null argument */

		     if arg_len < 1 then do;
			     args_finished = "1"b;
			     error_code = error_table_$bad_arg;
			     call
				com_err_ (error_code, caller_name, "^/^a ^d",
				"A null character string was detected for argument number",
				arg_count);
			end;
		     else do;

/* control arguments begin with a hyphen */

			     if substr (arg, 1, 1) = "-" then
				call process_control_arg ();
			     else call process_path_arg ();

			end;

/* advance to the next argument */

		     if arg_count < nargs then
			arg_count = arg_count + 1;
		     else args_finished = "1"b;

		end;

	end;

     end;

process_control_arg:
     procedure ();

/* routine to determine if user has given one of the legal
   control arguments of no_force. or force.
   The logic is such as to allow duplicate control arguments
   to override each other, with the last given taking effect. */

/* NO_FORCE */

	if arg = "-no_force" | arg = "-nfc" then do;
		force_control = "0"b;		/* query user first */
	     end;

/* FORCE */

	else if arg = "-force" | arg = "-fc" then do;
		force_control = "1"b;		/* dont query */
	     end;

/* UNKNOWN */

	else do;
		args_finished = "1"b;
		error_code = error_table_$badopt;
		call
		     com_err_ (error_code, caller_name, "^/^a^a^a",
		     "The control argument """, arg,
		     """ is not supported by this command.");
	     end;

     end;

process_path_arg:
     procedure ();

/* routine to verify the database model path or submodel path
   argument, that supplies the view for access information.
   Only one path argument is allowed */

	if path_seen then do;

/* duplicate path name arguments given */

		args_finished = "1"b;
		error_code = mrds_error_$duplicate_opt;
		call
		     com_err_ (error_code, caller_name, "^/^a ^a",
		     "The pathname argument was given more than once:", arg);
	     end;
	else do;

/* first pathname seen */

		path_seen = "1"b;

/* check for a valid path to a model or submodel */

		call
		     mrds_dsl_get_version$get_path_info (arg, area_ptr,
		     mrds_path_info_structure_version, mrds_path_info_ptr, error_code);
		if mrds_path_info_ptr = null () then
		     abs_path = arg;
		else abs_path = mrds_path_info.absolute_path;
		if error_code ^= 0 then do;
			args_finished = "1"b;
			call
			     com_err_ (error_code, caller_name, "^/^a^a^a",
			     "Unable to find database information using the path """,
			     abs_path, """.");
		     end;

		else do;

/* check that this is a data base, not a submodel */

			if mrds_path_info.type.submodel then do;
				args_finished = "1"b;
				error_code = error_table_$bad_arg;
				call
				     com_err_ (error_code, caller_name, "^/^a^a^a",
				     "This command will only accept database paths.  The path """,
				     abs_path, """ refers to a submodel.");
			     end;
			else do;

/* good database path given */

				db_path = rtrim (abs_path);

/* make sure the user is a DBA */

				if mrds_path_info.mrds_version = 4 then do;

					call
					     mrds_dm_authorization$get_user_class (rtrim (db_path),
					     area_ptr, mrds_authorization_structure_version,
					     mrds_authorization_ptr, error_code);
					if error_code ^= 0 then do;
						args_finished = "1"b;
						call
						     com_err_ (error_code, caller_name, "^/^a^a^a",
						     "Unable to determine if the user is a DBA for the database """
						     , db_path, """.");
					     end;
					else if ^mrds_authorization.administrator then do;
						args_finished = "1"b;
						error_code = error_table_$insufficient_access;
						call
						     com_err_ (error_code, caller_name, "^/^a^a^a",
						     "The user must be a DBA to use this command on the database """
						     , db_path, """.");
					     end;


				     end;

			     end;
		     end;

	     end;

     end;

delete_data:
     procedure ();

/* routine to delete all data from the database */

/* check to see if he really wants to delete all data */

	if force_control then
	     answer = "yes";
	else call command_query_ (command_query_info_ptr, answer, caller_name, "^a^a^a",
		"Do you really wish to delete all data currently stored in the database """
		, db_path, """?");
	if answer ^= "yes"
	then goto exit_delete_data;

/* open the model, and get all relation names */

	call mrds_dm_open (db_path, mode, data_model_ptr, error_code);
	if error_code ^= 0
	then do;
		call com_err_ (error_code, caller_name,
		     "^/Unable to open the data model for database ^a.", db_path);
		goto exit_delete_data;
	     end;

	call mrds_dm_get_relations (data_model_ptr, addr (work_area), mr_ptr,
	     error_code);
	if error_code ^= 0
	then do;
		call com_err_ (error_code, caller_name,
		     "^/Unable to get the relation names from the model for database ^a.", db_path);
		goto exit_delete_data;
	     end;

	mstxn_txn_id = "0"b;
	mstxn_transactions_needed = data_model_ptr -> db_model.db_type_flags.transactions_needed;

	on cleanup begin;
		call mstxn_cleanup;
		call clean_up;
	     end;

	on any_other call mstxn_any_other;

%include mrds_start_transaction;

	if mstxn_code ^= 0
	then do;
		call com_err_ (mstxn_code, caller_name, "^/Unable to start a transaction.");
		goto exit_delete_data;
	     end;

/* open the database itself, in an exclusive mode, to be able to delete data */

	if ^db_open
	then do;
		call mrds_dsl_open (db_path, dbi, EXCLUSIVE_UPDATE, error_code);
		if error_code ^= 0
		then do;
			call com_err_ (error_code, caller_name,
			     "^/Unable to get an exclusive opening of the database ^a.", db_path);
			goto finish_transaction;
		     end;
		else db_open = "1"b;
	     end;

/* delete all data for each relation in the database */

	call ioa_ ("^/^a ^d ^a ^a", "Opening version",
	     mrds_path_info.mrds_version, "database:", db_path);

	do rel_num = 1 by 1 to model_relations.nrels
	     while (error_code = 0);

	     rel_name = model_relations (rel_num).relation_name;
	     call mrds_dsl_delete (dbi,
		"-range (x " || rel_name || ") -select x", error_code);
	     if error_code = mrds_error_$tuple_not_found then
		error_code = 0;			/* 0 tuples OK */

	end;

	if error_code ^= 0
	then call com_err_ (error_code, caller_name,
		"^/Unable to delete all tuples from the relation ^a for the database ^a.",
		rel_name, db_path);
	else call ioa_ ("^/Data deletion complete, closing database.");

finish_transaction:
	mftxn_code = error_code;

%include mrds_finish_transaction;

	if mftxn_code ^= 0 & mftxn_code ^= error_code	/* don't report the same error twice */
	then call com_err_ (mftxn_code, caller_name, "^/Unable to finish transaction");

exit_delete_data:
	return;

should_rollback: proc () returns (bit (1));

	return ("0"b);

     end should_rollback;

restore_significant_data: proc;

	return;

     end restore_significant_data;


     end delete_data;

clean_up:
     procedure ();

/* close the model, and database, if open */

	if data_model_ptr = null () then
	     ;
	else do;
		call mrds_dm_close (data_model_ptr, discard);
		data_model_ptr = null ();
	     end;

	if ^db_open then
	     ;
	else do;
		call mrds_dsl_close (dbi, discard);
		db_open = "0"b;
	     end;

	if area_ptr ^= null () then do;
		call release_temp_segment_ (caller_name, area_ptr, discard);
		area_ptr = null ();
	     end;

	recursive_call = "0"b;

     end;

	declare abs_path		 char (200);	/* absolute pathname of model or submodel */
	declare all_relations	 bit (1);		/* on => do all rels in view */
	declare answer		 char (4) varying;	/* answer from command query */
	declare area_ptr		 ptr;		/* points to work space */
	declare arg		 char (arg_len) based (arg_ptr); /* input argument */
	declare arg_count		 fixed bin;	/* current arg under inspection */
	declare arg_len		 fixed bin (21);	/* lengh of input arg */
	declare arg_ptr		 ptr;		/* points to input argument */
	declare args_finished	 bit (1);		/* on => all args seen, or error */
	declare caller_name		 char (32) init ("unpopulate_mrds_db") int static
				 options (constant);/* name of calling routine */
	declare cleanup		 condition;	/* signaled upon quit/release */
	declare any_other		 condition;
	declare com_err_		 entry options (variable); /* reports errors */
	declare command_query_	 entry options (variable); /* quieries caller */
	declare cu_$af_arg_count	 entry (fixed bin, fixed bin (35)); /* gets arg count/call type */
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
						/* gets Nth arg */
	declare data_model_ptr	 ptr;		/* pointer to data model */
	declare db_open		 bit (1);		/* on => database is open */
	declare db_path		 char (168);	/* database absolute path */
	declare dbi		 fixed bin (35);	/* database opening index */
	declare discard		 fixed bin (35);	/* ignored error code */
	declare error_code		 fixed bin (35);	/* error status encoding */
	declare error_table_$bad_arg	 fixed bin (35) ext;/* null input arg */
	declare error_table_$badopt	 fixed bin (35) ext;/* unknown control arg */
	declare error_table_$insufficient_access fixed bin (35) ext;
						/* user not DBA */
	declare error_table_$noarg	 fixed bin (35) ext;/* missing argument */
	declare error_table_$not_act_fnc fixed bin (35) ext; /* should get this normally */
	declare error_table_$wrong_no_of_args fixed bin (35) ext; /* not minimum of 1 arg */
	declare force_control	 bit (1);		/* on => dont query user  */
	declare get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
						/* gets temp segs */
	declare command_query_info_ptr ptr;		/* points to query info */
	declare ioa_		 entry options (variable); /* does output display */
	declare mode		 fixed bin init (2);/* for model info retrieval */
	declare mrds_dm_authorization$get_user_class
				 entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
						/* detects DBA */
	declare mrds_dm_close	 entry (ptr, fixed bin (35)); /* closes data model */
	declare mrds_dm_get_relations	 entry (ptr, ptr, ptr, fixed bin (35));
						/* gets rel names */
	declare mrds_dm_open	 entry (char (168), fixed bin, ptr, fixed bin (35));
						/* opens model */
	declare mrds_dsl_close	 entry options (variable); /* closes databases */
	declare mrds_dsl_delete	 entry options (variable); /* delete mrds db tuples */
	declare mrds_dsl_get_version$get_path_info
				 entry (char (*), ptr, fixed bin, ptr, fixed bin (35));
	declare mrds_dsl_open	 entry options (variable); /* opens a database through model or submodel */
	declare mrds_error_$duplicate_opt fixed bin (35) ext; /* path arg given > 1 time */
	declare mrds_error_$no_recursion fixed bin (35) ext; /* recursion not allowed */
	declare mrds_error_$tuple_not_found fixed bin (35) ext; /* not tuples in rel */
	declare nargs		 fixed bin;	/* number of arguments presented */
	declare path_seen		 bit (1);		/* on => path name argument given */
	declare recursive_call	 bit (1) int static init ("0"b); /* on => attempt to use recursion */
	declare rel_name		 char (32);	/* current relation */
	declare rel_num		 fixed bin;	/* relation loop index */
	declare release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
						/* gets rid of temp segs */
	declare sub_error_		 condition;	/* from dsl_ entries for added info */
	declare sys_info$max_seg_size	 fixed bin (35) ext;/* largest segment */
	declare work_area		 area (sys_info$max_seg_size) based (area_ptr);
						/* space for temp storage */
	declare (addr, empty, null, substr, rtrim, fixed, rel) builtin;

%include mdbm_db_model;
%page;
%include mrds_model_relations;
%page;
%include query_info;
%page;
%include mrds_opening_modes_;
%page;
%include mrds_path_info;
%page;
%include mrds_authorization;

     end;

*/
                                          -----------------------------------------------------------


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

*/
