<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">



		    adjust_bit_count.pl1            10/25/83  1546.8r w 10/25/83  1444.5       52713



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


adjust_bit_count: abc: proc;

	/* This command sets the bit counts of segments to the last
	   bit of the last non-zero word or character */

/* Written 3/4/76 by Steve Herbst */
/* Fixed to complain about directories 05/15/79 S. Herbst */

dcl 1 paths (arg_count) based(paths_ptr),		/* ptrs and lengths of pathname args */
     2 path_ptr ptr,
     2 path_len fixed bin;

dcl 1 entries (ecount) aligned based(entries_ptr),	/* entry info from hcs_$star_ */
     2 etype fixed bin(1) unaligned,
     2 nnames fixed bin(15) unaligned,
     2 nindex fixed bin unaligned;

dcl LINK_TYPE fixed bin int static options(constant) init(0);

dcl names (99) char(32) aligned based(names_ptr);		/* entry names from hcs_$star_ */

dcl area area based(area_ptr);

dcl arg char(arg_len) based(arg_ptr);
dcl dn char(168);
dcl (en, star_name) char(32);

dcl (character, chase_sw, long, match, stars) bit(1) aligned;

dcl (area_ptr, arg_ptr, entries_ptr, names_ptr, paths_ptr) ptr;

dcl (arg_count, arg_len, ecount, i, j, path_count) fixed bin;
dcl (bit_count, old_bit_count) fixed bin(24);
dcl code fixed bin(35);

dcl error_table_$badopt fixed bin(35) ext;
dcl error_table_$badstar fixed bin(35) ext;
dcl error_table_$dirseg fixed bin(35) ext;
dcl error_table_$nomatch fixed bin(35) ext;

dcl adjust_bit_count_ entry(char(*),char(*),bit(1)aligned,fixed bin(24),fixed bin(35));
dcl check_star_name_$entry entry(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));
dcl expand_path_ entry(ptr,fixed bin,ptr,ptr,fixed bin(35));
dcl get_system_free_area_ entry returns(ptr);
dcl hcs_$get_link_target entry(char(*),char(*),char(*),char(*),fixed bin(35));
dcl hcs_$star_ entry(char(*),char(*),fixed bin(2),ptr,fixed bin,ptr,ptr,fixed bin(35));
dcl hcs_$status_minf entry(char(*),char(*),fixed bin(1),fixed bin(2),fixed bin(24),fixed bin(35));
dcl ioa_ entry options(variable);

dcl (addr, null, substr) builtin;

dcl cleanup condition;
/**/
	call cu_$arg_count(arg_count);
	if arg_count=0 then do;
  NO_PATH:     call com_err_(0,"","Usage is:  adjust_bit_count paths -control_args-");
	     return;
	end;

	entries_ptr, names_ptr, paths_ptr = null;
	on condition(cleanup) call clean_up;

	area_ptr = get_system_free_area_();
	allocate paths in(area) set(paths_ptr);
	path_count = 0;

	character, chase_sw, long = "0"b;

	do i = 1 to arg_count;
	     call cu_$arg_ptr(i,arg_ptr,arg_len,code);
	     if substr(arg,1,1)="-" then
		if arg="-character" | arg="-ch" then character = "1"b;
		else if arg="-long" | arg="-lg" then long = "1"b;
		else if arg="-chase" then chase_sw = "1"b;
		else if arg="-no_chase" then chase_sw = "0"b;
		else do;
		     call com_err_(error_table_$badopt,"adjust_bit_count","^a",arg);
		     free paths in(area);
		     return;
		end;
	     else do;				/* pathname argument */
		path_count = path_count+1;
		path_ptr(path_count) = arg_ptr;
		path_len(path_count) = arg_len;
	     end;
	end;

	if path_count=0 then do;
	     free paths in(area);
	     go to NO_PATH;
	end;
/**/
	do i = 1 to path_count;

	     call expand_path_(path_ptr(i),path_len(i),addr(dn),addr(en),code);
	     if code^=0 then do;
		arg_ptr = path_ptr(i);
		arg_len = path_len(i);
		call com_err_(code,"adjust_bit_count","^a",arg);
		go to NEXT_PATH;
	     end;

	     call check_star_name_$entry(en,code);
	     if code=0 then do;
		stars = "0"b;
		ecount = 1;
	     end;
	     else if code=error_table_$badstar then do;
		call com_err_(code,"adjust_bit_count","^a",en);
		go to NEXT_PATH;
	     end;
	     else do;
		stars = "1"b;
		star_name = en;
		call hcs_$star_(dn,en,3,area_ptr,ecount,entries_ptr,names_ptr,code);
		if code^=0 then do;
		     call com_err_(code,"adjust_bit_count","^a&gt;^a",dn,en);
		     go to NEXT_PATH;
		end;
	     end;

	     match = "0"b;

	     do j = 1 to ecount;			/* for each starname match */

		if stars then do;
		     en = names(nindex(j));
		     if etype(j)=LINK_TYPE then
			if chase_sw then do;
			     call hcs_$get_link_target(dn,en,dn,en,code);
			     if code^=0 then go to NEXT_MATCH;
			end;
			else go to NEXT_MATCH;
		end;

		if long then do;
		     call hcs_$status_minf(dn,en,1,(0),old_bit_count,code);
		     bit_count = old_bit_count;
		end;

		call adjust_bit_count_(dn,en,character,bit_count,code);

		if code = error_table_$dirseg then do;
		     if ^stars then call com_err_ (code, "adjust_bit_count",
			"^a^[&gt;^]^a", dn, dn ^= "&gt;", en);
		end;
		else do;

		     match = "1"b;

		     if code ^= 0 then
			if bit_count=-1 then call com_err_(code,"adjust_bit_count","^a&gt;^a",dn,en);
			else call com_err_(code,"adjust_bit_count",
				"^a&gt;^a^/^-Computed bit count = ^d",dn,en,bit_count);

		     else if long &amp; bit_count^=old_bit_count then
			call ioa_("Bit count of ^a&gt;^a changed from ^d to ^d",
				dn,en,old_bit_count,bit_count);
		end;
NEXT_MATCH:    end;

	     if stars then do;

		if ^match then call com_err_ (error_table_$nomatch, "adjust_bit_count",
		     "^a^[&gt;^]^a", dn, dn ^= "&gt;", star_name);

		free entries in(area);
		free names in(area);
	     end;

  NEXT_PATH: end;

	call clean_up;
	return;

clean_up: proc;

	if paths_ptr^=null then free paths in(area);
	if entries_ptr^=null then free entries in(area);
	if names_ptr^=null then free names in(area);

end clean_up;

end adjust_bit_count;
���



		    adjust_bit_count_.pl1           07/26/84  1221.5rew 07/26/84  1137.3       55746



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


adjust_bit_count_: proc (dn, en, ascii, a_bit_count, a_code);

/* Subroutine that does adjusting on individual files.


   Prepared for installation by C Garman, July 1971

   */

/* re-modified to work on MSF's by Steve Herbst 12/15/74 */
/* fixed by M. Asherman 9/2/76 to return a bit_count for msf's */
/* Modified 06/08/82 by Jim Lippard to not require aligned dname
   and ename, and to compile without error */
/* Modified 08/02/83 by Jim Lippard to properly handle MSFs */
/* Modified 04/09/84 by Jim Lippard to return proper error code on MSF
   to which caller has no access */

/* DECLARATIONS */
dcl sum_prev_bcs fixed(35);				/* sum of bit counts of MSF components */


/* fixed bin */

dcl (current_block,
     i,
     j,
     k init (0),
     components,
     ldn
     ) fixed bin (17);

dcl  block_offset fixed bin (18);

dcl a_bit_count fixed(35);
dcl (bc,bit_count) fixed(24);

dcl (a_code,
     code,
     error_table_$dirseg ext,
     error_table_$noentry ext,
     error_table_$segknown ext) fixed bin (35);


/* bit */

dcl  ascii bit (1) aligned;
dcl  msf bit (1) aligned;


/* character */

dcl (en, enc) char (32);				/* entry name */

dcl (dn, dnc) char (168);				/* directory name */


/* pointer */

dcl (blockp,
     compp init (null),
     eptr,
     fcbp init (null),
     segp,
     wordp) ptr;


/* builtin */

dcl (addr, addrel, fixed, max, null) builtin;


/* structures and based declarations */

declare 1 br aligned,				/* status branch */
        (2 (type bit (2), nnames bit (16), nrp bit (18)),
        2 dtm bit (36),
        2 dtu bit (36),
        2 (mode bit (5), pad1 bit (13), records bit (18)),
        2 dtd bit (36),
        2 dtem bit (36),
        2 acct bit (36),
        2 (curlen bit (12), bitcnt bit (24)),
        2 (did bit (4), imdid bit (4),
         copysw bit (1), pad3 bit (9),
         rbs (0:2) bit (6)),
        2 uid bit (36)) unaligned;

dcl  word_mask (0:1023) fixed bin based (blockp);

declare 1 char_mask aligned based (wordp),
        2 char (1:4) bit (9) unaligned;


/* external entries */

dcl  hcs_$fs_get_path_name  entry (ptr, char(*), fixed bin, char(*), fixed bin(35));
dcl  hcs_$initiate  entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35));
dcl  hcs_$set_bc entry (char(*), char(*), fixed bin(24), fixed bin(35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin(35));
dcl  msf_manager_$adjust entry (ptr, fixed bin, fixed bin(24), bit(3), fixed bin(35));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));
dcl  msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35));
/* 
   adjust_bit_count_:  proc (dn, en, ascii, a_bit_count, a_code); */

	bit_count = -1;
	msf = "0"b;
	sum_prev_bcs=0;

	eptr = addr (br);
	call hcs_$status_long (dn, en, 1, eptr, null, code); /* Get length and type of segment */
	if code ^= 0
	then go to FIN;

	if br.type = "10"b then 
	     if br.bitcnt = "0"b then do;
		code = error_table_$dirseg;
		go to FIN;
	     end;
	     else do;
		msf = "1"b;
		call msf_manager_$open (dn, en, fcbp, code);
		if code ^= 0 then go to FIN;
		components = -1;
		bc=0;

  msf_loop:	components = components + 1;
		sum_prev_bcs=sum_prev_bcs+bc;
		segp = compp;
		call msf_manager_$get_ptr (fcbp, components, "0"b, compp, bc, code);
		if code = 0 | code = error_table_$segknown then go to msf_loop;
		else if code ^= error_table_$noentry then do;
		     sum_prev_bcs = 0;
		     go to FIN;
		end;
		call hcs_$fs_get_path_name (segp, dnc, ldn, enc, code);
		if code ^= 0 then go to FIN;
		call hcs_$status_long (dnc, enc, 1, eptr, null, code);
		if code ^= 0 then go to FIN;
	     end;

	else call hcs_$initiate (dn, en, "", 0, 1, segp, code); /* Get pointer to segment */

	if segp = null
	then go to FIN;				/* this is the only non-zero code that worries us */

  last:	code = 0;

	current_block = fixed (br.curlen, 12) -1;	/* get current block number */
	if current_block &gt;= 0			/* If non-zero current length */
	then do i = current_block to 0 by -1 while (bit_count &lt; 0);

	     block_offset = i * 1024;			/* Compute start of current block */
	     blockp = addrel (segp, block_offset);

	     do j = 1023 by -1 to 0 while
		(blockp -&gt; word_mask (j) = 0);	/* Search current block for non-zero word */
	     end;

	     if j &gt;= 0				/* (Should always be, but ...) */
	     then do;

		if ascii				/* If character adjustment wanted, test last word */
		then do;

		     wordp = addr (blockp -&gt; word_mask (j)); /* Get pointer to last word */

		     do k = 4 by -1 to 1 while (wordp -&gt; char_mask.char (k) = (9)"0"b);
						/* Now test characters */
		     end;

		end;

		else				/* no character adjustment wanted */
		j = j + 1;			/* include full last non-zero word */

	     end;

	     if j &gt;= 0				/* a non-zero length block was found */
	     then bit_count = (((block_offset + j) * 4) + k) * 9; /* inner expression is multiplied by 36 */

	end;

	bit_count = max (bit_count, 0);

	if msf then do;
	     call msf_manager_$adjust (fcbp, components-1, bit_count, "110"b, code);
	     if code ^= 0 then go to FIN;
	     if components&gt;1 then call hcs_$set_bc (dn, en, (components), code);
	     if code ^= 0 then go to FIN;
	end;
	call hcs_$set_bc_seg(segp,bit_count,code);
	if code ^= 0 then go to FIN;

	if msf then call msf_manager_$close (fcbp);
	else call hcs_$terminate_noname (segp, (0));

FIN:	
	a_bit_count = bit_count+sum_prev_bcs;

	a_code = code;				/* Return the last error code */

     end adjust_bit_count_;
��



		    check_file_system_damage.pl1    09/15/88  1344.6rew 09/15/88  1341.0      183537



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(85-09-05,Spitzer), approve(85-09-05,MCR7269),
     audit(85-09-18,Blair), install(85-12-16,MR12.0-1001):
     1) Fix CA detection code.  2) Add -pn CA.
  2) change(88-08-25,TLNguyen), approve(88-08-25,MCR7962),
     audit(88-09-14,Parisek), install(88-09-15,MR12.2-1110):
     Remove the check_superior_dirs internal procedure because users don't
     generally have a status access mode on their superior directories and
     this procedure goes beyond what this program is documented or
     supposed to do.
                                                   END HISTORY COMMENTS */

check_file_system_damage:
cfsd:
     proc;

/* ***********************************************************************
   *   Command for finding damaged segments and connection failures.     *
   *   This program is useful after a system crash to check the state    *
   *   of the libraries and system control directories                   *
   *                                                                     *
   *   Coded July 1980 by Jim Homan, with thanks to Warren Johnson for   *
   *   his check_dsw command.                                            *
   *   Bug fixes installed August 1980 by Warren Johnson.                *
   *********************************************************************** */

/* Modified 3/8/84 by C Spitzer. modify for installation per MCRB amendments */
/* Modified 1/6/85 by Keith Loepere to understand "new" error code from hcs_$star_. */

/* ****************************************************************************
   *                                                                          *
   * Usage:                                                                   *
   *                                                                          *
   * check_file_system_damage path {-control_args}                            *
   *                                                                          *
   * path          is a pathname specifying what is to be checked.  It        *
   *               may be a starname, and -wd is accepted.                    *
   *                                                                          *
   * control_args  may be any of the following:                               *
   *                                                                          *
   * -pathname,    specifies that the next argument is to be used as a        *
   * -pn	         pathname rather than as a control argument.	        *
   *							        *
   * -subtree,     if this control argument is specified, then path must      *
   *    -subt      be a directory.  All segments in the specified directory   *
   *               and all directories below the specified directory are      *
   *               checked.                                                   *
   *                                                                          *
   * -multisegment_file,                                                      *
   * -msf          if this control argument is specified, then the components *
   *               of MSFs are checked.  This is the default.	        *
   *							        *
   * -no_multisegment_file,					        *
   * -no_msf,      turns off checking of MSF.			        *
   *                                                                          *
   * -brief, bf    if this control argument is specified, then error          *
   *               messages about incorrect access to directories and no star *
   *               name matches are suppressed.                               *
   *                                                                          *
   * -call STR     STR is a command to be executed for each segment which     *
   *               is damaged.  For each damaged segment, the command         *
   *               executed is "STR path damaged".  For each connection       *
   *               failure, the executed is "STR path connection_failure".    *
   *               The default action, when -call is not specified, is to     *
   *               print out an error message for each damaged segment and    *
   *               each connection failure.                                   *
   **************************************************************************** */
%page;
/* external entries */

dcl  active_fnc_err_ entry options (variable);
dcl  check_star_name_$entry entry (char (*), fixed (35));
dcl  com_err_ entry options (variable);
dcl  cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35));
dcl  cu_$arg_count entry returns (fixed);
dcl  cu_$arg_ptr entry (fixed, ptr, fixed, fixed (35));
dcl  cu_$cp entry (ptr, fixed, fixed (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  get_wdir_ entry () returns (char (168));
dcl  hcs_$star_ entry (char (*), char (*), fixed (2), ptr, fixed, ptr, ptr, fixed (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed (1), ptr, ptr, fixed (35));
dcl  ioa_ entry options (variable);
dcl  pathname_ entry (char (*), char (*)) returns (char (168));

/* external static */

dcl  error_table_$bad_arg fixed (35) bin external static;
dcl  error_table_$badopt fixed (35) bin external static;
dcl  error_table_$inconsistent fixed (35) bin external static;
dcl  error_table_$logical_volume_not_defined fixed (35) bin external static;
dcl  error_table_$moderr fixed (35) bin external static;
dcl  error_table_$noarg fixed (35) bin external static;
dcl  error_table_$nomatch fixed (35) bin external static;
dcl  error_table_$too_many_args fixed (35) bin external static;
dcl  error_table_$vtoce_connection_fail fixed (35) bin external static;

/* internal static */

dcl  ME char (32) int static options (constant) init ("check_file_system_damage");

/* automatic */

dcl  area_ptr ptr;					/* pointer to area used for hcs_$star allocations */
dcl  argN fixed;					/* number of argument being processed */
dcl  arglen fixed;					/* length of any command argument */
dcl  argptr ptr;					/* pointer to any command argument */
dcl  brief_switch bit (1) aligned;			/* on if -brief specified */
dcl  call_switch bit (1) aligned;			/* on if -call specified */
dcl  code fixed (35);				/* error code returned by Multics subroutines */
dcl  command_line_length fixed init (0);		/* length of command line argument */
dcl  command_line_ptr ptr;				/* pointer to command line argument */
dcl  dname char (168);				/* directory portion of pathname given as argument */
dcl  ename char (32);				/* entryname portion of pathname given as argument */
dcl  max_depth fixed bin;				/* number of dirs allowed to go down. default is 99999 */
dcl  msf_switch bit (1) aligned;			/* on if -msf specified */
dcl  nargs fixed;					/* number of arguments given to the command */
dcl  star_switch bit (1) aligned;			/* on if pathname arg is a starname */
dcl  subroutine bit (1) aligned;			/* on if entry thru subroutine interface */
dcl  subtree_switch bit (1) aligned;			/* on if -subtree specified */

/* based */

dcl  arg char (arglen) based (argptr);			/* any command argument */
dcl  command_line char (command_line_length) based (command_line_ptr);
						/* argument after -call */

/* conditions */

dcl  cleanup condition;

/* builtins */

dcl  (addr, index, length, null, rtrim, substr, sum) builtin;
%page;
%include branch_status;
%page;
	star_switch, subtree_switch, brief_switch, call_switch, subroutine = "0"b;
	msf_switch = "1"b;
	max_depth = 99999;

	call cant_be_active_function ();
	call check_number_of_args (1, 0, "check_file_system_damage path {-ctl_args}", nargs);
	dname = "";
	argN = 1;

	do while (argN &lt;= nargs);
	     call cu_$arg_ptr (argN, argptr, arglen, code);
	     if /* case */ code ^= 0
	     then do;
		call com_err_ (code, ME, "^/Error getting argument ^d.", argN);
		return;
		end;
	     else if index (arg, "-") ^= 1
		then if dname = ""
		     then call get_starname_arg (arg, dname, ename, star_switch);
		     else do;
MULTIPLE_PATHS:		call com_err_ (0, ME, "Multiple pathnames given. ^a", arg);
			goto EXIT;
			end;
	     else if arg = "-pn" | arg = "-pathname"
		then if dname = ""
		     then do;
			argN = argN + 1;
			call get_required_arg (argN, "After -pathname.", argptr, arglen);
			call expand_pathname_ (arg, dname, ename, code);
			if code ^= 0
			then do;
			     call com_err_ (code, ME, "^a", arg);
			     return;
			     end;
			end;
		     else goto MULTIPLE_PATHS;
	     else if arg = "-wd" | arg = "-working_dir"
		then if dname = ""
		     then call expand_pathname_ (get_wdir_ (), dname, ename, (0));
		     else goto MULTIPLE_PATHS;
	     else if arg = "-subtree" | arg = "-subt"
		then subtree_switch = "1"b;
		else if arg = "-brief" | arg = "-bf"
		     then brief_switch = "1"b;
		     else if arg = "-msf" | arg = "-multisegment_file"
			then msf_switch = "1"b;
			else if arg = "-no_msf" | arg = "-no_multisegment_file"
			     then msf_switch = "0"b;
			     else if arg = "-dh" | arg = "-depth"
				then do;
				     argN = argN + 1;
				     call get_required_arg (argN, "After -depth.", argptr, arglen);
				     max_depth = cv_dec_check_ (arg, code);
				     if code ^= 0
				     then do;
					call com_err_ (0, ME, "Non-numeric after -depth. ^a", arg);
					return;
					end;
				     subtree_switch = "1"b;
				     end;
				else if arg = "-call"
				     then do;
					call_switch = "1"b;
					argN = argN + 1;
					call get_required_arg (argN, "After -call.", command_line_ptr,
					     command_line_length);
					end;
				     else do;	/* Error, unrecognized argument */
					if arglen &gt; 0
					then if substr (arg, 1, 1) = "-"
					     then call com_err_ (error_table_$badopt, ME, arg);
					     else call com_err_ (error_table_$bad_arg, ME, arg);
					else ;
					return;
					end;
	     argN = argN + 1;
	     end;

	if dname = "" 
	then do;
	     call com_err_ (error_table_$noarg, ME, "^/Usage: ^a path {-control_args}", ME);
	     goto EXIT;
	     end;

	if subtree_switch &amp; star_switch
	then do;
	     call com_err_ (error_table_$inconsistent, ME,
		"Pathname may not be a starname if -^[subtree^;depth^] option is used. ^a", (max_depth = 99999),
		pathname_ (dname, ename));
	     go to EXIT;
	     end;
	else ;

	area_ptr = get_system_free_area_ ();

	if subtree_switch
	then call survey_the_damage (pathname_ (dname, ename), "**", 1);
	else if star_switch
	     then call survey_the_damage (dname, ename, 1);
	     else call check_entry (dname, ename, 1);

EXIT:						/* all internal procs may go to here to after reporting errors */
	return;
%page;
check_file_system_damage_:
     entry (Pdir, Pname, Pcode) returns (bit (36) aligned);

dcl  Pdir char (*) parameter;				/* directory name (input) */
dcl  Pname char (*) parameter;			/* entry name (input)*/
dcl  Pcode fixed bin (35) parameter;			/* error code (output) */

dcl  return_bits bit (36) aligned;
dcl  1 return_bits_based aligned based (addr (return_bits)),
       2 damage bit (1) unaligned,			/* ON = any damage */
       2 damaged_switch bit (1) unaligned,		/* ON = damaged entry */
       2 connection_failure bit (1) unaligned,		/* ON = connectin failure on entry */
       2 unused bit (33) unaligned;			/* future expansion */

	return_bits = "0"b;
	Pcode, code = 0;

	subroutine = "1"b;
	call_switch, msf_switch = "0"b;
	max_depth = 0;

	command_line_length = 0;
	call check_entry (Pdir, Pname, 0);
	if code ^= 0
	then do;
	     Pcode = code;
	     return_bits = "0"b;
	     end;
	else if return_bits ^= "0"b
	     then return_bits_based.damage = "1"b;

	return (return_bits);
%page;
/* **********************************************************************
   *  Internal procedure to check all entries in a directory that match *
   *  a starname.                                                       *
   ********************************************************************** */

survey_the_damage:
     proc (dir, et, depth) recursive;

dcl  dir char (*) parameter;				/* Input-directory name */
dcl  et char (*) parameter;				/* Input-starname */
dcl  depth fixed bin parameter;			/* Input-number of dirs downwards we are */

dcl  ec fixed (35);					/* error code */
dcl  i fixed;					/* loop index */
%page;
%include star_structures;
%page;
	if depth &gt; max_depth
	then return;

	star_entry_ptr, star_names_ptr = null ();

	on cleanup /* CLEANUP HANDLER */
	     begin;
		if star_names_ptr ^= null ()
		then free star_names;
		else ;
		if star_entry_ptr ^= null ()
		then free star_entries;
		else ;
		end;

	call hcs_$star_ (dir, et, star_BRANCHES_ONLY, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, ec);

	if ec ^= 0
	then if (ec = error_table_$moderr | ec = error_table_$nomatch
		| ec = error_table_$logical_volume_not_defined) &amp; brief_switch
	     then ;
	     else call com_err_ (ec, ME, "^a", pathname_ (dir, et));
	else do i = 1 to star_entry_count by 1;
		call check_entry (dir, star_names (star_entries (i).nindex), depth);
		end;
CLEANUP:
	if star_names_ptr ^= null ()
	then free star_names;
	else ;
	if star_entry_ptr ^= null ()
	then free star_entries;
	else ;
	return;

     end survey_the_damage;
%page;
/* **********************************************************************
   *   Internal procedure to check an individual branch for damage.     *
   *   This procedure recalls survey_damage as needed to handle         *
   *   subtrees and MSFs.                                               *
   ********************************************************************** */

check_entry:
     proc (d, e, depth);

dcl  d char (*) parameter;				/* Input-directory portion of pathname */
dcl  e char (*) parameter;				/* Input-entryname */
dcl  depth fixed bin parameter;			/* Input-number of dirs downward we are */

dcl  ec fixed (35);					/* error code */
dcl  command char (command_line_length + 188);		/* long enough for command line plus pathname plus */
						/* "connection_failure" plus spaces */

	call hcs_$status_long (d, e, 0, addr (branch_status), null (), ec);
	if ec = error_table_$vtoce_connection_fail
	then if call_switch
	     then do;
		command = command_line || " " || rtrim (pathname_ (d, e)) || " connection_failure";
		call cu_$cp (addr (command), length (command), (0));
		end;
	     else if subroutine
		then return_bits_based.connection_failure = "1"b;
		else call ioa_ ("Connection failure: ^a", pathname_ (d, e));
	else if ec ^= 0
	     then if subroutine
		then do;
		     code = ec;
		     return;
		     end;
		else call com_err_ (ec, ME, "^a", pathname_ (d, e));
	     else if branch_status.damaged_switch
		then if call_switch
		     then do;

			command = command_line || " " || rtrim (pathname_ (d, e)) || " damaged";
			call cu_$cp (addr (command), length (command), (0));
			end;
		     else if subroutine
			then return_bits_based.damaged_switch = "1"b;
			else call ioa_ ("Damage switch on: ^a", pathname_ (d, e));
		else if branch_status.type = directory_type
		     then if (msf_switch &amp; branch_status.bit_count ^= "0"b)
			     | (branch_status.bit_count = "0"b &amp; subtree_switch)
			then if depth &lt; max_depth
			     then call survey_the_damage (pathname_ (d, e), "**", depth + 1);
			     else ;		/* would make it too far down */
			else ;
		     else ;			/* not a directory */

	return;

     end check_entry;
%page;
/* ***********************************************************************
   *  Internal procedure to check to see if command was called as active *
   *  function, and to report an error if it was.                        *
   *********************************************************************** */

cant_be_active_function:
     proc;

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

	call cu_$af_return_arg ((0), null (), (0), ec);	/* call with dummy args, we just want the error code */
	if ec = 0
	then do;
	     call active_fnc_err_ (0, ME, "This command cannot be called as an active function.");
	     go to EXIT;
	     end;
	else return;

     end cant_be_active_function;
%page;
/* **********************************************************************
   *  Internal procedure to determine the number of arguments passed to *
   *  the command and ensure that the minimum and maximum number of     *
   *  arguments for the command are not abused.                         *
   ********************************************************************** */

check_number_of_args:
     proc (min_args, max_args, usage, nargs);

/* parameters */

dcl  min_args fixed parameter;			/* Input-Minimum number of arguments needed by this command */
dcl  max_args fixed parameter;			/* Input-Maximum number of arguments acceptable
						   to this command.  (0 means no maximum) */
dcl  usage char (*) parameter;			/* Input-Usage description for this command */
dcl  nargs fixed parameter;				/* Output-Actual number of arguments given to command */

	nargs = cu_$arg_count ();

	if nargs &lt; min_args				/* not enough arguments, tell user what to do */
	then call com_err_ (error_table_$noarg, ME, "^/^-Usage: ^a", usage);
	else if nargs &gt; max_args &amp; max_args ^= 0	/* too many arguments, tell user what to do */
	     then call com_err_ (error_table_$too_many_args, ME, "^/^-Usage: ^a", usage);
	     else return;
	go to EXIT;

     end check_number_of_args;
%page;
/* **********************************************************************
   *  This internal procedure is used to get pointer and length for a   *
   *  required argument.                                                *
   ********************************************************************** */

get_required_arg:
     proc (n, error_comment, ap, al);

dcl  n fixed parameter;				/* Input-number of the argument we want to get */
dcl  error_comment char (*) parameter;			/* Input-comment to print with any error messages */
dcl  ap ptr parameter;				/* Output-pointer to argument */
dcl  al fixed parameter;				/* Output-length of argument */

dcl  arg char (al) based (ap);			/* the argument itself */
dcl  ec fixed (35);					/* error code */

	call cu_$arg_ptr (n, ap, al, ec);
	if ec = 0
	then if al &gt; 0				/* check to make sure it's not another control arg */
	     then if substr (arg, 1, 1) = "-"
		then do;
		     ec = error_table_$noarg;
		     call com_err_ (ec, ME, error_comment);
		     go to EXIT;
		     end;
		else ;
	     else ;
	else do;
	     call com_err_ (ec, ME, error_comment);
	     go to EXIT;
	     end;
	return;

     end get_required_arg;
%page;
/* **********************************************************************
   *  Internal procedure to get a pathname,  which may be a starname.   *
   *  -wd or -working_dir is accepted as meaning the working directory. *
   ********************************************************************** */

get_starname_arg:
     proc (arg, dir, et, is_star);

dcl  arg char (*) parameter;				/* Input-path of the directory to usage (may be a starname) */
dcl  dir char (*) parameter;				/* Output-directory portion of pathname */
dcl  et char (*) parameter;				/* Output-entryname portion (starname) of pathname */
dcl  is_star bit (1) aligned parameter;			/* Output-"1"b if   entryname is a starname */

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

	call expand_pathname_ (arg, dir, et, ec);
	if ec ^= 0
	then do;
	     call com_err_ (ec, ME, "^a", arg);
	     go to EXIT;
	     end;

	if dir = "&gt;" &amp; et = ""			/* special case the ROOT */
	then is_star = "0"b;
	else do;
	     call check_star_name_$entry (et, ec);
	     if ec &gt; 2
	     then do;				/* 1 and 2 have special meanings and do not indicate errors */
		call com_err_ (ec, ME, "^a", arg);
		go to EXIT;
		end;
	     else ;
	     if ec = 0
	     then is_star = "0"b;
	     else is_star = "1"b;
	     end;
	return;

     end get_starname_arg;

     end check_file_system_damage;

���



		    copy.pl1                        01/24/89  0858.0rew 01/24/89  0847.4      209439



/****^  **************************************************************
        *                                                            *
        * Copyright, (C) Honeywell Bull Inc., 1989                   *
        *                                                            *
        * Copyright, (C) Massachusetts Institute of Technology, 1983 *
        *                                                            *
        * Copyright, (C) Honeywell Information Systems Inc., 1983    *
        *                                                            *
        ************************************************************** */






/****^  HISTORY COMMENTS:
  1) change(87-02-13,TLNguyen), approve(87-02-13,MCR7619),
     audit(87-03-20,Gilcrease), install(87-03-24,MR12.1-1011):
     - Change "copy" to always display a correct error message when copying
       a specified extended entry types into unsuffixed targets.
     - Change "move" to always display a correct error message when moving
       a specified MSF that has unsufficient ACL requirements in order to move.
     - Change "copy" to always display a correct error message when copying
       a specified segment or star convention is applied and unsufficient
       ACL requirements for directory containing a specified segment.
  2) change(88-10-03,Flegel), approve(89-01-09,MCR8020), audit(89-01-16,Lee),
     install(89-01-24,MR12.3-1012):
     Change sub_err_handler display of an error so that the causing pathname is
     properly displayed with the error according to the
     copy_error_info.target_err_switch value.  This sort of backs out phx20384
     as the solution addressed the wrong source its problem.
                                                   END HISTORY COMMENTS */


/* format: style2,idind30,indcomtxt */
copy:
cp:
     procedure () options (variable);


/****
      This is the standard service system command to copy a segment or
      multi-segment file.  This procedure also includes the move command, which
      consists of a copy (with names and ACLs) followed by a delete.
      Both commands take multiple arguments and the star convention.
      Under control of optional arguments it will also copy extra names
      and/or the ACL of the segment.
*/

/* Coded 3 Aug 1969 David Clark */
/* Revised 25 Sept 1969 0935 DDC */
/* Modified by M Weaver 11 April 1970 */
/* Broken into four routines by John Strayhorn. July 1, 1970 */
/* Check for same directory, when copying names, added by T.Casey, Jan 1973 */
/* Modified June 4 1974 by Steve Herbst */

/* Rewritten: June 1979 by G. Palter, adding -chase in the process */
/* Bugs fixed, check for "copy foo" added 07/14/81 S. Herbst */
/* Changed move to move switches, max length, and ring brackets 11/17/82 S. Herbst */
/* Fixed to move MSF ring brackets correctly 12/15/82 S. Herbst */
/* Modified: 6/2/83 Jay Pattin moved it all to copy_ */
/* 831001 BIM infintessimally cleaned up for installation */
/* 841102 C Spitzer. fixed bug in sub_error_handler, getting null pointer fault if info_ptr not set */
/* 850206 MSharpe.  changed -force_no_type to -inase/-inaee; modified to advise
   user that no non-dirs matched the starname */

	dcl     argument		        character (argument_lth) based (argument_ptr);
	dcl     argument_lth	        fixed binary (21);
	dcl     argument_ptr	        pointer;

	dcl     system_area		        area based (system_area_ptr);

	dcl     system_area_ptr	        pointer;

	dcl     (argument_count, arg_idx)     fixed binary;
	dcl     arg_list_ptr	        pointer;

	dcl     NAME		        character (32);
						/* who I am */

	dcl     code		        fixed binary (35);

	dcl     chase_sw		        bit (2) aligned;
						/* either default or one of two given values */
	dcl     (brief, copy_command_sw, entry_only_sw, have_paths)
				        bit (1) aligned;
	dcl     (successful_copy,
	         inhibit_nomatch_error)       bit (1) aligned;

	dcl     (source_dir, target_dir)      character (168);
	dcl     (source_ename, target_eqname, ename)
				        character (32);
	dcl     source_stars	        fixed binary (35);
	dcl     source_type		        fixed binary (2);

	dcl     select_sw		        fixed binary (2);
	dcl     idx		        fixed binary;

	dcl     DEFAULT_2ND_NAME	        character (2) static options (constant) initial ("==");

	dcl     (
                  error_table_$argerr,
	        error_table_$badopt,
                  error_table_$badstar,
	        error_table_$dirseg,
	        error_table_$incorrect_access,
	        error_table_$moderr,
	        error_table_$namedup,
	        error_table_$noarg,
	        error_table_$noentry,
                  error_table_$no_info,
                  error_table_$not_seg_type,
	        error_table_$sameseg,
	        error_table_$inconsistent,
                  error_table_$root,
	        error_table_$unsupported_operation
	        )			        fixed binary (35) external;

	dcl     (cleanup, sub_error_)	        condition;

	dcl     (
	        com_err_,
	        com_err_$suppress_name
	        )			        entry () options (variable);
	dcl     check_star_name_$entry        entry (character (*), fixed binary (35));
	dcl     continue_to_signal_	        entry (fixed bin (35));
	dcl     copy_		        entry (ptr);
	dcl     cu_$arg_count	        entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_list_ptr	        entry () returns (pointer);
	dcl     cu_$arg_ptr		        entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
	dcl     cu_$arg_ptr_rel	        entry (fixed binary, pointer, fixed binary (21), fixed binary (35),
				        pointer);
	dcl     expand_pathname_	        entry (character (*), character (*), character (*), fixed binary (35));
	dcl     find_condition_info_	        entry (ptr, ptr, fixed bin (35));
	dcl     get_equal_name_	        entry (character (*), character (*), character (*), fixed binary (35));
	dcl     get_system_free_area_	        entry () returns (pointer);
	dcl     hcs_$star_		        entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
				        fixed bin (35));
	dcl     hcs_$status_minf	        entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				        fixed bin (35));
	dcl     pathname_		        entry (char (*), char (*)) returns (char (168));

	dcl     (addr, length, index, null, rtrim, search, string, substr, sum)
				        builtin;
%page;
%include star_structures;
%page;
%include copy_options;
%page;
%include copy_flags;

	dcl     1 cpo		        aligned like copy_options;
	dcl     1 explicit		        aligned like copy_flags;
%page;
%include sub_error_info;

%include condition_info_header;
%page;
%include condition_info;

%include copy_error_info;
%page;
/* copy: cp: entry () options (variable); */

	NAME = "copy";

	copy_command_sw = "1"b;
	string (cpo.copy_items) = ""b;		/* default options */

	go to COMMON;



/* This is the move command */

move:
mv:
     entry () options (variable);

	NAME = "move";

	copy_command_sw = "0"b;

	string (cpo.copy_items) = ""b;
	cpo.copy_items.acl, cpo.copy_items.names, cpo.copy_items.ring_brackets, cpo.copy_items.max_length,
	     cpo.copy_items.copy_switch, cpo.copy_items.safety_switch, cpo.copy_items.dumper_switches = "1"b;



/* Actual work starts here */

COMMON:
	chase_sw = "00"b;				/* none supplied */
	cpo.version = COPY_OPTIONS_VERSION_1;
	cpo.caller_name = NAME;

	cpo.copy_items.entry_bound = "1"b;		/* always copy */
	string (cpo.flags) = ""b;
	cpo.flags.delete = ^copy_command_sw;

	string (explicit) = ""b;

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

	if argument_count = 0
	then do;
USAGE:
		call com_err_ (error_table_$noarg, NAME, "^/^6xUsage: ^a path1 {equal_name1 ...} {-control_args}",
		     NAME);
		return;
	     end;


/* Scan for control arguments */

	have_paths = "0"b;				/* haven't found any yet */

	do arg_idx = 1 to argument_count;

	     call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, NAME, "Fetching argument #^d.", arg_idx);
		     return;
		end;

	     if substr (argument, 1, 1) ^= "-"
	     then have_paths = "1"b;			/* found some pathnames */

	     else if (argument = "-brief") | (argument = "-bf")
	     then brief = "1"b;

	     else if (argument = "-long") | (argument = "-lg")
	     then brief = "0"b;

	     else if (argument = "-all") | (argument = "-a")
	     then cpo.copy_items.acl, cpo.copy_items.names, cpo.copy_items.ring_brackets, cpo.copy_items.max_length,
		     cpo.copy_items.copy_switch, cpo.copy_items.safety_switch, cpo.copy_items.dumper_switches = "1"b;

	     else if (argument = "-acl")
	     then cpo.copy_items.acl, explicit.acl = "1"b;

	     else if (argument = "-no_acl")
	     then cpo.copy_items.acl, explicit.acl = "0"b;

	     else if (argument = "-name") | (argument = "-nm")
	     then cpo.copy_items.names, explicit.names = "1"b;

	     else if (argument = "-no_name") | (argument = "-nnm")
	     then cpo.copy_items.names, explicit.names = "0"b;

	     else if (argument = "-chase")
	     then chase_sw = "11"b;			/* explicit request to do chasing */

	     else if (argument = "-no_chase")
	     then chase_sw = "10"b;

	     else if argument = "-force" | argument = "-fc"
	     then cpo.flags.force = "1"b;

	     else if argument = "-no_force" | argument = "-nfc"
	     then cpo.flags.force = "0"b;

	     else if argument = "-max_length" | argument = "-ml"
	     then cpo.copy_items.max_length, explicit.max_length = "1"b;

	     else if argument = "-no_max_length" | argument = "-nml"
	     then cpo.copy_items.max_length, explicit.max_length = "0"b;

	     else if argument = "-ring_brackets" | argument = "-rb"
	     then cpo.copy_items.ring_brackets, explicit.ring_brackets = "1"b;

	     else if argument = "-no_ring_brackets" | argument = "-nrb"
	     then cpo.copy_items.ring_brackets, explicit.ring_brackets = "0"b;

	     else if argument = "-copy_switch" | argument = "-csw"
	     then cpo.copy_items.copy_switch, explicit.copy_switch = "1"b;

	     else if argument = "-no_copy_switch" | argument = "-ncsw"
	     then cpo.copy_items.copy_switch, explicit.copy_switch = "0"b;

	     else if argument = "-safety_switch" | argument = "-ssw"
	     then cpo.copy_items.safety_switch, explicit.safety_switch = "1"b;

	     else if argument = "-no_safety_switch" | argument = "-nssw"
	     then cpo.copy_items.safety_switch, explicit.safety_switch = "0"b;

	     else if argument = "-volume_dumper_switches" | argument = "-vdsw"
	     then cpo.copy_items.dumper_switches, explicit.dumper_switches = "1"b;

	     else if argument = "-no_volume_dumper_switches" | argument = "-nvdsw"
	     then cpo.copy_items.dumper_switches, explicit.dumper_switches = "0"b;

	     else if argument = "-entry_bound" | argument = "-eb"
	     then cpo.copy_items.entry_bound, explicit.entry_bound = "1"b;

	     else if argument = "-no_entry_bound" | argument = "-neb"
	     then cpo.copy_items.entry_bound, explicit.entry_bound = "0"b;

	     else if argument = "-extend"
	     then do;
		     cpo.copy_items.extend = "1"b;
		     cpo.copy_items.update = "0"b;
		end;

	     else if ^copy_command_sw
	     then goto BADOPT;

	     else if argument = "-replace" | argument = "-rp"
	     then cpo.copy_items.extend, cpo.copy_items.update = "0"b;

	     else if argument = "-update" | argument = "-ud"
	     then do;
		     cpo.copy_items.update = "1"b;
		     cpo.copy_items.extend = "0"b;
		end;

	     else if argument = "-interpret_as_standard_entry" | argument = "-inase"
	     then cpo.flags.raw = "1"b;

	     else if argument = "-interpret_as_extended_entry" | argument = "-inaee"
	     then cpo.flags.raw = "0"b;

	     else do;
BADOPT:
		     call com_err_ (error_table_$badopt, NAME, """^a""", argument);
		     return;
		end;
	end;

	if ^have_paths
	then /* nothing to work on */
	     go to USAGE;

	if (cpo.copy_items.extend | cpo.copy_items.update)
	     &amp; (cpo.copy_items.acl | cpo.copy_items.names | cpo.copy_items.ring_brackets | cpo.copy_items.max_length
	     | cpo.copy_items.copy_switch | cpo.copy_items.safety_switch | cpo.copy_items.dumper_switches)
	then do;
		call com_err_ (error_table_$inconsistent, NAME,
		     "Attributes may not be copied when -^[extend^;update^] is used.", cpo.copy_items.extend);
		return;
	     end;					/*						*/

	system_area_ptr = get_system_free_area_ ();

	star_entry_ptr,				/* so cleanup will work */
	     star_names_ptr = null ();

	on condition (cleanup) call clean_up ();


/* Process the pairs of pathnames supplied */

	arg_list_ptr = cu_$arg_list_ptr ();

	do arg_idx = 1 to argument_count;

	     call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, (0));
						/* known to work from above */

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

		     entry_only_sw = (search (argument, "&lt;&gt;") = 0);

		     call expand_pathname_ (argument, source_dir, source_ename, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, NAME, "^a", argument);
			     call find_second_arg ();
			     go to NEXT_PAIR;
			end;

		     call check_star_name_$entry (source_ename, source_stars);
		     if (source_stars ^= 0) &amp; (source_stars ^= 1) &amp; (source_stars ^= 2)
		     then do;
			     call com_err_ (source_stars, NAME, "^a", pathname_ (source_dir, source_ename));
			     call find_second_arg ();
			     go to NEXT_PAIR;
			end;

		     call find_second_arg ();		/* move on to second pair (if any) */

		     if arg_idx &gt; argument_count
		     then do;			/* none, use === */
			     if entry_only_sw
			     then do;
				     call com_err_ (0, NAME, "No target pathname specified.");
				     return;
				end;
			     argument_ptr = addr (DEFAULT_2ND_NAME);
			     argument_lth = length (DEFAULT_2ND_NAME);
			end;

		     call expand_pathname_ (argument, target_dir, target_eqname, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, NAME, "^a", argument);
			     go to NEXT_PAIR;
			end;

		     call check_star_name_$entry (target_eqname, code);
		     if code ^= 0
		     then do;
			     if code &gt; 2 then  /* code = error_table_$badstar  */
/* fix an incorrect error message, for example ! copy foo &gt;  */
				if argument = "&gt;" then do;
				      call com_err_ (error_table_$root, NAME,
                                                             "^a.  Your request has been aborted.", argument);
				      go to NEXT_PAIR;
				end;
/* end of bug fix */
			          else call com_err_ (code, NAME, "^a", pathname_ (target_dir, target_eqname));
			     else call com_err_ (0, NAME, "Star convention not allowed in second argument.  ^a",
				     pathname_ (target_dir, target_eqname));
			     go to NEXT_PAIR;
			end;


/* Preliminary checks OK for this pair; now do the work */

		     if source_stars = 0
		     then do;			/* source name is a single entry */
			     if chase_sw = "10"b
			     then do;		/* user doesn't want links chased */
				     call hcs_$status_minf (source_dir, source_ename, 0b, source_type, (0), code);
				     if code ^= 0
				     then do;
					     call com_err_ (code, NAME, "^a",
						pathname_ (source_dir, source_ename));
					     go to NEXT_PAIR;
					end;
				     if source_type = star_LINK
				     then do;
					     call com_err_ (0, NAME,
						"^a is a link and ""-no_chase"" was specified.",
						pathname_ (source_dir, source_ename));
					     go to NEXT_PAIR;
					end;
				end;

			     call process_entry (source_ename, "1"b, ("0"b));
						/* ignore the successful_copy bit */
			end;			/* do the work */


		     else do;			/* source name is a star name */
			     if chase_sw = "11"b
			     then select_sw = star_ALL_ENTRIES;
						/* request -chase */
			     else select_sw = star_BRANCHES_ONLY;

			     call hcs_$star_ (source_dir, source_ename, select_sw, system_area_ptr,
				star_entry_count, star_entry_ptr, star_names_ptr, code);
			     if code ^= 0 then
/* fix bug for TR number 19526 */
				if code = error_table_$moderr then do;
				     call com_err_ (error_table_$incorrect_access, NAME, "^a",
					          pathname_ (source_dir, source_ename));
				     go to NEXT_PAIR;
				end;
/* end of bug fix */
				else do;
				     call com_err_ (code, NAME, "^a", pathname_ (source_dir, source_ename));
				     go to NEXT_PAIR;
				end;

			     inhibit_nomatch_error,
			     successful_copy = "0"b;	/* If still OFF after the loop, there were no 
						   non-dirs that matched the starname */
			     do idx = 1 to star_entry_count;

				ename = star_names (star_entries (idx).nindex);
				call process_entry (ename, "0"b, successful_copy);
			     end;			/* ignore directories */
			     if ^successful_copy
				&amp; ^inhibit_nomatch_error
				then call com_err_ (0, NAME,
				     "No entries of appropriate type matched the starname ^a",
				     pathname_ (source_dir, source_ename));
			end;

NEXT_PAIR:
		     call clean_up ();		/* free up anything still around */
		end;				/* of non-control argument */
	end;

/**/

/* This internal procedure cleans up after an argument pair */

clean_up:
     procedure ();


	if star_names_ptr ^= null ()
	then do;
		free star_names in (system_area);
		star_names_ptr = null ();
	     end;

	if star_entry_ptr ^= null ()
	then do;
		free star_entries in (system_area);
		star_entry_ptr = null ();
	     end;

	return;

     end clean_up;					/*						*/
find_second_arg:
     procedure ();

/* This internal procedure scans the argument list looking for the second pathname
   of the current pair (if any) */

	do arg_idx = (arg_idx + 1) to argument_count;

	     call cu_$arg_ptr_rel (arg_idx, argument_ptr, argument_lth, (0), arg_list_ptr);

	     if substr (argument, 1, 1) ^= "-"
	     then /* found it */
		return;
	end;

	arg_idx = argument_count + 1;			/* none found */

	return;

     end find_second_arg;
%page;
process_entry:					/* copy one segment */
     procedure (P_ename, P_report_dirseg, P_successful_copy);

	dcl     P_ename		        character (32) parameter;
						/* source entry name */
	dcl     P_report_dirseg	        bit (1) aligned parameter;
						/* ON =&gt; e_t_$dirseg on source */

	dcl     P_successful_copy	        bit (1) aligned parameter;
						/* OUTPUT: ON =&gt; entry successfully copied */

          dcl     bit_count                     fixed binary (24); /* bit count returned by hcs_$status_minf. */
	dcl     (source_ename, target_ename)  character (32);
	dcl     code		        fixed binary (35);
          dcl     target_type                   fixed binary (2); /* type of a target entryname returned by hcs_$status_minf. */

	source_ename = P_ename;
	bit_count = -0;                                   /* initialized */
	target_type = -0;                                 /* initialized */

	call get_equal_name_ (source_ename, target_eqname, target_ename, code);
	if code ^= 0
	then do;
		call com_err_ (code, NAME, "^a for ^a", pathname_ (target_dir, target_eqname), source_ename);
		return;
	     end;

	cpo.source_dir = source_dir;
	cpo.source_name = source_ename;
	cpo.target_dir = target_dir;
	cpo.target_name = target_ename;

	on sub_error_ call sub_err_handler ();		/* copy_ reports erors with sub_err_ */

	call copy_ (addr (cpo));			/* go to it */
	P_successful_copy = "1"b;

COPY_LOST:
	return;
%page;
sub_err_handler:
     proc ();

	declare 1 ci		        aligned like condition_info;
          declare reverse                       builtin;
          declare suffix_name                   char (8) varying init ("");
          declare temp_source_ename             char (32) varying init ("");

	ci.version = condition_info_version_1;
	call find_condition_info_ (null (), addr (ci), (0));
	sub_error_info_ptr = ci.info_ptr;

	if sub_error_info.name ^= "copy_"
	then do;
CONTINUE_TO_SIGNAL:
	     call continue_to_signal_ ((0));
		goto END_HANDLER;
	     end;
	else if sub_error_info.info_ptr = null
	     then goto CONTINUE_TO_SIGNAL;
	else if copy_error_info.copy_options_ptr ^= addr (cpo)
	     then goto CONTINUE_TO_SIGNAL;

	code = sub_error_info.status_code;

	if sub_error_info.cant_restart
	then do;					/* copy failed */
		if ^copy_error_info.target_err_switch
		then if code = error_table_$dirseg
		     then /* source is a directory */
			if ^P_report_dirseg
			then /* but that's OK for starnames */
			     goto COPY_LOST;

		inhibit_nomatch_error = "1"b;		/* found an appropriate entry that matched the starname,
						   but still didn't get it copied -- 
						   Don't report a nomatch for this starname */

		if code ^= error_table_$namedup then /* already reported */
/* fix bug for TR number phx20617 */
		     if (code = error_table_$badstar) | (code = error_table_$argerr) then do;
			temp_source_ename = reverse (rtrim (source_ename));
			
                              suffix_name = substr (temp_source_ename, 1, (index (temp_source_ename, ".") - 1));
			suffix_name = reverse (suffix_name);
		          call com_err_ (error_table_$not_seg_type, NAME,  "The .^a suffix was missing from  ^a",
                                        suffix_name, pathname_ (target_dir, target_ename));
                         end;
/* fix bug for TR number phx19526 */
		     else if code = error_table_$no_info then
			 call com_err_ (error_table_$incorrect_access, NAME, sub_error_info.info_string);
/* end of bug fixes */
		     else call com_err_ (code, NAME, sub_error_info.info_string);
                    else;
		if ^copy_command_sw
		then if (code ^= error_table_$noentry) &amp; (code ^= error_table_$dirseg)
			&amp; (code ^= error_table_$moderr) &amp; (code ^= error_table_$sameseg)
			&amp; (code ^= error_table_$namedup)
		     then call com_err_$suppress_name (0, NAME, "Segment ^a not deleted.",
			     pathname_ (source_dir, source_ename));
		goto COPY_LOST;
	     end;					/* fatal error */

	else if sub_error_info.default_restart
	then if ^brief
	     then call com_err_ (code, NAME, sub_error_info.info_string);
	     else ;

	else do;
		if code = error_table_$unsupported_operation
		then if badop ()
		     then call com_err_ (0, NAME, sub_error_info.info_string);
		     else ;
/* fix an incorrect error message for TR number phx20384, this is backed out
 * with phx20481 as the original repair was incorrect */
		else do;
		     call com_err_ (code, NAME, sub_error_info.info_string);
		     goto COPY_LOST;
		end;
/* end of fixing */
	     end;
END_HANDLER:
	return;

     end sub_err_handler;
%page;
badop:						/* returns true iff operation specifically requested */
     proc returns (bit (1) aligned);

	declare op		        char (32);

	op = copy_error_info.operation;
	if op = "names"
	then return (explicit.names | ^copy_command_sw);
	if op = "ACL"
	then return (explicit.acl | ^copy_command_sw);
	if op = "ring brackets"
	then return (explicit.ring_brackets);
	if op = "max length"
	then return (explicit.max_length);
	if op = "copy switch"
	then return (explicit.copy_switch);
	if op = "safety switch"
	then return (explicit.safety_switch);
	if op = "dumper switches"
	then return (explicit.dumper_switches);
	if op = "entry bound"
	then return (explicit.entry_bound);

	return ("1"b);				/* if we don't recognize it, print it. */
     end badop;
     end process_entry;

     end copy;
�



		    copy_.pl1                       10/14/90  0932.7rew 10/14/90  0915.0      220482



/****^  **************************************************************
        *                                                            *
        * Copyright, (C) BULL HN Information Systems Inc., 1990      *
        *                                                            *
        * Copyright, (C) Honeywell Information Systems Inc., 1983    *
        *                                                            *
        * Copyright, (C) Massachusetts Institute of Technology, 1983 *
        *                                                            *
        ************************************************************** */





/****^  HISTORY COMMENTS:
  1) change(88-10-03,Flegel), approve(88-11-16,MCR8020), audit(89-01-16,Lee),
     install(89-01-24,MR12.3-1012):
     phx19616 - created procedure change_source_dir, see function header for
                info.
     phx20481 - repaired ioa_ control strings for calls to error and
                warning so that all 3 arguments are properly accounted for.
     phx21214 - reorder the copying of characteristics so that the ACL is
                copied last and the ring_brackets are second last.
  2) change(88-11-10,Flegel), approve(88-12-22,MCR8028), audit(89-01-16,Lee),
     install(89-01-24,MR12.3-1012):
     phx21056 / phx21147 - ignore error_table_$action_not_performed when
                setting max_length and allow suffix_XXX_ to set the
                max_length appropriately when the copy is first perfomed.
  3) change(89-01-31,Flegel), approve(89-03-08,PBF8020), audit(89-03-09,Lee),
     install(89-03-13,MR12.3-1023):
     Post Bug Fix - The call to sub_error_ had control string backwards in
     respect to the pathnames that were to be used based on the value of
     switch.
  4) change(89-11-15,Flegel), approve(89-11-16,MECR0014),
     audit(89-11-15,LZimmerman), install(89-11-16,MR12.3-1118):
     Repair "change_source_dir" subroutine to verify that the target is a real
     directory (which excludes MSFs).
  5) change(89-12-14,Flegel), approve(89-12-14,MCR8151),
     audit(89-12-14,LZimmerman), install(90-04-19,MR12.4-1007):
     Install MECR0014 through regular installation procedures.
  6) change(90-09-04,Huen), approve(90-09-04,MCR8195), audit(90-09-26,Vu),
     install(90-10-14,MR12.4-1039):
     phx21348 (cmds_837) - Fix the error handling of the copy/move commands by
     intercepting the "sub_error" condition.
                                                   END HISTORY COMMENTS */


/* format: style2,indcomtxt,idind30 */

copy_:
     proc (P_copy_options_ptr);

/* This is the primitive used to copy (and move) segments.

   Jay Pattin 6/2/83 */

/****
      BIM 830923 rework of object_type_ to fs_util_ */
/**** BIM 831022 split into fs_copy_ and copy_. */
/**** BIM 831031 fixed raw mode to use source type instead of target. */
/**** BIM 1984-07-27 fix copying with the raw switch. */
/**** C Spitzer 841102 fix bug in sub_err_ call */
/**** MSharpe 850206 to check the hcs type of the source before calling nd_handler_ */

/**** * copy_ is the advertised interface for copying objects.
      copy_ uses fs_util_$copy to copy the contents,
      and then various copy_XXX_ utilities to copy other
      atrributes. In raw mode, it forcibly uses segment or
      msf copying in fs_standard_object_, and does
      attributes appropriately. */

	declare P_copy_options_ptr	        ptr parameter;

	declare errsw		        bit (1) aligned;
	declare forced_access	        bit (1) aligned;
	declare max_length		        fixed bin (19);
	declare raw		        bit (1) aligned;
	declare same_dir_sw		        bit (1) aligned;
	declare ring_brackets	        (64) fixed bin (3);
	declare source_dir		        char (168);
	declare source_name		        char (32);
	declare source_type		        char (32);
	declare target_dir		        char (168);
	declare target_name		        char (32);
	declare (source_uid, target_uid)      bit (36) aligned;
	declare fs_type		        char (32);
	declare (source_hcs_type, target_hcs_type)
				        fixed bin (2);
	declare old_source_dir	        char (168);

	declare 1 bks		        aligned like status_for_backup;
	declare 1 si		        aligned like suffix_info;
	declare 1 cei		        aligned like copy_error_info;

	declare (
	        error_table_$nonamerr,
	        error_table_$dirseg,
	        error_table_$namedup,
	        error_table_$noentry,
	        error_table_$no_info,
	        error_table_$sameseg,
	        error_table_$segnamedup,
	        error_table_$unimplemented_version,
	        error_table_$unsupported_operation,
	        error_table_$action_not_performed
	        )			        fixed bin (35) external;

	declare copy_acl_		        entry (char (*), char (*), char (*), char (*), bit (1) aligned,
				        fixed bin (35));
	declare copy_names_		        entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned,
				        fixed bin (35));
	declare delete_$path	        entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
	declare expand_pathname_	        entry (char (*), char (*), char (*), fixed bin (35));
	declare (
	        hcs_$chname_file,
	        fs_util_$chname_file
	        )			        entry (char (*), char (*), char (*), char (*), fixed bin (35));
	declare hcs_$get_link_target	        entry (char (*), char (*), char (*), char (*), fixed bin (35));
	declare hcs_$get_uid_file	        entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	declare hcs_$status_minf	        entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				        fixed bin (35));
	declare hcs_$set_entry_bound	        entry (char (*), char (*), fixed bin (14), fixed bin (35));
	declare hcs_$status_for_backup        entry (char (*), char (*), ptr, fixed bin (35));
	declare move_names_		        entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned,
				        fixed bin (35));
	declare nd_handler_$switches	        entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35));

	declare get_shortest_path_	        entry (char (*)) returns (char (168));
	declare get_system_free_area_	        entry () returns (ptr);
	declare hcs_$status_	        entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));

	declare 1 entries		        aligned,
		2 (
		copy_entry	        entry (ptr, fixed bin (35)),
	        (get_ml_entry, set_ml_entry)  entry (char (*), char (*), fixed bin (19), fixed bin (35)),
	        (get_rb_entry, set_rb_entry)  entry (char (*), char (*), (*) fixed bin (3), fixed bin (35)),
	        (get_switch_entry, set_switch_entry)
				        entry (char (*), char (*), char (*), bit (1) aligned, fixed bin (35))
	        )			        variable;

	declare fs_util_$suffix_info_for_type entry (char (*), ptr, fixed bin (35));
	declare fs_util_$get_type	        entry (char (*), char (*), char (*), fixed bin (35));
	declare fs_util_$make_entry_for_type  entry (char (*), char (*), entry, fixed bin (35));
						/*	declare fs_util_$copy	        entry (pointer, fixed bin (35));
						*/
	declare sub_err_		        entry options (variable);
	declare pathname_		        entry (char (*), char (*)) returns (char (168));
	declare code		        fixed bin (35);

	declare (addr, fixed, rtrim, string, index, length, pointer, substr)
				        builtin;	/* format: off */

%page; %include status_structures;
%page; %include status_for_backup;
%page; %include suffix_info;
%page; %include copy_options;
%page; %include copy_flags;
%page; %include access_mode_values;
%page; %include delete_options;
%page; %include nd_handler_options;
%page; %include sub_error_info;
%page; %include sub_err_flags;
%page; %include condition_info_header;
%page; %include condition_info;
%page; %include copy_error_info;
%page; %include file_system_operations;
/* format: on */



	entries = Dummy_Procedure;			/* aggregately */
	old_source_dir = "";			/* No source dir change */
	copy_options_ptr = P_copy_options_ptr;
	if copy_options.version ^= COPY_OPTIONS_VERSION_1
	then call copy_error (error_table_$unimplemented_version, "0"b);

	if copy_options.extend &amp; copy_options.update
	then call fatal (0, "contents", "0"b, "The extend and update switches may not both be specified.");

	source_dir = copy_options.source_dir;
	source_name = copy_options.source_name;
	target_dir = copy_options.target_dir;
	target_name = copy_options.target_name;

	raw = copy_options.raw;
	forced_access = "0"b;

	call hcs_$status_minf (source_dir, source_name, 1 /* chase */, source_hcs_type, (0), code);
	if code ^= 0
	then if code ^= error_table_$no_info		/* may not be true for inner-ring entries;
						   fs_util_$get_type will catch this anyway */
	     then call copy_error (code, "0"b);

	call fs_util_$get_type (source_dir, source_name, source_type, code);
	if code = 0 &amp; source_type = FS_OBJECT_TYPE_DIRECTORY
	then code = error_table_$dirseg;
	if code ^= 0
	then call copy_error (code, "0"b);

	call hcs_$status_minf (target_dir, target_name, 0, target_hcs_type, (0), code);
						/* does target already exist? */
	if code = error_table_$noentry
	then /* Has to if updating or extending */
	     if copy_options.extend | copy_options.update
	     then call copy_error (code, "1"b);
	     else ;
	else do;					/* check if source = target */
		if code ^= 0
		then call copy_error (code, "1"b);
		call hcs_$get_uid_file (source_dir, source_name, source_uid, (0));
		call hcs_$get_uid_file (target_dir, target_name, target_uid, (0));
		if source_uid = target_uid
		then if target_hcs_type ^= Link
		     then call copy_error (error_table_$sameseg, "1"b);
		     else do;			/* in case we delete the link, get real source path */
			     call hcs_$get_link_target (copy_options.source_dir, copy_options.source_name,
				source_dir, source_name, code);
			     if code ^= 0
			     then call copy_error (code, "0"b);

			     copy_options.source_dir = source_dir;
			     copy_options.source_name = source_name;
			end;

		if ^copy_options.no_name_dup &amp; ^copy_options.extend &amp; ^copy_options.update
		then do;

/* MF - phx19616 - make sure pathname in source will not change */

			call change_source_dir ();
			string (nd_handler_options) = ""b;
			nd_handler_options.delete_force = copy_options.force;
			nd_handler_options.raw = raw;
			call nd_handler_$switches (copy_options.caller_name, target_dir, target_name,
			     string (nd_handler_options), code);
			if code ^= 0
			then do;
				if code = error_table_$action_not_performed
				then code = error_table_$namedup;
				call copy_error (code, "1"b);
			     end;
		     end;
	     end;					/* name duplication */

	if raw
	then /* we could use a GET_REAL_TYPE, ... */
	     if source_hcs_type = Segment
	     then fs_type = FS_OBJECT_TYPE_SEGMENT;
	     else fs_type = FS_OBJECT_TYPE_MSF;
	else fs_type = source_type;

	call fs_util_$make_entry_for_type (fs_type, FS_COPY, copy_entry, (0));
	call fs_util_$make_entry_for_type (fs_type, FS_GET_RING_BRACKETS, get_rb_entry, (0));
	call fs_util_$make_entry_for_type (fs_type, FS_SET_RING_BRACKETS, set_rb_entry, (0));
	call fs_util_$make_entry_for_type (fs_type, FS_GET_MAX_LENGTH, get_ml_entry, (0));
	call fs_util_$make_entry_for_type (fs_type, FS_SET_MAX_LENGTH, set_ml_entry, (0));
	call fs_util_$make_entry_for_type (fs_type, FS_GET_SWITCH, get_switch_entry, (0));
	call fs_util_$make_entry_for_type (fs_type, FS_SET_SWITCH, set_switch_entry, (0));

	si.version = SUFFIX_INFO_VERSION_1;
	call fs_util_$suffix_info_for_type (fs_type, addr (si), code);
	if code ^= 0
	then call copy_error (code, "0"b);

	if (copy_options.extend &amp; ^si.copy_flags.extend) | (copy_options.update &amp; ^si.copy_flags.update)
	then call copy_error (error_table_$unsupported_operation, "0"b);

/* phx21348 - use original if no source dir change */
	if (old_source_dir = "") /* No source_dir change */
	     then call copy_entry (copy_options_ptr, code);     /* Grab the contents */
	else begin; /* pass modified copy of struc that contains a valid source_dir */
/* MF - phx19616 - need to use a local version of copy_options so we don't
   * change the original passed into us when there is a source_dir change */
	declare 1 co		        aligned like copy_options;
	declare sub_error_		        condition;
	     co = copy_options;
	     co.source_dir = source_dir;     /* source_dir change */

/* phx21348 - If the sub_error_ condition occurs and the error was caused
 * using the modifed copy of the copy_options struc (co) then we patch
 * copy_error_info.copy_options_ptr to point back to the original version.
 * This is necessary because the handler in the 'copy' command uses this
 * value to determine whether to handle the condition. */
               on sub_error_  begin;
		declare 1 ci                          aligned like condition_info;
		declare continue_to_signal_           entry (fixed bin(35));
		declare find_condition_info_	        entry (ptr, ptr, fixed bin(35));
		declare null                          builtin;

		ci.version = condition_info_version_1;
		call find_condition_info_ (null (), addr (ci), (0));
		sub_error_info_ptr = ci.info_ptr;
		if sub_error_info.name = "copy_" &amp;
		   copy_error_info.copy_options_ptr = addr(co) then
		     copy_error_info.copy_options_ptr = P_copy_options_ptr;
	          call continue_to_signal_ ((0));
	     end;	/* of sub_error_ patch handler */

	     call copy_entry (addr (co), code);	      /* Grab the contents */
	end;
	if code ^= 0
	then call copy_error (code, (copy_options.target_err_switch));

/* MF - phx21214 - reorganized the characteristic copying section so that
   * the ACL is last (except for source deletion) and the ring_brackets are
   * second last. */

	if copy_options.max_length
	then if ^si.copy_flags.max_length
	     then call unsup ("max length");
	     else do;
		     call get_ml_entry (source_dir, source_name, max_length, code);
		     if code ^= 0
		     then call error (code, "max length", "0"b, "Getting max length on ^[^s^a^;^a^s^].");
		     else do;
			     call set_ml_entry (target_dir, target_name, max_length, code);

/* MF - phx21056 - ignore action_not_performed error code */

			     if code ^= 0 &amp; code ^= error_table_$action_not_performed
			     then call error (code, "max length", "1"b, "Setting max length on ^[^s^a^;^a^s^].");
			end;
		end;

	if copy_options.copy_switch
	then if ^si.copy_flags.copy_switch
	     then call unsup ("copy switch");
	     else call copy_switch ("copy");

	if copy_options.safety_switch
	then if ^si.copy_flags.safety_switch
	     then call unsup ("safety switch");
	     else call copy_switch ("safety");

	if copy_options.dumper_switches
	then if ^si.copy_flags.dumper_switches
	     then call unsup ("dumper switches");
	     else do;
		     call copy_switch ("complete_volume_dump");
		     call copy_switch ("incremental_volume_dump");
		end;
	if copy_options.entry_bound
	then do;
		if fs_type ^= FS_OBJECT_TYPE_SEGMENT
		then goto NOT_GATE;
		bks.version = status_for_backup_version_2;
		call hcs_$status_for_backup (source_dir, source_name, addr (bks), code);
		if code ^= 0
		then call error (code, "entry bound", "0"b, "Getting entry bound on ^[^s^a^;^a^s^].");
		else if ^bks.entrypt
		then
NOT_GATE:
		     call error (error_table_$unsupported_operation, "entry bound", "0"b,
			"Entry has no entry bound to copy. ^[^s^a^;^a^s^]");
		else do;
			call hcs_$set_entry_bound (target_dir, target_name, fixed (bks.entrypt_bound), code);
			if code ^= 0
			then call error (code, "entry bound", "1"b, "Setting entry bound on ^[^s^a^;^a^s^].");
		     end;
	     end;

	if copy_options.ring_brackets
	then if ^si.copy_flags.ring_brackets
	     then call unsup ("ring brackets");
	     else do;
		     call get_rb_entry (source_dir, source_name, ring_brackets, code);
		     if code ^= 0
		     then call error (code, "ring brackets", "0"b, "Getting ring brackets on ^[^s^a^;^a^s^].");
		     else do;
			     call set_rb_entry (target_dir, target_name, ring_brackets, code);
			     if code ^= 0
			     then call error (code, "ring brackets", "1"b,
				     "Setting ring brackets on ^[^s^a^;^a^s^].");
			end;
		end;

/**** NOTE -- since we don't have copy_XXX_$raw yet, we have to skip these! */

	if ^raw
	then do;
		if copy_options.acl
		then if ^si.copy_flags.acl
		     then call unsup ("ACL");
		     else do;
			     call copy_acl_ (source_dir, source_name, target_dir, target_name, errsw, code);
			     if code ^= 0
			     then call error (code, "ACL", errsw, "Copying ACL ^[from ^a^s^;to ^s^a^].");
			end;

		if copy_options.names
		then if ^si.copy_flags.names
		     then call unsup ("names");
		     else do;
			     same_dir_sw = same_dirp ();
			     if same_dir_sw
			     then do;		/* If in same dir, have to move names */
				     if ^copy_options.delete
				     then call warning (0, "names", "1"b,
					     "Source and target are in the same directory. Names will be moved instead of copied."
					     );
				     call move_names_ (source_dir, source_name, target_dir, target_name,
					copy_options.caller_name, errsw, code);
				end;
			     else call copy_names_ (source_dir, source_name, target_dir, target_name,
				     copy_options.caller_name, errsw, code);

			     if code ^= 0 &amp; code ^= error_table_$namedup &amp; code ^= error_table_$segnamedup
			     then call error (code, "names", errsw, "Copying names ^[from ^a^s^;to ^s^a^].");
			end;

	     end;

	if copy_options.delete
	then do;
		string (delete_options) = ""b;
		delete_options.segment, delete_options.link, delete_options.chase, delete_options.question = "1"b;
		delete_options.force = copy_options.force;
		delete_options.raw = raw;
		call delete_$path (source_dir, source_name, string (delete_options), copy_options.caller_name, code);
		if code ^= 0
		then if code ^= error_table_$action_not_performed
		     then call error (code, "delete", "0"b, "Deleting ^[^s^a^;^a^s^].");

		if copy_options.names &amp; same_dir_sw
		then do;
			if raw
			then call hcs_$chname_file (target_dir, target_name, "", source_name, code);
			else call fs_util_$chname_file (target_dir, target_name, "", source_name, code);
			if code ^= 0
			then call error (code, "names", "1"b, "Copying names to ^[^s^a^;^a^s^].");
		     end;
	     end;

MAIN_RETURN:
	return;
%page;
same_dirp:
     proc returns (bit (1) aligned);

	declare dir_dir		        char (168),
	        dir_ent		        char (32);

	if source_dir = target_dir
	then return ("1"b);

	call expand_pathname_ (source_dir, dir_dir, dir_ent, (0));
	call hcs_$get_uid_file (dir_dir, dir_ent, source_uid, (0));

	call expand_pathname_ (target_dir, dir_dir, dir_ent, (0));
	call hcs_$get_uid_file (dir_dir, dir_ent, target_uid, (0));

	return (source_uid = target_uid);
     end same_dirp;


copy_switch:
     proc (switch_name);

	declare switch_name		        char (*),
	        value		        bit (1) aligned;

	call get_switch_entry (source_dir, source_name, switch_name, value, code);
	if code ^= 0
	then call error (code, rtrim (switch_name) || "switch", "0"b, "Getting switch from ^[^s^a^;^a^s^].");
	else do;
		call set_switch_entry (target_dir, target_name, switch_name, value, code);
		if code ^= 0
		then call error (code, rtrim (switch_name) || "switch", "1"b, "Setting switch on ^[^s^a^;^a^s^].");
	     end;

	return;
     end copy_switch;

change_source_dir:
     proc ();

/* FUNCTION

   phx19616 - Determine whether or not there will be a conflict in names
   between a target pathname and some component of the source directory.  If
   there is, then the source dir will be changed so that a new name is inserted
   where the conflict occurs.  If there are no other names to use, then it will
   merely return to let nd_handler and the user resolve what to do.
*/

/* MISC VARIABLES */
	declare short_target_path	        char (168) var;
	declare short_target_dir	        char (168) var;
	declare short_source_dir	        char (168) var;
	declare target_type		        char (32);
	declare done		        bit (1);
	declare i			        fixed bin;
	declare 1 sb		        aligned like status_branch;

/* INIT */
	short_target_dir = rtrim (get_shortest_path_ (target_dir));
	short_source_dir = rtrim (get_shortest_path_ (source_dir));
	short_target_path = rtrim (pathname_ (rtrim (short_target_dir), target_name));

/* MAIN */

/* Find out what type of file we are targetting to */

	call fs_util_$get_type (target_dir, target_name, target_type, code);
	if (code ^= 0) then do;
	     call error (code, "copy_", "1"b, "Getting file system type of ^[^s^a^;^a^s^]");
	     return;
	end;

/* A target DIRECTORY contained in the source DIRECTORY is potential */

	if (target_type = FS_OBJECT_TYPE_DIRECTORY)
	     &amp; (index (short_source_dir, short_target_path) &gt; 0)
	then do;
		status_ptr = addr (sb);
		status_area_ptr = get_system_free_area_ ();

		call hcs_$status_ (target_dir, target_name, 0, status_ptr, status_area_ptr, code);
		if (code ^= 0)
		then call error (code, "status", "0"b, "Getting status on ^[^s^a^;^a^s^]");

		done = "0"b;			/* Is there really a contention? */
		do i = 1 to status_branch.short.nnames;
		     if status_entry_names (i) = target_name
		     then do;			/* Found, so get out of the loop */
			     done = "1"b;
			     i = status_branch.short.nnames;
			end;
		end;
		if ^done
		then do;				/* No, then get out */
			free status_entry_names;
			return;
		     end;

		i = 1;				/* Look for another name to use */
		done = "0"b;
		do while (^done);
		     if (i &gt; status_branch.short.nnames)
		     then /* None at all */
			done = "1"b;
		     else if (status_entry_names (i) ^= target_name)
		     then /* Found */
			done = "1"b;
		     else /* Keep trying */
			i = i + 1;
		end;

		if (i &gt; status_branch.short.nnames)
		then do;				/* Oh-oh, can't continue */
			free status_entry_names;
			call fatal (error_table_$nonamerr, "copy_", "1"b,
			     "^s^s^a. Source will be deleted before copy completed.");
			return;
		     end;

/* Rearrange the names so that there will be no contention */

		old_source_dir = source_dir;
		source_dir = short_target_dir || "&gt;" || rtrim (status_entry_names (i));
		if length (short_target_path) &lt; length (short_source_dir)
		then source_dir = rtrim (source_dir) || substr (short_source_dir, length (short_target_path) + 1);

		free status_entry_names;
	     end;

     end change_source_dir;



copy_error:
     proc (status, switch);

	declare status		        fixed bin (35),
	        switch		        bit (1) aligned;

	cei.copy_options_ptr = copy_options_ptr;
	cei.operation = "contents";
	cei.target_err_switch = switch;

	do while ("1"b);
	     call sub_err_ (status, "copy_", ACTION_CANT_RESTART, addr (cei), (0), "^[^a^s^;^s^a^]", switch,
		pathname_ (target_dir, target_name), pathname_ (source_dir, source_name));

	end;

     end copy_error;

unsup:
     proc (op);

	declare op		        char (32);

	cei.copy_options_ptr = copy_options_ptr;
	cei.operation = op;
	cei.target_err_switch = "0"b;

	call sub_err_ (error_table_$unsupported_operation, "copy_", ACTION_CAN_RESTART, addr (cei), (0),
	     "The ^a object type does not support the copying of ^a. ^a", si.type_name, op,
	     pathname_ (source_dir, source_name));

	return;
     end unsup;


error:
     proc (status, op, switch, message);

	declare flags		        bit (36) aligned,
	        status		        fixed bin (35),
	        op		        char (*),
	        switch		        bit (1) aligned,
	        message		        char (*);

	flags = ACTION_CAN_RESTART;
	goto COMMON;

fatal:
     entry (status, op, switch, message);

	flags = ACTION_CANT_RESTART;
	goto COMMON;

warning:
     entry (status, op, switch, message);

	flags = ACTION_DEFAULT_RESTART;
COMMON:
	cei.copy_options_ptr = copy_options_ptr;
	cei.operation = op;
	cei.target_err_switch = switch;

	call sub_err_ (status, "copy_", flags, addr (cei), (0), message, switch, pathname_ (source_dir, source_name),
	     pathname_ (target_dir, target_name));

	return;

     end error;

Dummy_Procedure:
     procedure options (non_quick);

	declare cu_$arg_count	        entry (fixed bin, fixed bin (35));
	declare cu_$arg_ptr		        entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare last_arg_x		        fixed bin;
	declare code_ptr		        pointer;
	declare code		        fixed bin (35) based (code_ptr);
	declare error_table_$no_operation     fixed bin (35) ext static;

	call cu_$arg_count (last_arg_x, (0));
	call cu_$arg_ptr (last_arg_x, code_ptr, (0), (0));
	code = error_table_$no_operation;
	return;
     end Dummy_Procedure;

     end copy_;
��



		    copy_acl.pl1                    09/12/84  1456.6rew 09/12/84  1451.6       78471



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */




/* format: style2,idind30,indcomtxt */

copy_acl:
     procedure options (variable);

/* COPY_ACL, COPY_IACL_SEG, COPY_IACL_DIR */
/* initial coding 8/76 THVV */
/* Added -working_dir or -wd in place of pathnames 07/25/80 S. Herbst */
/* cleaned and neatened BIM and J. Pattin, 83-(8 9) */
/* Modified 11/01/83 by C. Spitzer.  fix arg processing bug, allow equal
   convention in place of missing last argument */

          dcl     arg                           char (al) based (ap);
          dcl     (dn1, dn2)                    char (168);
          dcl     (en1, en2)                    char (32);
          dcl     error_sw                      bit (1);
          dcl     (ap, areap)                   ptr;
          dcl     (eptr, nptr)                  ptr init (null);
          dcl     whoami                        char (13);
          dcl     (i, ecount)                   fixed bin;
          dcl     al                            fixed bin (21);
          dcl     an                            fixed bin init (1);
          dcl     (starsw, areasw)              bit (1) init ("0"b);

          dcl     system_area                   area ((1024)) based (areap);

          dcl     1 entries                     (100) based (eptr) aligned,
                    2 type                      bit (2) unaligned,
                    2 nnames                    bit (16) unaligned,
                    2 nindex                    bit (18) unaligned;

          dcl     names                         (100) char (32) based (nptr);

          dcl     arg_count                     fixed bin;
          dcl     code                          fixed bin (35);
          dcl     error_table_$badopt           fixed bin (35) ext;
          dcl     error_table_$noarg            fixed bin (35) ext;
          dcl     error_table_$odd_no_of_args   fixed bin (35) ext;
          dcl     error_table_$badequal         fixed bin (35) ext;

          dcl     check_star_name_$entry        entry (char (*), fixed bin (35));
          dcl     com_err_                      entry options (variable);
          dcl     com_err_$suppress_name        entry options (variable);
          dcl     cu_$arg_count                 entry (fixed bin, fixed bin (35));
          dcl     cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
          dcl     get_equal_name_               entry (char (*), char (*), char (*), fixed bin (35));
          dcl     expand_pathname_              entry (char (*), char (*), char (*), fixed bin (35));
          dcl     hcs_$star_                    entry (char (*), char (*), fixed bin, ptr, fixed bin, ptr, ptr,
                                                fixed bin (35));
          dcl     get_system_free_area_         entry () returns (ptr);
          dcl     get_wdir_                     entry returns (char (168));
          dcl     copy_acl_                     entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35));
          dcl     copy_iacl_$dir                entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35));
          dcl     copy_iacl_$seg                entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35));
          dcl     pathname_                     entry (char (*), char (*)) returns (char (168));

          dcl     (addr, addrel, bin, null)     builtin;
          dcl     cleanup                       condition;



          whoami = "copy_acl";
          go to start;

copy_iacl_seg:
     entry;
          whoami = "copy_iacl_seg";
          go to start;

copy_iacl_dir:
     entry;
          whoami = "copy_iacl_dir";

start:
          call cu_$arg_count (arg_count, code);
          if code ^= 0
          then do;
                    call com_err_ (code, whoami);
                    return;
               end;
          if arg_count = 0
          then do;
                    call com_err_$suppress_name (0, whoami, "Usage: ^a path11 {path21 ... pathN1 {pathN2}}", whoami);
                    return;
               end;

          do an = 1 to arg_count by 2;
               call cu_$arg_ptr (an, ap, al, (0));

               if index (arg, "-") = 1
               then if arg = "-working_dir" | arg = "-wd"
                    then call expand_pathname_ (get_wdir_ (), dn1, en1, code);
                    else do;
BADOPT:
                              call com_err_ (error_table_$badopt, whoami, "^a", arg);
                              return;
                         end;
               else call expand_pathname_ (arg, dn1, en1, code);

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

               call check_star_name_$entry (en1, code);
               if code = 0
               then starsw = "0"b;                          /* No stars */
               else if code &lt;= 2
               then do;                                     /* Name1 has stars */
                         if ^areasw
                         then do;
                                   areasw = "1"b;
                                   areap = get_system_free_area_ ();
                                   on condition (cleanup) call cleanup_handler;
                              end;
                         call hcs_$star_ (dn1, en1, 3, areap, ecount, eptr, nptr, code);
                         if code ^= 0
                         then do;
                                   call com_err_ (code, whoami, "Could not star list ^a.", pathname_ (dn1, en1));
                                   return;
                              end;
                         starsw = "1"b;
                    end;
               else
PATHNAME_ERROR:
                    do;
                         call com_err_ (code, whoami, "^a.", pathname_ (dn1, en1));
                         return;
                    end;

	     if an = arg_count
	     then do;				/* last argument missing */
		dn2 = get_wdir_ ();
		en2 = "===";			/* same name in current [wd] */
		end;
	     else do;
		call cu_$arg_ptr (an+1, ap, al, (0));	/* Get Name2 */

		if index (arg, "-") = 1
		then if arg = "-working_dir" | arg = "-wd"
		     then call expand_pathname_ (get_wdir_ (), dn2, en2, code);
		     else go to BADOPT;
		else call expand_pathname_ (arg, dn2, en2, code);

		if code ^= 0
		then go to PATHNAME_ERROR;
	     end;

               if ^starsw
               then call PERFORM_COPY (en1);
               else do i = 1 to ecount;
                         call PERFORM_COPY (names (bin (entries (i).nindex, 18)));
                    end;
again:
               if starsw
               then call cleanup_handler;
          end;

PERFORM_COPY:
     proc (oldent);

          dcl     oldent                        char (32);
          dcl     newent                        char (32);

          call get_equal_name_ (oldent, en2, newent, code);
          if code ^= 0
          then if code = error_table_$badequal
               then go to PATHNAME_ERROR;                   /* skip this pair of arguments */
               else do;                                     /* must be longeql */
                         call com_err_ (code, whoami, arg); /* print arg name in error message */
                         return;
                    end;

          if whoami = "copy_acl"
          then call copy_acl_ (dn1, oldent, dn2, newent, error_sw, code);
          else if whoami = "copy_iacl_seg"
          then call copy_iacl_$seg (dn1, oldent, dn2, newent, error_sw, code);
          else if whoami = "copy_iacl_dir"
          then call copy_iacl_$dir (dn1, oldent, dn2, newent, error_sw, code);

          if code ^= 0
          then do;
                    if error_sw
                    then call com_err_ (code, whoami, "^a", pathname_ (dn2, newent));
                    else call com_err_ (code, whoami, "^a", pathname_ (dn1, oldent));
               end;

     end PERFORM_COPY;

cleanup_handler:
     proc;
          if eptr ^= null
          then free entries in (system_area);
          if nptr ^= null
          then free names in (system_area);
     end cleanup_handler;

     end copy_acl;
�



		    copy_acl_.pl1                   12/07/87  1554.0rew 12/07/87  1343.3       78534



/****^  **************************************************************
        *                                                            *
        * Copyright, (C) Honeywell Bull Inc., 1987                   *
        *                                                            *
        * Copyright, (C) Honeywell Information Systems Inc., 1983    *
        *                                                            *
        * Copyright, (C) Massachusetts Institute of Technology, 1983 *
        *                                                            *
        ************************************************************** */






/****^  HISTORY COMMENTS:
  1) change(87-08-27,TLNguyen), approve(87-08-27,MCR7755),
     audit(87-09-08,Lippard), install(87-12-07,MR12.2-1009):
     Change copy_acl_ to set the error switch just before it calls
     fs_util_$replace_acl.
                                                   END HISTORY COMMENTS */


/* format: style2,idind30,indcomtxt */

copy_acl_:
     proc (Dir_name_1, Entryname_1, Dir_name_2, Entryname_2, Errsw, Code);


/* Routine to copy the acl from one file to another.
   Called by the copy command.
   Coded by John Strayhorn, 7/1/70 */
/* Modified by M. Weaver 31 December 1970 */
/* Modified 7/1/74 by Steve Herbst to copy MSF acls */
/* Modified 12/19/79 by Gary Dixon to copy seg-&gt;MSF acls, or vice versa */
/* Modified 2/20/83 Jay Pattin for object_type_ */
/* Modified 830927 BIM for object_type_ --&gt; fs_util_ */

          dcl     cleanup                       condition;

          dcl     (Dir_name_1, Entryname_1, Dir_name_2, Entryname_2)
                                                char (*);   /* arguments */

          dcl     Code                          fixed bin (35);
          dcl     error_table_$not_seg_type     fixed bin (35) ext static;
          dcl     error_table_$unsupported_operation
                                                fixed bin (35) ext static;
          dcl     Errsw                         bit (1) aligned;
                                                            /* indicates which seg error was on */

          declare fs_util_$suffix_info          entry (character (*), character (*), pointer, fixed binary (35));
          declare fs_util_$list_acl             entry (character (*), character (*), character (*), pointer, pointer,
                                                fixed binary (35));
          declare fs_util_$list_extended_acl    entry (character (*), character (*), character (*), pointer, pointer,
                                                fixed binary (35));
          declare fs_util_$replace_acl          entry (character (*), character (*), pointer, bit (1), fixed binary (35));
          declare fs_util_$replace_extended_acl entry (character (*), character (*), pointer, bit (1), fixed binary (35));
          declare fs_util_$get_type             entry (character (*), character (*), character (*), fixed binary (35));
          declare get_system_free_area_         entry () returns (ptr);
          declare sub_err_                      entry () options (variable);

          declare fs_util_type_2                char (32) unaligned;
          declare dir_name                      (2) char (168) unaligned;
          declare entryname                     (2) char (32) unaligned;
%page;
%include acl_structures;
%include suffix_info;
%include copy_flags;
          declare 1 si                          aligned like suffix_info;
%include sub_err_flags;
%page;
          dcl     (addr, null)           builtin;

/* begin coding */
          Code = 0;
          acl_ptr = null ();                                /* make cleanup handler happy */

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

/* get input parameters */
          dir_name (1) = Dir_name_1;
          dir_name (2) = Dir_name_2;
          entryname (1) = Entryname_1;
          entryname (2) = Entryname_2;

/* determine the type (extended or standard) of specified source and target entries */
          Errsw = "0"b;                                     /* Error apply to source. */
          si.version = SUFFIX_INFO_VERSION_1;               /* get version name for "si" structure */
          call fs_util_$suffix_info (dir_name (1), entryname (1), addr (si), Code);
          if Code ^= 0 
          then return;

          Errsw = "1"b;                                     /* indicates error applied to target */
          call fs_util_$get_type (dir_name (2), entryname (2), fs_util_type_2, Code);
          if Code ^= 0
          then return;

/**** *
      Errsw = 1 since mismatch is layed at door of output */

          if si.type ^= fs_util_type_2
          then do;
                    if si.type = FS_OBJECT_TYPE_SEGMENT | si.type = FS_OBJECT_TYPE_MSF
                    then call SPECIAL_CASE_SEG_MSF;         /* perhaps seg -&gt; msf or vica versa */
                    else Code = error_table_$not_seg_type;  /* ycch, used to get dirseg right ... */
                    return;
               end;


/**** *
      here is a pair of the same type ! */

          Errsw = "0"b;                                     /* indicates error applied to source */
          if si.extended_acl
          then do;
                    call fs_util_$list_extended_acl (dir_name (1), entryname (1), GENERAL_EXTENDED_ACL_VERSION_1,
                         get_system_free_area_ (), acl_ptr, Code);
                    if Code = error_table_$unsupported_operation
                    then call sub_err_ ((0), "Invalid suffix_XXX_", ACTION_CANT_RESTART, null (), (0),
                              "suffix_^a_ claims to support extended acl's, but does not supply a list_extended_acl operation."
                              , fs_util_type_2);

                    else if Code ^= 0
                    then go to EXIT;

                    Errsw = "1"b;                          /* indicates error applied to target */
                    call fs_util_$replace_extended_acl (dir_name (2), entryname (2), acl_ptr, "1"b /* no sysdaemon! */,
                         Code);

                    if Code = error_table_$unsupported_operation
                    then call sub_err_ ((0), "Invalid suffix_XXX_", ACTION_CANT_RESTART, null (), (0),
                              "suffix_^a_ claims to support extended acl's, but does not supply a replace_extended_acl operation."
                              , fs_util_type_2);

                    go to EXIT;                             /* Leaving code set */

               end;

/**** *
      Land here for non-extended acls */


          Errsw = "0"b;                                      /* indicates error applied to source */
          call fs_util_$list_acl (dir_name (1), entryname (1), GENERAL_ACL_VERSION_1, get_system_free_area_ (), acl_ptr,
               Code);
          if Code ^= 0
          then go to EXIT;

	Errsw = "1"b;                                       /* indicates error applied to target */
          call fs_util_$replace_acl (dir_name (2), entryname (2), acl_ptr, "1"b /* no sysdaemon! */, Code);

          go to EXIT;


/**** *
      This procedure handles the special case of copying acls back and forth
      between segments and msf's. Someday, we may permit this for dm files
      as well. */

SPECIAL_CASE_SEG_MSF:
     procedure;


/**** *
      To get into this procedure, the input object had to be a seg
      or msf. now examine the output object to see if the types are
      compatable. */

          if fs_util_type_2 ^= FS_OBJECT_TYPE_SEGMENT &amp; fs_util_type_2 ^= FS_OBJECT_TYPE_MSF
          then do;
                    Code = error_table_$not_seg_type;
                    return;
               end;

          Errsw = "0"b;                                        /* indicates error applied to source */
          call fs_util_$list_extended_acl (dir_name (1), entryname (1), GENERAL_EXTENDED_ACL_VERSION_1,
               get_system_free_area_ (), acl_ptr, Code);
          if Code ^= 0
          then return;

          Errsw = "1"b;                                         /* indicates error applied to target */
          call fs_util_$replace_extended_acl (dir_name (2), entryname (2), acl_ptr, "1"b /* no sysdaemon! */, Code);

          return;
     end SPECIAL_CASE_SEG_MSF;


EXIT:
          call clean_up ();

          if Code = 0
          then Errsw = "0"b;

          return;


clean_up:
     proc;

          if acl_ptr ^= null ()
          then do;
                    free general_acl;                       /* or general_extended_acl, illegal but effective */
                    return;
               end;

     end clean_up;

     end copy_acl_;
��



		    copy_dir.pl1                    03/10/85  1722.5r w 03/08/85  1003.3      137340



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */




/* format: style2,idind30,indcomtxt */
copy_dir:
cpd:
     procedure options (variable);

/*  Move or copy a directory and its subtree.

   Last modified:

   06/02/78  by  LLS for initial implementation
   07/06/78  by  LLS to add -update, the entry_type_keys, and fix containment and argument consistency checking.
   11/14/80  by  GAT to use copy_dir_.
   09/22/81  by  Lindsey Spratt: removed call to status to validate pathnames.
   copy_dir_ does this validation and it need not be duplicated
   here.
   6/29/83 by Jay Pattin to add -fcnt
   831002  by BIM to cleanup a bit, audit above, etc. 
   25/09/84 by B. Braun to initialize copy_dir_options.parent_ac_sw to "0"b;
   12/27/84  by Keith Loepere to remove create_branch_info.
   830206 by MSharpe to replace -fcnt with -inase/inaee; to accept -fc
	   as synonym for -force;  to initialize cdo.primary to ""b.
*/
/* Entries */

          dcl     check_star_name_$entry        entry (char (*), fixed bin (35));
          dcl     com_err_                      entry options (variable);
          dcl     com_err_$suppress_name        entry options (variable);
          dcl     copy_dir_                     entry (char (*), char (*), char (*), char (*), char (*), ptr,
                                                fixed bin (35));
          dcl     cu_$arg_count                 entry (fixed bin, fixed bin (35));
          dcl     cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
          dcl     expand_pathname_              entry (char (*), char (*), char (*), fixed bin (35));
          dcl     get_equal_name_               entry (char (*), char (*), char (32), fixed bin (35));
          dcl     get_system_free_area_         entry returns (ptr);
          dcl     get_wdir_                     entry returns (char (168));
          dcl     hcs_$star_                    entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
                                                fixed bin (35));

/**** *  Conditions  */

          dcl     cleanup                       condition;

/**** *  Based  */

          dcl     arg                           char (arg_len) based (arg_ptr);
          dcl     area                          area based (area_ptr);

/**** *  Automatic  */

          dcl     whoami                        char (8);   /* name of entry into code ("copy_dir" or "move_dir"). */
          dcl     code                          fixed bin (35);
                                                            /* the returned error code from a system call. */
          dcl     (
                  all_entries,                              /* all entries are copied */
                  all_names,                                /* all names on an entry are copied */
                  errors,
                  have_source,                              /* pathname of source is known. */
                  have_target,                              /* pathname of target is known */
                  same_dir,                                 /* se_name and te_name are in the same directory. */
                  multiple_sources,                         /* star name input                                */
                  move
                 )                              bit (1);    /* delete source_dir after copying */
          dcl     (
                  argno,                                    /* index to count through the argument list. */
                  entry_count,                              /* number star matches                            */
                  entry_index,
                  nargs
                  )                             fixed bin;
          dcl     arg_len                       fixed bin (21);
                                                            /* length of argument pointed to by arg_ptr. */

          dcl     (sd_name, td_name, wd)        char (168);
          dcl     (entry_temp, se_name, te_name)
                                                char (32);
          dcl     (arg1, arg2)                  char (32) varying;
          dcl     (
                  area_ptr,                                 /* ptr on which area is based. */
                  arg_ptr                                   /* Ptr to arg, set by call to cu_$arg_ptr. */
                  )                             ptr;

/*  External  */

          dcl     (
                  error_table_$badopt,
                  error_table_$inconsistent,
                  error_table_$notadir,
                  error_table_$no_s_permission
                  )                             fixed bin (35) external;

/**** *  Builtins  */

          dcl     (addr, binary, null, substr, sum)
                                                builtin;


          whoami = "copy_dir";
          move = "0"b;
          go to START;

move_dir:
mvd:
     entry options (variable);

          whoami = "move_dir";
          move = "1"b;

/*  true beginning of program */

START:
          star_branch_count, star_link_count = 0;
          star_select_sw = star_BRANCHES_ONLY;
          area_ptr = get_system_free_area_ ();
          star_entry_ptr, star_names_ptr = null ();
          on condition (cleanup)
               begin;
                    if star_names_ptr ^= null ()
                    then free star_names in (area);
                    if star_entry_ptr ^= null ()
                    then free star_entries in (area);
               end;

          wd = get_wdir_ ();
          have_source = "0"b;
          have_target = "0"b;
          all_names = "1"b;
          all_entries = "1"b;
          errors = "0"b;
          same_dir = "0"b;

          cdo.version = copy_dir_options_version_0;
          cdo.replace = "0"b;
          cdo.link_translation = "1"b;
	cdo.primary = "0"b;
          cdo.acl = "0"b;
          cdo.force = "0"b;
          cdo.brief = "0"b;
          cdo.chase = "0"b;
          cdo.parent_ac_sw = "0"b;
          cdo.link = "0"b;
          cdo.seg = "0"b;
          cdo.msf = "0"b;
          cdo.nnlk = "0"b;
          cdo.update = "0"b;
          cdo.dir = "0"b;
          cdo.raw = "0"b;
          cdo.pad1, cdo.pad2 = "0"b;
          if move
          then cdo.delete = "1"b;
          else cdo.delete = "0"b;


/* process arguments */

          call cu_$arg_count (nargs, code);
          if code ^= 0
          then do;
                    call com_err_ (code, whoami);
                    return;
               end;
          if nargs = 0
          then do;
usage:
                    call com_err_$suppress_name (0, whoami,
                         "Usage: ^a source_dir {target_dir} {-entry_type_keys} {-control_args} ", whoami);
                    goto finish;
               end;                                         /* get source_dir (sd_name and se_name). */


          do argno = 1 to nargs;
               call cu_$arg_ptr (argno, arg_ptr, arg_len, code);
               if code ^= 0
               then do;
                         call com_err_ (code, whoami, "On argument number ^d", argno);
                         goto finish;
                    end;

               if substr (arg, 1, 1) ^= "-"
               then if ^have_source
                    then do;
                              call expand_pathname_ (arg, sd_name, se_name, code);
                              if code ^= 0
                              then do;
err:
                                        call com_err_ (code, whoami, "^a", arg);
                                        goto finish;
                                   end;
                              call check_star_name_$entry (se_name, code);
                              if code = 0
                              then do;
                                        entry_count = 1;
                                        multiple_sources = "0"b;
                                   end;
                              else if (code = 1 | code = 2)
                              then multiple_sources = "1"b;
                              else do;
                                        call com_err_ (code, whoami, "Star name check failed on ^a.", se_name);
                                        goto finish;
                                   end;
                              have_source = "1"b;
                         end;

/*  process the rest of the arguments. */

                    else if ^have_target
                    then do;

                              call expand_pathname_ (arg, td_name, entry_temp, code);
                              if code ^= 0
                              then do;
                                        call com_err_ (code, whoami, "^a", arg);
                                        goto finish;
                                   end;

                              have_target = "1"b;
                         end;
                    else do;
                              call com_err_ (error_table_$badopt, whoami,
                                   "Too many pathnames, a maximum of two is allowed.");
                              goto finish;
                         end;                               /* check for the control arguments */
               else if arg = "-replace" | arg = "-rp"
               then cdo.replace = "1"b;
               else if arg = "-update" | arg = "-ud"
               then cdo.update = "1"b;
               else if (arg = "-no_link_translation" | arg = "-nlt") &amp; ^move
               then cdo.link_translation = "0"b;
               else if arg = "-acl"
               then cdo.acl = "1"b;
               else if arg = "-force" | arg = "-fc"
               then cdo.force = "1"b;
               else if arg = "-brief" | arg = "-bf"
               then cdo.brief = "1"b;
               else if arg = "-chase"
               then cdo.chase = "1"b;
               else if arg = "-primary" | arg = "-pri"
               then cdo.primary = "1"b;
               else if arg = "-interpret_as_standard_entry" | arg = "-inase"
               then cdo.raw = "1"b;

               else if arg = "-interpret_as_extended_entry" | arg = "-inaee"
               then cdo.raw = "0"b;

/* check for entry type keys. */

               else if arg = "-link" | arg = "-lk"
               then do;
                         all_entries = "0"b;
                         cdo.link = "1"b;
                    end;
               else if arg = "-sm" | arg = "-segment"
               then do;
                         all_entries = "0"b;
                         cdo.seg = "1"b;
                    end;
               else if arg = "-dr" | arg = "-directory"
               then do;
                         all_entries = "0"b;
                         cdo.dir = "1"b;
                    end;
               else if arg = "-branch" | arg = "-br"
               then do;
                         all_entries = "0"b;
                         cdo.seg = "1"b;
                         cdo.msf = "1"b;
                         cdo.dir = "1"b;
                    end;
               else if arg = "-file" | arg = "-f"
               then do;
                         all_entries = "0"b;
                         cdo.seg = "1"b;
                         cdo.msf = "1"b;
                    end;
               else if arg = "-msf" | arg = "-multisegment_file"
               then do;
                         all_entries = "0"b;
                         cdo.msf = "1"b;
                    end;
               else if arg = "-non_null_link" | arg = "-nnlk"
               then do;
                         all_entries = "0"b;
                         cdo.nnlk = "1"b;
                    end;
               else do;
                         call com_err_ (error_table_$badopt, whoami, "^a", arg);
                         goto finish;
                    end;
          end;

/* check argument compatibility. */

          if (cdo.nnlk &amp; cdo.link)
          then do;
                    arg1 = "-non_null_link";
                    arg2 = "-link";
incompatarg:
                    call com_err_ (error_table_$inconsistent, whoami, "Incompatible arguments ^a and ^a", arg1, arg2);
                    goto finish;
               end;
          if (cdo.replace &amp; cdo.update)
          then do;
                    arg1 = "-replace";
                    arg2 = "-update";
                    goto incompatarg;
               end;
          if (cdo.chase &amp; ^(cdo.link | all_entries))
          then do;
                    arg1 = "-chase";
                    arg2 = "not -link";
                    goto incompatarg;
               end;
          if ^have_target
          then do;
                    td_name = wd;
                    entry_temp = "==";
               end;
          if all_entries
          then cdo.link, cdo.seg, cdo.dir, cdo.msf = "1"b;


/* if source_dir is a star name, decode it and set up for using
   multiple source entries.  Otherwise, set up for using  a single
   source entry. */

          if multiple_sources
          then do;

                    call hcs_$star_ (sd_name, se_name, star_BRANCHES_ONLY, area_ptr, star_entry_count, star_entry_ptr,
                         star_names_ptr, code);
                    if code ^= 0
                    then do;
                              call com_err_ (code, whoami, "Could not get matching names for ^a^[&gt;^]^a.", sd_name,
                                   sd_name ^= "&gt;", se_name);
                              goto finish;
                         end;
                    entry_count = star_entry_count;
               end;

/* begin the loop through all of the source entries. */

          do entry_index = 1 to entry_count;
               if multiple_sources
               then if star_entries (entry_index).type = star_DIRECTORY
                                                            /*  check that arg 1 is a directory. */
                    then se_name = star_names (star_entries (entry_index).nindex);
                    else goto NEXT_ENTRY;

               call get_equal_name_ (se_name, entry_temp, te_name, code);
               call copy_dir_ (whoami, sd_name, se_name, td_name, te_name, addr (cdo), code);

/* errors messages are taken care of by copy_dir_, if -brief was used, the "trivial" errors
   aren't reported anywhere.
*/
NEXT_ENTRY:
          end;
finish:
          if star_names_ptr ^= null ()
          then free star_names in (area);
          if star_entry_ptr ^= null ()
          then free star_entries in (area);

          return;
%page;
/* Include */

%include star_structures;
%page;
%include query_info_;
%page;
%include copy_dir_options;

          declare 1 cdo                         aligned like copy_dir_options;

     end copy_dir;




		    copy_dir_.pl1                   03/15/89  0848.2r w 03/15/89  0800.0      401661



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */





/****^  HISTORY COMMENTS:
  1) change(87-02-17,TLNguyen), approve(87-02-17,MCR7624),
     audit(87-02-27,Lippard), install(87-03-20,MR12.1-1006):
     - Change "copy_dir_" to always set its returned code parameter before
       returning.
     - Change "copy_dir_" to properly delete the target dir when "-replace"
       is given.  It currently calls "hcs_$del_dir_tree" rather than calling
       "delete_$path".  Therefore it fails to delete Data Managment files.
     - Change "copy_dir_" to properly copy ACLs when -acl is specified.  It
       currently copies only ACLs on 2nd-Nth segments of a directory.
  2) change(88-08-30,TLNguyen), approve(88-08-30,MCR7949),
     audit(88-09-09,Parisek), install(88-11-1,MR12.2-1202):	
     - Change the copy_dir_ to do the containment check before deleting
       the contents of the target which indicated by the replace flag.
     - Change copy_dir_ so that -replace will work as documented for
       the copy_dir command.
                                                   END HISTORY COMMENTS */


/* format: style2,idind30,indcomtxt */
copy_dir_:
     procedure (whoami, source_dir, source_ename, target_dir, target_ename, pcopy_dir_options, acode);

/****

      * Most of this code is from the original copy_dir command.

      * Status:
      0) Original by LLS in 1978
      1) Modified: 11/80 by GAT to make the subroutines
      2) Gutted: 6/30/83 by Jay Pattin for extended objects
      3) 831002 BIM for extended object cleanup
      4) Modified: 12/84 by Keith Loepere to set dir_quota at append.
      5)  Modified:  2/15/85 M. Sharpe to give up if can't create target */

/**** * Entries */
	dcl     command_query_	        entry options (variable);
	dcl     copy_		        entry (ptr);
	dcl     com_err_		        entry options (variable);
	dcl     copy_acl_		        entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35));
	dcl     copy_iacl_		        entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35));
	dcl     move_names_		        entry (char (*), char (*), char (*), char (*), char (*), bit (1),
				        fixed bin (35));
	dcl     copy_names_		        entry (char (*), char (*), char (*), char (*), char (*), bit (1),
				        fixed bin (35));

	dcl     continue_to_signal_	        entry (fixed bin (35));
	dcl     expand_pathname_	        entry (char (*), char (*), char (*), fixed bin (35));
	dcl     find_condition_info_	        entry (ptr, ptr, fixed bin (35));
	dcl     get_group_id_$tag_star        entry returns (char (32));
	dcl     get_max_authorization_        entry () returns (bit (72) aligned);
	dcl     get_ring_		        entry () returns (fixed bin (3));
	dcl     get_system_free_area_	        entry returns (ptr);
	dcl     hcs_$get_dir_ring_brackets    entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
	dcl     hcs_$get_access_class	        entry (char (*), char (*), bit (72) aligned, fixed bin (35));
	dcl     hcs_$append_link	        entry (char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$create_branch_	        entry (char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$get_safety_sw	        entry (char (*), char (*), bit (1), fixed bin (35));
	dcl     hcs_$get_uid_file	        entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     hcs_$get_link_target	        entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$set_safety_sw	        entry (char (*), char (*), bit (1), fixed bin (35));
	dcl     hcs_$star_		        entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
				        fixed bin (35));
	dcl     hcs_$status_	        entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     hcs_$status_minf	        entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				        fixed bin (35));
	dcl     cu_$arg_list_ptr	        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_$general_rs	        entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned,
				        bit (1) aligned);
	dcl     ioa_		        entry options (variable);
	dcl     ioa_$rsnnl		        entry options (variable);
	dcl     nd_handler_		        entry (char (*), char (*), char (*), fixed bin (35));
	dcl     nd_handler_$switches	        entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     delete_$path	        entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
	dcl     fs_util_$get_type	        entry (character (*), character (*), character (*), fixed binary (35));
	dcl     fs_util_$suffix_info	        entry (char (*), char (*), ptr, fixed bin (35));
	dcl     pathname_		        entry (char (*), char (*)) returns (char (168));
	dcl     sub_err_		        entry () options (variable);

/* Constants */

	dcl     no_translation	        fixed bin (35) internal static options (constant) init (1);

/*  Conditions  */

	dcl     (cleanup, sub_error_)	        condition;

/*  Based  */

	dcl     1 comp		        based (cptr),
		2 name		        char (32) varying,
		2 next		        ptr;

	dcl     area		        area based (area_ptr);

/*  Automatic  */

	dcl     acode		        fixed bin (35);
	dcl     parent_access	        bit (1);
	dcl     (source_dir, source_ename, target_dir, target_ename)
				        char (*);	/* from where to where                            */
	dcl     whoami		        char (*);	/* name of entry into code ("copy_dir" or "move_dir"). */
	dcl     (tt, type)		        fixed bin (2);
						/*  type of entry returned by hcs_$status_minf,
						   0 = link, 1 = seg, 2 = dir. */
	dcl     ln		        fixed bin (21);
						/* length of a char string returned by ioa_$rsnnl. */
	dcl     (code, code1)	        fixed bin (35);
						/* the returned error code from a system call. */
	dcl     bc		        fixed bin (24);
						/* bit count returned by hcs_$status_minf. */
	dcl     answer		        char (3) varying;
						/* answer from user via command_query_ */
	dcl     dir_rings		        (2) fixed bin (3);
						/* ring validation for a directory. */
	dcl     (
	        acl,				/* acl on copy is same as original */
	        all_entries,			/* all entries are copied */
	        all_names,				/* all names on an entry are copied */
	        brief,				/* comments are suppressed */
	        chase,				/* copy targets of links */
	        force,				/* user is not queried about existing target */
	        raw,				/* don't use object_type_ */
	        replace,				/* truncate target_dir before copying */
	        translate_links,			/* translate links */
	        update,				/* name duplications are deleted or unlinked without asking the user */
	        clink,				/* copy links. */
	        cseg,				/* copy segments. */
	        cmsf,				/* copy multisegment files. */
	        cnnl,				/* copy non-null links. */
	        cdir,				/* copy directories. */
	        errors,				/* one or more errors occurred while processing */
	        ersw,				/* used in calls to copy_ utilities to indicate which
						   entry an error occurred on. */
	        source_contains_target,		/* if "1"b, the source directory contains the target directory. */
	        target_contains_source,		/* If "1"b, the target_directory contains the source directory. */
	        safety_sw,				/* used in setting the safety_switch of a branch. */
	        same_dir,				/* se_name and te_name are in the same directory. */
	        move
	        )			        bit (1);	/* delete source_dir after copying */
	dcl     fs_util_type	        char (32);
	dcl     (entry_index, lcomp_count, scomp_count, tcomp_count, ii)
				        fixed bin;
	dcl     (dir1_uid, dir2_uid, uid)     bit (36) aligned;
	dcl     (sd_name, td_name, temp_target_dir)
                                                char (168);

	dcl     (se_name, le, userid, te_name)
				        char (32);
	dcl     (
	        area_ptr,				/* ptr on which area is based. */
	        cb_ptr,				/* ptr on which create_branch_info is based. */
	        lcomp_root,				/* Path info for link_target(lcomp). */
	        scomp_root,				/* Path info for source_dir. */
	        tcomp_root,				/* Path info for target_dir. */
	        cptr				/* Ptr on which comp is based. */
	        )			        ptr;

/*  External  */

	dcl     (
	        error_table_$action_not_performed,
	        error_table_$inconsistent,
                  error_table_$bad_ring_brackets,
	        error_table_$incorrect_access,
	        error_table_$no_dir,
	        error_table_$no_s_permission,
	        error_table_$not_seg_type,
	        error_table_$segnamedup,
	        error_table_$namedup,
	        error_table_$noentry,
	        error_table_$nomatch,
	        error_table_$notadir,
	        error_table_$sameseg,
	        error_table_$unimplemented_version
	        )			        fixed bin (35) external;

/*  Builtins  */

	dcl     (addr, index, null, reverse, rtrim, ptr, string, substr, sum)
				        builtin;


/**** ** Copy all the parameters into local variables. In the case of
      * the structure, this is unneccessary, but is convienient since this
      * did not used to be a seperate routine from the command. */

	cb_ptr = null ();
	acode = 0; /* must be initialized */

	on condition (cleanup)
	     begin;
		if cb_ptr ^= null ()
		then free cb_ptr -&gt; create_branch_info in (area);
	     end;

	if copy_dir_options.version ^= copy_dir_options_version_0
	then do;
		call sub_err_ (error_table_$unimplemented_version, ACTION_CANT_RESTART, null (), (0),
		     "copy_dir_ has been invoked with the wrong version of the copy_dir_options structure.
The version provided was ^d, the expected version is ^d.", copy_dir_options.version, copy_dir_options_version_0);
		return;
	     end;

	userid = get_group_id_$tag_star ();
	area_ptr = get_system_free_area_ ();
	move = copy_dir_options.delete;
	if ^(copy_dir_options.link | copy_dir_options.dir | copy_dir_options.seg | copy_dir_options.msf
	     | copy_dir_options.nnlk)
	then do;
		call complain (error_table_$action_not_performed, "^/No entries specified to be ^[copied^;moved^].",
		     (^copy_dir_options.delete));
		return;
	     end;
	if (copy_dir_options.link &amp; copy_dir_options.dir &amp; copy_dir_options.seg &amp; copy_dir_options.msf)
	then do;
		all_entries = "1"b;
		clink, cseg, cdir, cmsf, cnnl = "0"b;
	     end;
	else do;
		all_entries = "0"b;
		clink = copy_dir_options.link;
		cseg = copy_dir_options.seg;
		cdir = copy_dir_options.dir;
		cmsf = copy_dir_options.msf;
		cnnl = copy_dir_options.nnlk;
	     end;
	parent_access = copy_dir_options.parent_ac_sw;
	brief = copy_dir_options.brief;
	force = copy_dir_options.force;
	replace = copy_dir_options.replace;
	update = copy_dir_options.update;
	acl = copy_dir_options.acl;
	primary = copy_dir_options.primary;
	translate_links = copy_dir_options.link_translation;
	chase = copy_dir_options.chase;
	raw = copy_dir_options.raw;
	if (replace &amp; update)
	then do;
		call complain (error_table_$inconsistent, "^/Options replace and update specified.");
		return;
	     end;

	if primary
	then all_names = "0"b;
	else all_names = "1"b;


	allocate create_branch_info in (area) set (cb_ptr);
	cb_ptr -&gt; create_branch_info.version = create_branch_version_2;
	cb_ptr -&gt; create_branch_info.quota = 0;
	cb_ptr -&gt; create_branch_info.dir_quota = 0;
	cb_ptr -&gt; create_branch_info.mode = "111"b;
	cb_ptr -&gt; create_branch_info.switches.dir_sw = "1"b;
	cb_ptr -&gt; create_branch_info.switches.copy_sw = "0"b;
	cb_ptr -&gt; create_branch_info.switches.chase_sw = "1"b;
	cb_ptr -&gt; create_branch_info.switches.parent_ac_sw = parent_access;
	cb_ptr -&gt; create_branch_info.priv_upgrade_sw = "0"b;
	cb_ptr -&gt; create_branch_info.userid = userid;
	cb_ptr -&gt; create_branch_info.bitcnt = 0;

	sd_name = source_dir;			/* copy the name args to the "old" variables      */
	se_name = source_ename;			/* and proceed with existing code                 */
	td_name = target_dir;
	te_name = target_ename;

	if sd_name = td_name
	then same_dir = "1"b;
	else same_dir = (get_uid (sd_name) = get_uid (td_name));

/*  check that arg 1 is a directory. */
	call hcs_$status_minf (sd_name, se_name, 0, type, bc, code);
	if code ^= 0 &amp; code ^= error_table_$no_s_permission
	then do;
BAD_STAT:
		call complain (code, "^/Unable to get the status of ^a^[&gt;^]^a.", sd_name, sd_name ^= "&gt;", se_name);
		return;
	     end;

	if type ^= Directory | bc ^= 0
	then do;
NOT_A_DIR:
		call complain (error_table_$notadir,
		     "^/The source pathname must be a directory. ^a^[&gt;^]^a is not a directory", sd_name,
		     sd_name ^= "&gt;", se_name);
		return;
	     end;

	if ^raw
	then do;					/* check if it is an extended object */
		call fs_util_$get_type (sd_name, se_name, fs_util_type, code);
		if fs_util_type ^= FS_OBJECT_TYPE_DIRECTORY
		then goto NOT_A_DIR;
	     end;

	call hcs_$get_uid_file (sd_name, se_name, uid, code);
	if code ^= 0
	then goto BAD_STAT;

	dir1_uid = uid;

/* if the target doesn't exist, create it. If it does exist,
   but is not a directory, complain and get next entry. */

	call hcs_$status_minf (td_name, te_name, 0, type, bc, code);
	if code ^= 0
	then if code = error_table_$noentry
	     then do;
		     if ^brief
		     then call ioa_ ("^a: Creating target directory ^a.", whoami, pathname_ (td_name, te_name));

		     call create_directory;
		     if code ^= 0
		     then goto finish;
		end;
	     else do;
BAD_TSTAT:
		     call complain (code, "^/Unable to get the status of the target directory ^a^[&gt;^]^a.", td_name,
			td_name ^= "&gt;", te_name);
		     return;
		end;
	else if type ^= Directory | bc ^= 0
	then do;
T_NOT_DIR:
		call nd_handler_ (whoami, td_name, te_name, code);
		if code ^= 0
		then do;
			acode = code;
			return;
		     end;

		call create_directory;
		if code ^= 0
		then goto finish;
	     end;
	else do;					/*  target_dir exists */
		if ^raw
		then do;
			call fs_util_$get_type (td_name, te_name, fs_util_type, code);
			if fs_util_type ^= FS_OBJECT_TYPE_DIRECTORY
			then goto T_NOT_DIR;
		     end;

		call hcs_$get_uid_file (td_name, te_name, dir2_uid, code);
		if code ^= 0
		then go to BAD_TSTAT;

		if dir1_uid = dir2_uid
		then do;
			call complain (error_table_$action_not_performed,
			     "Attempt to specify the same directory as both old and new");
			return;
		     end;
		if ^(force | replace)
		then do;
			query_info.version = 1;
			query_info.yes_or_no_sw = "1"b;
			query_info.suppress_name_sw = "0"b;
			query_info.status_code = 0;
			query_info.query_code = 0;
			call command_query_ (addr (query_info), answer, whoami,
			     "^a^[&gt;^]^a  already exists.  Do you wish to continue?", td_name, td_name ^= "&gt;",
			     te_name);
			if query_info.status_code ^= 0
			then do;
				call complain (query_info.status_code, "^/Unable to use answer from query.");
				return;
			     end;
			if answer = "no"
			then goto finish;
		     end;

                                                          /* perform the containment check */
		call contains (source_contains_target, target_contains_source, code);
		if code ^= 0
		then do;
			call complain (code,
			     "^/Unable to check containment of source and target directories, ^a^[&gt;^]^a and ^a^[&gt;^]^a respectively.",
			     sd_name, sd_name ^= "&gt;", se_name, td_name, td_name ^= "&gt;", te_name);
			return;
		     end;

		if source_contains_target             /* the source directory contains the target directory */
		then do;
			call complain (error_table_$action_not_performed,
			     "^/The source directory cannot contain the target directory;^/^a contains ^a.",
			     pathname_ (sd_name, se_name), pathname_ (td_name, te_name));
			return;
		     end;

		if target_contains_source            /* the target directory contains the source directory */
		then do;
			call complain (error_table_$action_not_performed,
			     "^/The target directory cannot contain the source directory;^/^a contains ^a.",
			     pathname_ (td_name, te_name), pathname_ (sd_name, se_name));
			return;
		     end;

		if replace                             /* want to delete the contents of the specified existent target */
		then do;
		          string (delete_options) = ""b;
			delete_options.force = force;
			delete_options.question,
			delete_options.directory,
			delete_options.segment,
			delete_options.link = "1"b;
			delete_options.chase = chase;
			delete_options.library = "0"b;
			delete_options.raw = raw;

			temp_target_dir = pathname_ (td_name, te_name);

			star_entry_count = 0;        /* initialize variable declared in star_structures.incl.pl1 */
			star_entry_ptr = null;       /* initialize variable declared in star_structures.incl.pl1 */
			star_names_ptr = null;       /* initialize variabel declared in start_structures.incl.pl1 */

                                                           /* get information on all entries in the specified existent target */
			call hcs_$star_ (temp_target_dir, "**", star_ALL_ENTRIES, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code);
			if code ^= 0 then do;
                                                            /* if the existent target is empty (star_entry_count = 0), then keep going */
			     if code ^= error_table_$nomatch then do;
				call complain (code, "Unable to return information on all entries in target directory ^a.", temp_target_dir);
				return;
			     end;
			end;

                                                            /* delete all entries in the specified existent target */
			do entry_index = 1 to star_entry_count;
			     call delete_$path (temp_target_dir, star_names (entry_index), string (delete_options), whoami, code);
			     if code ^= 0 &amp; code ^= error_table_$bad_ring_brackets
			     then do;
				call complain (code, "^/Unable to delete the entryname ^a in the directory ^a.",
				     rtrim (star_names (entry_index)), rtrim (temp_target_dir));
				return;
			     end;
			end;                          /* make the specified existent target directory become empty */
		     end;				/* want to delete the contents of a specified existent directory */
	     end;                                         /* case the specified target directory exists */

	errors = "0"b;				/* start fresh */

	call hcs_$get_safety_sw (sd_name, se_name, safety_sw, code);
	if code ^= 0
	then call complain (code, "^/Unable to get the safety switch for the source directory ^a^[&gt;^]^a.", sd_name,
		sd_name ^= "&gt;", se_name);
	else do;
		call hcs_$set_safety_sw (td_name, te_name, safety_sw, code);
		if code ^= 0
		then call complain (code, "^/Unable to set the safety switch on the target directory ^a^[&gt;^]^a.",
			td_name, td_name ^= "&gt;", te_name);
	     end;

	call copy_iacl_ (sd_name, se_name, td_name, te_name, ersw, code);
	if code ^= 0
	then call complain (code,
		"^/Unable to copy the initial ACL from the source directory ^a^[&gt;^]^a to the target directory ^a^[&gt;^]^a.
Error occurred on the ^[source^;target^] directory.",
		sd_name, sd_name ^= "&gt;", se_name, td_name, td_name ^= "&gt;", te_name, ^ersw);

	cpo.version = COPY_OPTIONS_VERSION_1;
	cpo.caller_name = "copy_dir_";

/* Now call the recursive procedure which does the actual copying */

	call work (sd_name, se_name, td_name, te_name, acl, move);

	if acl | move
	then do;
		call copy_acl_ (sd_name, se_name, td_name, te_name, ersw, code);
		if code ^= 0
		then call complain (code, "^/Unable to copy the ACL from  ^a^[&gt;^]^a to  ^a^[&gt;^]^a.
Error occurred on the ^[source^;target^].", sd_name, sd_name ^= "&gt;", se_name, td_name, td_name ^= "&gt;", te_name, ^ersw);

	     end;
	if all_names
	then do;
		if same_dir
		then call move_names_ (sd_name, se_name, td_name, te_name, whoami, ersw, code);

		else call copy_names_ (sd_name, se_name, td_name, te_name, whoami, ersw, code);
		if code ^= 0
		then if code ^= error_table_$segnamedup
		     then if code ^= error_table_$namedup
			then call complain (code, "^/Unable to ^[move^;copy^] names of ^a^[&gt;^]^a to  ^a^[&gt;^]^a.
Error occurred on the ^[source^;target^].", same_dir, sd_name, (sd_name ^= "&gt;"), se_name, td_name, td_name ^= "&gt;",
				te_name, ^ersw);
	     end;
	if move
	then if errors
	     then do;
		     if ^brief
		     then call com_err_ (error_table_$action_not_performed, whoami,
			     "Source directory not deleted due to error in copying.");
		     if acode = 0
		     then acode = error_table_$action_not_performed;
						/* tell caller something!                         */
		end;
	     else do;
		     string (delete_options) = ""b;
		     delete_options.question, delete_options.directory = "1"b;
		     delete_options.raw = raw;
		     call delete_$path (sd_name, se_name, string (delete_options), whoami, code);
		     if code ^= 0
		     then call complain (code, "^/Unable to delete ^a^[&gt;^]^a.", sd_name, (sd_name ^= "&gt;"), se_name);
		end;
finish:
	if cb_ptr ^= null ()
	then free cb_ptr -&gt; create_branch_info in (area);
	return;
%page;
/* The directory tree is recursively followed, copying the links,
   files, and directories along the way. If a copy fails for any
   reason on a particular entry,processing continues with the next one
   and nothing is done with the failed entry. */

work:
     proc (d1, e1, d2, e2, acl, move) recursive;
	dcl     i			        fixed bin;
	dcl     (from_dir, to_dir)	        char (168);
	dcl     name		        char (32);
	dcl     names		        (500) char (32) aligned based (nptr);
						/* info from hcs_$star_ */
	dcl     nptr		        ptr;
	dcl     1 branches		        (entry_count) aligned based (sptr),
						/* info from hcs_$star_ */
	        ( 2 type		        bit (2),
		2 nnames		        fixed bin (15),
		2 nindex		        fixed bin (17)
		)		        unaligned;
	dcl     (d1, d2, e1, e2)	        char (*);
          dcl     (acl, move)                   bit (1);    /* save these flags for later reference in the "file" procedure. */
	dcl     sptr		        ptr;
	dcl     entry_count		        fixed bin;

/* construct directory pathnames */
	call ioa_$rsnnl ("^a^[&gt;^]^a", from_dir, ln, d1, (d1 ^= "&gt;"), e1);
	call ioa_$rsnnl ("^a^[&gt;^]^a", to_dir, ln, d2, (d2 ^= "&gt;"), e2);

/* set up cleanup handler */
	on condition (cleanup)
	     begin;
		if sptr ^= null
		then free branches in (area);
		if nptr ^= null
		then free nptr -&gt; names in (area);
	     end;

/* get all of the entries in from_dir */

	call hcs_$star_ (from_dir, "**", 3, area_ptr, entry_count, sptr, nptr, code);
	if code ^= 0
	then if code = error_table_$nomatch
	     then goto finish_work;
	     else do;

		     call complain (code, "^/Unable to get the entries in the directory ^a.", from_dir);
		     return;
		end;

/* call appropriate entry copier */

	do i = 1 to entry_count;
	     name = names (branches (i).nindex);
	     if branches (i).type = "00"b
	     then do;
		     if (all_entries | clink | cnnl)
		     then call link;
		end;
	     else if branches (i).type = "01"b
	     then do;
FILE:
		     if (all_entries | cseg)
		     then call file (from_dir, name, to_dir, name, acl, move);
		end;
	     else if branches (i).type = "10"b
	     then do;
		     if ^raw
		     then do;
			     call fs_util_$get_type (from_dir, name, fs_util_type, code);
			     if code ^= error_table_$not_seg_type &amp; substr (fs_util_type, 1, 1) ^= "-"
			     then goto FILE;
			end;

		     call hcs_$status_minf (from_dir, name, 1, tt, bc, code);
		     if code ^= 0
		     then do;
			     call complain (code, "^/Unable to get status on the file  ^a^[&gt;^]^a.", from_dir,
				from_dir ^= "&gt;", name);
			     return;
			end;
		     if bc ^= 0
		     then do;
			     if (all_entries | cmsf)
			     then call file (from_dir, name, to_dir, name, acl, move);
			end;
		     else do;
			     if (all_entries | cdir)
			     then call directory;
			end;
		end;
	     else do;
		     call complain (0, "Illegal branch type ""11""b ^a^[&gt;^]^a", from_dir, from_dir ^= "&gt;", name);
		     return;			/* tell caller something                          */
		end;
	end;

finish_work:
	if sptr ^= null
	then free sptr -&gt; branches in (area);
	if nptr ^= null
	then free nptr -&gt; names in (area);

	return;					/* Effective end of work. */

link:
     proc;
	dcl     pptr		        ptr;
	dcl     1 links		        aligned like status_link;
	dcl     pathname		        char (links.pathname_length) aligned based (pptr);
	dcl     (link_target, new_target, ld) char (168);

	call hcs_$status_ (from_dir, name, 0, addr (links), area_ptr, code);
	if code ^= 0
	then do;
		call complain (code, "^/Unable to get detailed status on the link ^a^[&gt;^]^a.", from_dir,
		     from_dir ^= "&gt;", name);
		return;
	     end;

	pptr = ptr (area_ptr, links.names_relp);
	free pptr -&gt; names in (area);

	pptr = ptr (area_ptr, links.pathname_relp);

	link_target = pathname;

	call expand_pathname_ (link_target, ld, le, code);
	if code ^= 0
	then do;
		call complain (code, "^/Unable to expand the target pathname ^a for the link ^a^[&gt;^]^a.", link_target,
		     from_dir, from_dir ^= "&gt;", name);
		return;
	     end;
	if translate_links
	then do;
		call contains_target (ld, le, new_target, code);
		if code = 0
		then link_target = new_target;
		else if code = no_translation
		then code = 0;
		else do;
			call complain (code,
			     "^/Unable to analyze  ^a^[&gt;^]^a for containment in the target directory.", ld,
			     ld ^= "&gt;", le);
			return;
		     end;
	     end;
	free pptr -&gt; pathname in (area);

	if chase
	then do;
		call hcs_$get_link_target (ld, le, ld, le, code);
		if code ^= 0
		then if code = error_table_$noentry | code = error_table_$no_dir
		     then do;
			     if clink
			     then goto append_link;
			     return;
			end;
		     else do;
			     call complain (code,
				"^/Unable to get the link target of  ^a^[&gt;^]^a, with target pathname of  ^a^[&gt;^]^a.",
				from_dir, (from_dir ^= "&gt;"), name, ld, ld ^= "&gt;", le);
			     return;
			end;
		call hcs_$status_minf (ld, le, 0, tt, bc, code);
		if code ^= 0
		then if code = error_table_$noentry | code = error_table_$no_dir
		     then do;
			     if clink
			     then goto append_link;
			     return;
			end;
		     else do;
			     call complain (code,
				"^/Unable to get status on  ^a^[&gt;^]^a, the link target of  ^a^[&gt;^]^a.", ld,
				ld ^= "&gt;", le, from_dir, from_dir ^= "&gt;", name);
			     return;
			end;

		if ^raw
		then do;
			call fs_util_$get_type (ld, le, fs_util_type, code);
			if code ^= error_table_$not_seg_type &amp; substr (fs_util_type, 1, 1) ^= "-"
						/* if it is an extended object, or if it dont exist */
			then tt = 1;
		     end;

		if (tt = 1 &amp; (cseg | all_entries)) | (tt = 2 &amp; bc ^= 0 &amp; (cmsf | all_entries))
		then call file (ld, le, to_dir, name, acl, move);
		else if (tt = 2 &amp; bc = 0 &amp; (cdir | all_entries))
		then goto append_link;
		else return;
	     end;
	else do;
		if cnnl
		then do;
			call hcs_$status_minf (ld, le, 1, tt, bc, code);
			if code ^= 0
			then if code = error_table_$noentry | code = error_table_$no_dir
			     then return;
			     else do;
				     call complain (code,
					"^/Unable to get status on ^a^[&gt;^]^a, the link target of  ^a^[&gt;^]^a.",
					ld, ld ^= "&gt;", le, from_dir, from_dir ^= "&gt;", name);
				     return;
				end;
		     end;
append_link:
		call hcs_$append_link (to_dir, name, link_target, code);
		if code ^= 0
		then if code = error_table_$namedup
		     then do;
			     string (nd_handler_options) = ""b;
			     nd_handler_options.raw = raw;
			     nd_handler_options.delete_force = update;
			     call nd_handler_$switches (whoami, to_dir, name, string (nd_handler_options), code1);
			     if code1 = 0
			     then goto append_link;
			     else if code1 = error_table_$action_not_performed
			     then return;
			     else do;
				     acode = code1;
				     errors = "1"b;
				     return;
				end;
			end;
		     else do;
			     call complain (code,
				"^/Unable to copy  from ^a^[&gt;^]^a to ^a^[&gt;^]^a. Error occurred on the ^[source^;target^].",
				from_dir, (from_dir ^= "&gt;"), name, to_dir, (to_dir ^= "&gt;"), name, ^ersw);
			     return;
			end;

		call copy_names_ (from_dir, name, to_dir, name, whoami, ersw, code);
		if code ^= 0 &amp; code ^= error_table_$segnamedup &amp; code ^= error_table_$namedup
		then do;
			call complain (code, "^/Unable to copy the names from ^a^[&gt;^]^a to ^a^[&gt;^]^a.
Error occurred on the ^[source^;target^] entry.", from_dir, from_dir ^= "&gt;", name, to_dir, to_dir ^= "&gt;", name, ^ersw);
			return;
		     end;
	     end;
     end link;
%page;
file:
     proc (from_dir, from_en, to_dir, to_en, acl, move);

	dcl     (from_dir, from_en, to_dir, to_en)
				        char (*);
          dcl     (acl, move)                   bit (1); /* They are originally received from the "copy_dir_" procedure. */

	dcl     1 local_suffix_info	        aligned like suffix_info;

	cpo.source_dir = from_dir;
	cpo.source_name = from_en;
	cpo.target_dir = to_dir;
	cpo.target_name = to_en;

	string (cpo.flags) = ""b;
	cpo.raw = raw;
	cpo.no_name_dup = update;

	string (cpo.copy_items) = ""b;
	cpo.names = all_names;
	cpo.acl = acl | move;

	local_suffix_info.version = SUFFIX_INFO_VERSION_1;

	call fs_util_$suffix_info (from_dir, from_en, addr (local_suffix_info), code);
	if code ^= 0
	then do;
		call complain (code, "^/Unable to get the suffix_info for ^a.", pathname_ (from_dir, from_en));
		return;
	     end;

	if tt = 1
	then do;
		cpo.max_length = local_suffix_info.copy_flags.max_length;
		cpo.dumper_switches = local_suffix_info.copy_flags.dumper_switches;
	     end;
	cpo.safety_switch = local_suffix_info.copy_flags.safety_switch;

	on sub_error_ call sub_err_handler ();

	call copy_ (addr (cpo));

PUNT_FILE:
	return;
%page;
sub_err_handler:
     proc ();

	ci.version = condition_info_version_1;
	call find_condition_info_ (null (), addr (ci), (0));
	sub_error_info_ptr = ci.info_ptr;

	if sub_error_info.name ^= "copy_" | copy_error_info.copy_options_ptr ^= addr (cpo)
	then do;
		call continue_to_signal_ ((0));
		return;
	     end;

	code = sub_error_info.status_code;

	call complain (code,
	     "^[^a^/^-^;^s^]^[Copying^;Unable to copy^] from ^a to ^a. Error occurred on the ^[target^;source^].",
	     sub_error_info.info_string ^= "", sub_error_info.info_string, sub_error_info.default_restart,
	     pathname_ (from_dir, from_en), pathname_ (to_dir, to_en), copy_error_info.target_err_switch);

	if sub_error_info.cant_restart
	then goto PUNT_FILE;

	return;
     end sub_err_handler;

     end file;
%page;
directory:
     proc;

	call hcs_$status_minf (to_dir, name, 1, tt, bc, code);
	if code ^= 0
	then do;
		tt = 0;
		call hcs_$get_dir_ring_brackets (from_dir, name, dir_rings, code);
		if code ^= 0
		then do;
			call complain (code, "^/Unable to get the directory ring brackets of ^a^[&gt;^]^a.", from_dir,
			     (from_dir ^= "&gt;"), name);
			return;
		     end;
	     end;
	else if tt ^= 2
	then do;
		call nd_handler_ (whoami, to_dir, name, code);
		if code ^= 0
		then if code = error_table_$action_not_performed
		     then return;
		     else do;
			     errors = "1"b;
			     acode = code;
			     return;
			end;

		call hcs_$get_dir_ring_brackets (from_dir, name, dir_rings, code);
		if code ^= 0
		then do;
			call complain (code, "^/Unable to get the directory ring brackets of ^a^[&gt;^]^a.", from_dir,
			     (from_dir ^= "&gt;"), name);
			return;
		     end;

	     end;
	if tt ^= 2
	then do;
		cb_ptr -&gt; create_branch_info.rings (1) = dir_rings (1);
		cb_ptr -&gt; create_branch_info.rings (2) = dir_rings (2);
		cb_ptr -&gt; create_branch_info.rings (3) = 7;
		call hcs_$get_access_class (from_dir, name, cb_ptr -&gt; create_branch_info.access_class, code);
		if code ^= 0
		then do;
			call complain (code, "^/Unable to get the access class of  ^a^[&gt;^]^a.", from_dir,
			     (from_dir ^= "&gt;"), name);
			return;
		     end;

		cb_ptr -&gt; create_branch_info.switches.dir_sw = "1"b;
		cb_ptr -&gt; create_branch_info.switches.copy_sw = "0"b;
		cb_ptr -&gt; create_branch_info.switches.chase_sw = "1"b;
		cb_ptr -&gt; create_branch_info.mode = "111"b;
		call hcs_$create_branch_ (to_dir, name, cb_ptr, code);
		if code ^= 0
		then do;
			call complain (code, "^/Unable to create the directory branch ^a^[&gt;^]^a.", to_dir,
			     (to_dir ^= "&gt;"), name);
			return;
		     end;

	     end;

	if all_names
	then do;
		call copy_names_ (from_dir, name, to_dir, name, whoami, ersw, code);
		if code ^= 0 &amp; code ^= error_table_$segnamedup &amp; code ^= error_table_$namedup
		then call complain (code,
			"^/Unable to copy the names from ^a^[&gt;^]^a to ^a^[&gt;^]^a. Error occurred on the ^[source^;target^].",
			from_dir, (from_dir ^= "&gt;"), name, to_dir, (to_dir ^= "&gt;"), name, ^ersw);
	     end;

	call hcs_$get_safety_sw (from_dir, name, safety_sw, code);
	if code ^= 0
	then call complain (code, "^/Unable to get the safety_switch of ^a^[&gt;^]^a.", from_dir, (from_dir ^= "&gt;"), name);
	else do;
		call hcs_$set_safety_sw (to_dir, name, safety_sw, code);
		if code ^= 0
		then call complain (code, "^/Unable to set the safety switch of ^a^[&gt;^]^a.", to_dir, (to_dir ^= "&gt;"),
			name);
	     end;


	call copy_iacl_ (from_dir, name, to_dir, name, ersw, code);
	if code ^= 0
	then call complain (code,
		"^/Unable to copy the initial ACL from ^a^[&gt;^]^a to ^a^[&gt;^]^a. Error occurred on the ^[source^;target^].",
		from_dir, from_dir ^= "&gt;", name, to_dir, to_dir ^= "&gt;", name, ^ersw);

	call work (from_dir, name, to_dir, name, acl, move);

	if acl | move
	then do;
		call copy_acl_ (from_dir, name, to_dir, name, ersw, code);
		if code ^= 0
		then call complain (code,
			"^/Unable to copy ACL from ^a^[&gt;^]^a to ^a^[&gt;^]^a. Error occurred on the ^[source^;target^].",
			from_dir, from_dir ^= "&gt;", name, to_dir, to_dir ^= "&gt;", name, ^ersw);
	     end;
     end directory;
     end work;

create_directory:
     proc;
          code = 0;

	call hcs_$get_dir_ring_brackets (sd_name, se_name, dir_rings, code);
	if code ^= 0
	then do;
		if code = error_table_$no_s_permission | code = error_table_$incorrect_access
		then do;
			cb_ptr -&gt; create_branch_info.rings (1) = get_ring_ ();
			cb_ptr -&gt; create_branch_info.rings (2) = cb_ptr -&gt; create_branch_info.rings (1);
			cb_ptr -&gt; create_branch_info.rings (3) = 7;
		     end;
		else do;
			call complain (code, "^/Unable to get the directory ring brackets of ^a^[&gt;^]^a.", sd_name,
			     sd_name ^= "&gt;", se_name);
			return;
		     end;
	     end;
	else do;
		cb_ptr -&gt; create_branch_info.rings (1) = dir_rings (1);
		cb_ptr -&gt; create_branch_info.rings (2) = dir_rings (2);
		cb_ptr -&gt; create_branch_info.rings (3) = 7;
	     end;
	call hcs_$get_access_class (sd_name, se_name, cb_ptr -&gt; create_branch_info.access_class, code);
	if code ^= 0
	then do;
		if code = error_table_$no_s_permission | code = error_table_$incorrect_access
		then cb_ptr -&gt; create_branch_info.access_class = get_max_authorization_ ();
		else do;
			call complain (code, "^/Unable to get access class for ^a^[&gt;^]^a.", sd_name, sd_name ^= "&gt;",
			     se_name);
			return;
		     end;
	     end;
	call hcs_$create_branch_ (td_name, te_name, cb_ptr, code);
	if code ^= 0
	then do;
		call complain (code, "^/Unable to create the branch ^a^[&gt;^]^a.", td_name, td_name ^= "&gt;", te_name);
		return;
	     end;
	call hcs_$get_uid_file (td_name, te_name, dir2_uid, code);
	if code ^= 0
	then do;
		call complain (code, "^/Unable to get uid of the target directory  ^a^[&gt;^]^a.", td_name,
		     td_name ^= "&gt;", te_name);
		return;
	     end;

	call contains (source_contains_target, target_contains_source, code);
	if code ^= 0
	then do;
		call complain (code, "^/Unable to check containment of source and target directories,
^a^[&gt;^]^a and ^a^[&gt;^]^a respectively.", sd_name, sd_name ^= "&gt;", se_name, td_name, td_name ^= "&gt;", te_name);
		return;
	     end;

	if source_contains_target             /* the source directory contains the target directory */
	then do;
	     call complain (error_table_$action_not_performed,
		"^/The source directory cannot contain the target directory;^/^a contains ^a.", pathname_ (sd_name, se_name),
		pathname_ (td_name, te_name));
                                                /* indicate that error has been found */
	     code = error_table_$action_not_performed;

	     return;
	     end;

	if target_contains_source            /* the target directory contains the source directory */
	then do;
	     call complain (error_table_$action_not_performed,
		"^/The target directory cannot contain the source directory;^/^a contains ^a.", pathname_ (td_name, te_name),
		pathname_ (sd_name, se_name));
                                               /* indicate that an error has been found */
	     code = error_table_$action_not_performed;

	     return;
	     end;

	return;

     end create_directory;

contains:
     proc (p_source_contains_target, p_target_contains_source, code);

/* check of target_dir in source_dir and vice-versa. */

	dcl     (dir1, dir2)	        char (168);
	dcl     (en1, en2)		        char (32);
	dcl     p_source_contains_target      bit (1);
	dcl     p_target_contains_source      bit (1);
	dcl     code		        fixed bin (35);

          code = 0;
	p_source_contains_target = "0"b;
	p_target_contains_source = "0"b;

	call hcs_$get_link_target (sd_name, se_name, dir1, en1, code);
	if code ^= 0
	then return;

	call hcs_$get_link_target (td_name, te_name, dir2, en2, code);
	if code ^= 0
	then return;

	call path_info (dir1, en1, scomp_count, scomp_root, code);
	if code ^= 0
	then return;

	if dir1 = dir2 &amp; en1 = en2
	then do;
	     code = error_table_$sameseg;
	     p_target_contains_source = "1"b;
	     p_source_contains_target = "1"b;
	     end;
	else do;
	     call path_info (dir2, en2, tcomp_count, tcomp_root, code);
	     if code ^= 0
		then return;

	     if scomp_count = tcomp_count
		then return;

	     else if scomp_count &gt; tcomp_count
		then do;
		     call csub (scomp_root, tcomp_count, uid, code);
		     if code ^= 0
			then return;

		     if uid = dir2_uid
		     then p_source_contains_target = "1"b;
		     end;

	     else do;                             /* for example: source and target pathnames are "&gt;udd&gt;m&gt;x" and "&gt;udd&gt;m&gt;x&gt;y", respectively */
		call csub (tcomp_root, scomp_count, uid, code);
		if code ^= 0
		     then return;

		if uid = dir1_uid
		     then p_target_contains_source = "1"b;
		end;
	end;
%page;
csub:
     proc (p_root, p_count, p_uid, p_code);

	dcl     (p, p_root)		        ptr;
	dcl     (code, p_code)	        fixed bin (35);
	dcl     dir		        char (128);
	dcl     en		        char (32);
	dcl     p_count		        fixed bin;
	dcl     comp_index		        fixed bin;
	dcl     p_uid		        bit (36) aligned;

	dir = "";
	p = p_root;
	p_code = 0;

	if p_count = 1
	then dir = "&gt;";
	else do comp_index = 1 to p_count - 1;
		dir = rtrim (dir) || "&gt;" || p -&gt; comp.name;
		p = p -&gt; comp.next;
	     end;

	en = p -&gt; comp.name;
	call hcs_$get_uid_file (dir, en, p_uid, code);
	if code ^= 0
	then p_code = code;

     end;
     end;
path_info:
     proc (d, e, count, root, code);

/* Turn pathname into threaded list of component names. */

	dcl     code		        fixed bin (35);
	dcl     (d, e)		        char (*);
	dcl     count		        fixed bin;
	dcl     optr		        ptr;
	dcl     dirstr		        char (168);
	dcl     root		        ptr;
	count = 0;
	if d = "&gt;"
	then dirstr = reverse ("&gt;" || rtrim (e));
	else dirstr = reverse (rtrim (d) || "&gt;" || rtrim (e));
	ii = index (dirstr, "&gt;");
	cptr = null;

	optr = null;
	do while (ii &gt; 1);
	     alloc comp in (area);
	     comp.name = reverse (substr (dirstr, 1, ii - 1));
	     comp.next = optr;
	     optr = cptr;
	     dirstr = substr (dirstr, ii + 1);
	     count = count + 1;
	     ii = index (dirstr, "&gt;");
	end;

	root = cptr;
     end;						/*						*/
						/* containment subroutine for the link copier. */

contains_target:
     proc (ld, le, new_target, code) recursive;

/* Check whether source link's target pathname is contained in the source
   directory and if so, translate the link target pathname to a pathname in the
   target directory.  Only the components of the target pathname which are
   target directory.  Only the components of the target pathname which are
   be used in the check.  If one of the components being checked is a link, contains_target
   is re-called with the new link target pathname and the unprocessed portion of the
   old one. */

	dcl     i			        fixed bin;
	dcl     en		        char (32);
	dcl     dir		        char (168);
	dcl     new_target		        char (168);
	dcl     p			        ptr;
	dcl     (ld, le)		        char (*);
	dcl     code		        fixed bin (35);
	dcl     uid		        bit (36) aligned;

	call path_info (ld, le, lcomp_count, lcomp_root, code);
	if code ^= 0
	then goto finish;

	if lcomp_count &lt; scomp_count
	then do;
		code = no_translation;
		return;
	     end;

	p = lcomp_root;
	dir = "";

/* Catenate the 2nd through lcomp_count'th components, checking at each one
   for links or matching with unique id's. */

	do i = 1 to lcomp_count - 1;
	     dir = rtrim (dir) || "&gt;" || p -&gt; comp.name;
	     p = p -&gt; comp.next;
	     en = p -&gt; comp.name;
	     call hcs_$status_minf (dir, en, 0, type, (0), code);
	     if code ^= 0
	     then if code = error_table_$noentry | code = error_table_$no_dir
						/*  The part of the link target pathname which is non-null is not
						   contained in source_dir.  Therefore, don't translate the link. */
		then do;
			code = no_translation;
			return;
		     end;
		else do;
			code = no_translation;
			goto check_dir_level;
		     end;
	     if type = Link
	     then do;
		     code = no_translation;
		     return;
		end;
	     else if type ^= Directory
	     then do;
		     if i &lt;= scomp_count - 1
		     then do;
			     code = no_translation;
			     return;
			end;
		end;
	     else
check_dir_level:
		call hcs_$get_uid_file (dir, en, uid, code);
	     if code ^= 0
	     then do;
		     code = no_translation;
		     return;
		end;

	     if i = scomp_count - 1
	     then if dir1_uid ^= uid
		then do;
			code = no_translation;
			return;
		     end;
		else do;
			call ioa_$rsnnl ("^a^[&gt;^]^a", new_target, ln, td_name, (td_name ^= "&gt;"), te_name);
			p = p -&gt; comp.next;
			do while (p ^= null);
			     new_target = rtrim (new_target) || "&gt;" || p -&gt; comp.name;
			     p = p -&gt; comp.next;
			end;
			code = 0;
			return;
		     end;
next_comp:
	end;
	new_target = rtrim (new_target) || "&gt;" || rtrim (le);

	return;
     end contains_target;

get_uid:
     proc (p_path) returns (bit (36));
	dcl     p_path		        char (168);
	dcl     dir		        char (168);
	dcl     entry		        char (32);
	dcl     code		        fixed bin (35);
	dcl     uid		        bit (36) aligned;

	call expand_pathname_ (p_path, dir, entry, code);
	if code ^= 0
	then return ("0"b);

	call hcs_$get_uid_file (dir, entry, uid, code);
	if code ^= 0
	then return ("0"b);

	return (uid);

     end get_uid;
%page;
complain:
     proc () options (variable);
	dcl     p_code		        fixed bin (35) based (argp);
	dcl     argp		        ptr;
	dcl     argl		        fixed bin (21);
	dcl     nargs		        fixed bin;
	dcl     arg_list_ptr	        ptr;
	dcl     error_message	        char (512);
	dcl     error_message_length	        fixed bin;

	call cu_$arg_ptr (1, argp, argl, 0);
	if ^brief
	then do;
		call cu_$arg_count (nargs, 0);
		if nargs &gt; 1
		then do;
			call cu_$arg_list_ptr (arg_list_ptr);
			call ioa_$general_rs (arg_list_ptr, 2, 3, error_message, error_message_length, "0"b, "0"b);
			call com_err_ (p_code, whoami, substr (error_message, 1, error_message_length));
		     end;
		else call com_err_ (p_code, whoami);
	     end;
	errors = "1"b;
	acode = p_code;
     end complain;

/* format: off */
%page; %include suffix_info;
%include copy_flags;
%page; %include create_branch_info;
%page; %include query_info_;
%page; %include status_structures;
%page; %include copy_dir_options;
%page; %include copy_options;
declare   1 cpo                         aligned like copy_options;
%page; %include delete_options;
%include nd_handler_options;
%page; %include copy_error_info;
%include sub_error_info;
%include condition_info_header;
%include condition_info;
declare   1 ci                          aligned like condition_info;
%include sub_err_flags;
%include star_structures;

     end copy_dir_;
���



		    copy_iacl_.pl1                  10/25/83  1546.8r w 10/25/83  1444.6       42588



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



/* Copy segment and/or directory IACL from one directory to another */

/* Rewritten: 23 January 1981 by G.  Palter to not add *.SysDaemon.* term to the new IACL if not present in the original
	       and to use the system free area rather than an automatic one */


copy_iacl_:
     procedure (source_dirname, source_ename, target_dirname, target_ename, error_on_target, code);


/* Parameters */

dcl  source_dirname character (*) parameter;		/* dir/entry of directory whose IACL is copied */
dcl  source_ename character (*) parameter;

dcl  target_dirname character (*) parameter;		/* dir/entry of directory to receive the IACL */
dcl  target_ename character (*) parameter;

dcl  error_on_target bit (1) aligned parameter;		/* ON =&gt; error occurred adding IACL to target;
						   OFF =&gt; error occured adding getting IACL from source */

dcl  code fixed binary (35) parameter;


/* Remaining declarations */

dcl 1 segment_acl (acl_count) aligned based (acl_ptr),
    2 access_name character (32),
    2 modes bit (36),
    2 extended_modes bit (36),
    2 status_code fixed binary (35);

dcl 1 directory_acl (acl_count) based (acl_ptr),
    2 access_name character (32),
    2 dir_modes bit (36),
    2 status_code fixed binary (35);

dcl  acl_ptr pointer;
dcl  acl_count fixed binary;

dcl  ring fixed binary (3);

dcl  directory_iacl bit (1) aligned;

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  get_ring_ entry () returns (fixed binary (3));
dcl  get_system_free_area_ entry () returns (pointer);
dcl (hcs_$list_inacl, hcs_$list_dir_inacl)
	entry (character (*), character (*), pointer, pointer, pointer, fixed binary, fixed binary (3), fixed binary (35));
dcl (hcs_$replace_dir_inacl, hcs_$replace_inacl)
	entry (character (*), character (*), pointer, fixed binary, bit(1) aligned, fixed binary (3), fixed binary (35));

dcl  cleanup condition;

dcl  null builtin;
%page;
/* Copy both the segment and directory IACLs */

	system_area_ptr = get_system_free_area_ ();
	ring = get_ring_ ();

	acl_ptr = null ();				/* for cleanup handler */
	on condition (cleanup)
	     begin;
		if acl_ptr ^= null () then
		     if directory_iacl then
			free directory_acl in (system_area);
		     else free segment_acl in (system_area);
	     end;

	directory_iacl = "0"b;
	call copy_seg_iacl ();
	     if code ^= 0 then return;		/* couldn't do it */

	directory_iacl = "1"b;
	call copy_dir_iacl ();

	return;



/* Copy the segment IACL only */

seg: entry (source_dirname, source_ename, target_dirname, target_ename, error_on_target, code);

	system_area_ptr = get_system_free_area_ ();
	ring = get_ring_ ();

	acl_ptr = null ();
	on condition (cleanup)
	     begin;
		if acl_ptr ^= null () then
		     free segment_acl in (system_area);
	     end;

	call copy_seg_iacl ();

	return;



/* Copy the directory IACL only */

dir: entry (source_dirname, source_ename, target_dirname, target_ename, error_on_target, code);

	system_area_ptr = get_system_free_area_ ();
	ring = get_ring_ ();

	acl_ptr = null ();
	on condition (cleanup)
	     begin;
		if acl_ptr ^= null () then
		     free directory_acl in (system_area);
	     end;

	call copy_dir_iacl ();

	return;
%page;
/* Copy the segment IACL */

copy_seg_iacl:
	procedure ();

	     error_on_target = "0"b;
	     call hcs_$list_inacl (source_dirname, source_ename, system_area_ptr, acl_ptr, null (), acl_count, ring, code);
		if code ^= 0 then return;		/* assume nothing was allocated */

	     error_on_target = "1"b;
	     call hcs_$replace_inacl (target_dirname, target_ename, acl_ptr, acl_count, "1"b, ring, code);

	     free segment_acl in (system_area);		/* get rid of it */

	     return;

	end copy_seg_iacl;



/* Copy the directory IACL */

copy_dir_iacl:
	procedure ();

	     error_on_target = "0"b;
	     call hcs_$list_dir_inacl (source_dirname, source_ename, system_area_ptr, acl_ptr, null (), acl_count,
				 ring, code);
		if code ^= 0 then return;		/* assume nothing allocated */

	     error_on_target = "1"b;
	     call hcs_$replace_dir_inacl (target_dirname, target_ename, acl_ptr, acl_count, "1"b, ring, code);

	     free directory_acl in (system_area);

	     return;

	end copy_dir_iacl;

     end copy_iacl_;




		    copy_names.pl1                  03/21/84  1044.0r   03/21/84  1043.0       60111



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */




/* format: style2,idind30,indcomtxt */


copy_names:
     procedure options (variable);

/**** * The commands copy_names and move_names copy and move all
      the additional names from one designated segment to another.
      copy_names also copies the designated name. Name duplication
      within a directory is handled in the accepted manner.
      Any number of pairs of arguments is allowed and the = convention
      is followed in the second argument of a pair. */

/* Karolyn Martin 5/30/69 */
/* modified by M. Weaver 9 April 1970 6:35 PM -- recoded into PL/I */
/* last modified by M. Weaver 31 December 1970 */
/* modified 6/3/75 by S. Herbst: command names changed to copy_names and move_names */
/* TR7429 Changed to reject starnames 10/30/80 S. Herbst */
/* Housecleaned, but not entirely, J Pattin and BIM 83-(8, 9, 10) */
/* Allow star names in first argument. C Spitzer 12/20/83 */

	dcl     arg		        char (lng) based (ap);

	dcl     (copy, errsw)	        bit (1) aligned;
	dcl     (i, j, n)		        fixed bin (17);
	dcl     lng		        fixed bin (21);
	dcl     areap		        ptr;
	dcl     myarea		        area based (areap);
	dcl     bitcnt		        fixed bin (24);
	dcl     code		        fixed bin (35);
	dcl     (dir1, dir2)	        char (168);
	dcl     (en1, en2, qent)	        char (32);
	dcl     cleanup		        condition;
	dcl     (null, sum)		        builtin;
	dcl     stars		        bit (1) aligned;
	dcl     ap		        ptr;
	dcl     whoami		        char (32);
	dcl     type		        fixed bin (2);
	dcl     cu_$arg_ptr		        entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     check_star_name_$entry        entry (character (*), fixed binary (35));
	dcl     expand_pathname_	        entry (character (*), character (*), character (*), fixed binary (35));
	dcl     (
	        com_err_,
	        com_err_$suppress_name
	        )			        ext entry options (variable);
	dcl     error_table_$namedup	        external fixed bin (35);
	dcl     error_table_$segnamedup       external fixed bin (35);
	dcl     get_wdir_		        ext entry returns (char (168));
	dcl     hcs_$star_		        entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
				        fixed bin (35));
	dcl     hcs_$status_minf	        entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				        fixed bin (35));
	dcl     copy_names_		        entry (character (*), character (*), character (*), character (*),
				        character (*), bit (1) aligned, fixed binary (35));
	dcl     move_names_		        entry (character (*), character (*), character (*), character (*),
				        character (*), bit (1) aligned, fixed binary (35));
	dcl     get_equal_name_	        entry (character (*), character (*), character (32), fixed binary (35));
	dcl     cu_$arg_count	        ext entry (fixed bin, fixed bin (35));
	dcl     pathname_		        entry (character (*), character (*)) returns (character (168));
	dcl     get_system_free_area_	        entry() returns(ptr);

/* The additional names are to be left on the original segment. */

	copy = "1"b;
	whoami = "copy_names";
	go to work;

move_names:
     entry options (variable);

/* The additional names are to be removed from the original segment. */

	copy = "0"b;
	whoami = "move_names";

work:
	call cu_$arg_count (n, code);
	if code ^= 0
	then do;
		call com_err_ (code, whoami);
		return;
	     end;
	if n = 0
	then do;
		call com_err_$suppress_name (0, whoami, "Usage:  ^a from1 to1 ... fromj toj", whoami);
		return;
	     end;

	areap = get_system_free_area_ ();
	star_entry_ptr, star_names_ptr = null;
	on cleanup call cleaner;

/* The following master loop processes each pair of arguments completely
   unless some error code is returned by the file system. */

	do i = 1 to n by 2;

/* get first arg */
	     call cu_$arg_ptr (i, ap, lng, code);
	     call expand_pathname_ (arg, dir1, en1, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, whoami, "^a", arg);
		     return;
		end;
	     call check_star_name_$entry (en1, code);
	     if code ^= 0
	     then do;
		     if code = 1 | code = 2
		     then stars = "1"b;
		     else do;
			     call com_err_ (code, whoami, "^a", en1);
			     return;
			end;
		end;

/* get second arg */
	     if i = n
	     then do;
		     qent = en1;			/* have odd no. of args */
		     dir2 = get_wdir_ ();
		     call doit;
		end;
	     else do;
		     call cu_$arg_ptr (i + 1, ap, lng, code);
		     call expand_pathname_ (arg, dir2, qent, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, whoami, "^a", arg);
			     return;
			end;
		     if stars
		     then do;
			     call hcs_$star_ (dir1, en1, 3, areap, star_entry_count, star_entry_ptr, star_names_ptr,
				code);
			     if code ^= 0
			     then do;
errseg1:
				     call com_err_ (code, whoami, "^a", pathname_ (dir1, en1));
				     goto next_arg;
				end;
			     do j = 1 to star_entry_count;
				en1 = star_names (star_entries (j).nindex);
				call doit;
			     end;
			     call cleaner;		/* get rid of current star structures */
			end;
		     else call doit;
		end;
next_arg:
	end;


doit:
     proc;

	call get_equal_name_ (en1, qent, en2, code);
	if code ^= 0
	then do;
		call com_err_ (code, whoami, "^a for ^a", qent, en1);
		return;
	     end;

/* Does target segment exist?? */

	call hcs_$status_minf (dir2, en2, 0, type, bitcnt, code);
	if code ^= 0
	then go to errseg2;

/* If so, then move the names. */

	if copy
	then call copy_names_ (dir1, en1, dir2, en2, whoami, errsw, code);
	else call move_names_ (dir1, en1, dir2, en2, whoami, errsw, code);

	if code ^= 0 &amp; code ^= error_table_$namedup &amp; code ^= error_table_$segnamedup
	then if errsw
	     then
errseg2:
		call com_err_ (code, whoami, "^a", pathname_ (dir2, en2));
	     else call com_err_ (code, whoami, "^a", pathname_ (dir1, en1));

     end doit;

cleaner:
     proc;

	if star_names_ptr ^= null
	then do;
		free star_names in (myarea);
		star_names_ptr = null;
	     end;
	if star_entry_ptr ^= null
	then do;
		free star_entries in (myarea);
		star_entry_ptr = null;
	     end;

	return;
     end cleaner;

%page;
%include star_structures;

     end copy_names;
�



		    copy_names_.pl1                 10/25/83  1546.8r w 10/25/83  1444.6       57285



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */




/* format: style2,idind30,indcomtxt */

copy_names_:
     proc (dir1, en1, dir2, en2, entry_name, errsw, code);


/* Procedure to copy (copy_names_) or move (move_names_) the names from one segment to another. */
/* Copy_names_ copies all the names on a segment, move_names_ ignores the first name */
/* Coded by John Strayhorn 7/1/70 */
/* modified by E. Stone 12/71 - to allow nd_handler_ to be called from the user ring only */
/* last modified by J. Klensin 8/73 - to permit handling more than 60 names */
/* Bug fixed 1/22/76 by Steve Herbst */
/* changed to call object_type_ Jay Pattin 2/17/83 */
/* 830924 object_type_ -&gt; fs_util_ BIM */

          dcl     (count, i)                    fixed bin (17);
          dcl     code                          fixed bin (35);
          dcl     (dir1, dir2)                  char (*);   /* directories */
          dcl     (en1, en2, entry_name)        char (*);   /* entry names */
          dcl     name                          char (32);  /* temporary name to save based references */
          dcl     (areap, eptr)                 ptr;
          dcl     np                            ptr init (null);
          dcl     1 branch                      aligned,    /* structure for status */
                    2 type                      bit (2) unal,
                    2 nnames                    bit (16) unal,
                    2 nrp                       bit (18) unal,
                    2 pad                       bit (108) unal;

          dcl     area                          area based (areap);

          dcl     cleanup                       condition;

          dcl     names                         (0:119) char (32) based (np);
          dcl     hcs_$status_                  entry (char (*), char (*), fixed bin, ptr, ptr, fixed bin (35));
          dcl     fs_util_$chname_file          entry (char (*), char (*), char (*), char (*), fixed bin (35));
          dcl     nd_handler_                   entry (char (*), char (*), char (*), fixed bin (35));
          dcl     get_system_free_area_         entry () returns (ptr);

          dcl     (addr, bin, empty, null, ptr) builtin;
          dcl     (get_ring_, get_initial_ring_)
                                                returns (fixed bin);
          dcl     error_table_$namedup          external fixed bin (35);
          dcl     error_table_$segnamedup       external fixed bin (35);
          dcl     (mvsw, errsw, nd_flag, sd_flag, user_ring)
                                                bit (1) aligned;


          mvsw = "0"b;
          go to start;


/* This entry deletes the names before adding them to the target segment. */

move_names_:
     entry (dir1, en1, dir2, en2, entry_name, errsw, code);
          mvsw = "1"b;

/* Default assumption is that error occurred while referencing first segment. */

start:
          errsw, nd_flag, sd_flag = "0"b;

/* set switch to indicate whether called from user ring (OK to query) */
          user_ring = (get_ring_ () &gt;= get_initial_ring_ ());


/* initialize pointers and area (for status) */


          areap = get_system_free_area_ ();

          eptr = addr (branch);

          on condition (cleanup) call clean_up;

/* call status to get names (get link names if a link). */


          call hcs_$status_ (dir1, en1, 0, eptr, areap, code);
          if code ^= 0
          then go to out;

          np = ptr (areap, branch.nrp);
          count = bin (branch.nnames, 17);

/* move the names: same order, deleting first for move */

          do i = 0 to count - 1;

               name = np -&gt; names (i);

               if mvsw
               then do;
                         if name = en1
                         then go to nex_nam;                /* leave the name given as argument */
                         call fs_util_$chname_file (dir1, en1, name, "", code);
                         if code ^= 0
                         then go to out;
                    end;


next_try:
               call fs_util_$chname_file (dir2, en2, "", name, code);
               if code ^= 0
               then do;
                         if code = error_table_$namedup
                         then do;                           /* name already in directory */
                                   if user_ring
                                   then do;                 /* query user to correct namedup */
                                             call nd_handler_ (entry_name, dir2, name, code);
                                             if code = 0
                                             then go to next_try;
                                        end;
                                   nd_flag, errsw = "1"b;
                                   go to nex_nam;
                              end;

                         else if code = error_table_$segnamedup
                         then do;                           /* name already on segment */
                                   sd_flag = "1"b;
                                   go to nex_nam;
                              end;

                         else do;
                                   if mvsw
                                   then call fs_util_$chname_file (dir1, en1, "", name, code);
                                   errsw = "1"b;
                                   call clean_up;
                                   return;
                              end;
                    end;
nex_nam:
          end;

out:
          if nd_flag
          then code = error_table_$namedup;
          else if sd_flag
          then code = error_table_$segnamedup;

          call clean_up;

clean_up:
     proc ();                                               /* procedure to free any space in system area */

          if np ^= null
          then free names in (area);

     end clean_up;

     end copy_names_;
���



		    copy_seg_.pl1                   10/25/83  1546.8r w 10/25/83  1444.6       37143



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */



copy_seg_:
     proc (P_source_dir, P_source_name, P_target_dir, P_target_name, P_caller, P_error_sw, P_code);

/* This is a replacement for the old copy_seg_. It is just a write-around for copy_

   Jay Pattin 6/29/83 */

          declare (P_source_dir, P_source_name, P_target_dir, P_target_name, P_caller)
                                         char (*) parameter,
                  P_error_sw             bit (1) aligned parameter,
                  P_code                 fixed bin (35) parameter;

          declare 1 cpo                  aligned like copy_options,
                  1 cei                  aligned like copy_error_info,
                  1 ci                   aligned like condition_info;

          declare brief                  bit (1) aligned,
                  code                   fixed bin (35),
                  message                char (100) aligned,
                  no_message             bit (1) aligned;

          declare error_table_$fatal_error fixed bin (35) external,
                  iox_$error_output      ptr external,
                  string                 builtin,
                  sub_error_             condition;

          declare continue_to_signal_    entry (fixed bin (35)),
                  convert_status_code_   entry (fixed bin (35), char (8) aligned, char (100) aligned),
                  copy_                  entry (ptr),
                  find_condition_info_   entry (ptr, ptr, fixed bin (35)),
                  ioa_$ioa_switch        entry options (variable);
%page;
%include copy_options;
%page;
%include copy_flags;
%page;
%include sub_error_info;
%include copy_error_info;
%include condition_info_header;
%include condition_info;
%page;
          brief, no_message = "0"b;
          goto COMMON;

copy_seg_$brief:
     entry (P_source_dir, P_source_name, P_target_dir, P_target_name, P_caller, P_error_sw, P_code);

          brief = "1"b;
          no_message = "0"b;
          goto COMMON;

copy_seg_$no_message:
     entry (P_source_dir, P_source_name, P_target_dir, P_target_name, P_caller, P_error_sw, P_code);

          brief = "0"b;
          no_message = "1"b;
          goto COMMON;

COMMON:   cpo.version = COPY_OPTIONS_VERSION_1;
          cpo.caller_name = P_caller;
          cpo.source_dir = P_source_dir;
          cpo.source_name = P_source_name;
          cpo.target_name = P_target_name;
          cpo.target_dir = P_target_dir;

          string (cpo.flags) = ""b;
          cpo.no_name_dup = no_message;
          string (cpo.copy_items) = ""b;

          on sub_error_ call sub_err_handler ();

          call copy_ (addr (cpo));

          P_code = 0;
          return;

MAIN_RETURN:
          P_error_sw = cpo.target_err_switch;
          if code = 0 then code = error_table_$fatal_error;
          P_code = code;
          return;
%page;
sub_err_handler:
     proc ();

          ci.version = condition_info_version_1;
          call find_condition_info_ (null (), addr (ci), (0));
          sub_error_info_ptr = ci.info_ptr;

          if sub_error_info.name ^= "copy_" | copy_error_info.copy_options_ptr ^= addr (cpo) then do;
                    call continue_to_signal_ ((0));
                    return;
               end;

          code = sub_error_info.status_code;

          if sub_error_info.cant_restart then goto MAIN_RETURN;

          if sub_error_info.default_restart &amp; brief then return;

          call convert_status_code_ (code, "", message);
          call ioa_$ioa_switch (iox_$error_output, "^a: ^a ^a", cpo.caller_name, message, sub_error_info.info_string);

          return;
     end sub_err_handler;

     end copy_seg_;
�



		    create.pl1                      03/15/89  0848.2r w 03/15/89  0800.5      139086



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


create: cr: proc;


/* Command completely re-written on 10/04/74 to add create_dir options for
   compatibility with the Access Isolation Mechanism  -- J. C. Whitmore  */
/* Modified 750122 by LJS to use new hcs_$create_branch_ and clean up error handling */
/* Modified 751205 by LJS to use parent access class as default, make dir names starting with "-" invalid */
/* Modified April 1976 by Larry Johnson to create master directories */
/* Fix to reject "" and not print err after "no" to query 04/08/80 S. Herbst */
/* Fixed to reject -foo, create_dir to set 7,7 brackets and accept -rb 06/30/82 S. Herbst */
/* Changed to not create through links 07/28/82 S. Herbst */
/* Fixed -name 12/21/83 S. Herbst */
/* Rewrote again, added -msf and -max_length 01/11/84 S. Herbst */
/* Changed to provide dir_quota for dirs, December 1984, Keith Loepere. */
/* Modified 1985-01-02 by EJ Sharpe to add -account and -owner */
/* Fixed -name to disallow white space or null arg 02/21/85 Steve Herbst */


/* Constants */

dcl  SMA bit (3) unaligned internal static options (constant) init ("111"b);
dcl  RW bit (3) unaligned internal static options (constant) init ("101"b);


/* Based */

dcl arg char (arg_len) based (arg_ptr);


/* Automatic */

dcl dn char (168);
dcl (ctl_arg_name, en, lv_name, type_name, whoami) char (32);
dcl (account, owner) char (32);

dcl access_class bit (72) aligned;
dcl (create_dir_sw, create_msf_sw) bit (1);
dcl (ac_specified_sw, lv_specified_sw, quota_specified_sw, dir_quota_specified_sw) bit (1);
dcl (acct_specified_sw, owner_specified_sw) bit (1);

dcl (alp, arg_ptr, fcb_ptr) ptr;

dcl rb (3) fixed bin;
dcl (arg_count, i) fixed bin;
dcl (quota, dir_quota) fixed bin (18);
dcl (msf_max_length, specified_max_length) fixed bin (19);
dcl arg_len fixed bin (21);
dcl code fixed bin (35);


/* External */

dcl error_table_$action_not_performed fixed bin (35) ext;
dcl error_table_$bad_ring_brackets fixed bin (35) ext;
dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$invalid_ring_brackets fixed bin (35) ext;
dcl error_table_$namedup fixed bin (35) ext;
dcl error_table_$no_s_permission fixed bin (35) ext;
dcl error_table_$noarg fixed bin (35) ext;
dcl error_table_$noentry fixed bin (35) ext;
dcl error_table_$nostars fixed bin (35) ext;
dcl sys_info$max_seg_size fixed bin(35) ext static;


/* Entries */

dcl check_star_name_$entry entry (char (*), fixed bin (35));
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl cu_$arg_count entry (fixed bin, fixed bin (35));
dcl cu_$arg_list_ptr entry (ptr);
dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl mdc_$create_dirx_acct entry (char (*), char (*), char (*), ptr, char (*), char (*), fixed bin (35));
dcl cu_$level_get entry () returns (fixed bin);
dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl get_authorization_ entry returns (bit (72) aligned);
dcl get_group_id_$tag_star entry () returns (char (32));
dcl get_wdir_ entry returns (char (168));
dcl hcs_$create_branch_ entry (char (*), char (*), pointer, fixed bin (35));
dcl hcs_$set_max_length entry (char(*), char(*), fixed bin(19), fixed bin(35));
dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl ioa_ entry options (variable);
dcl msf_manager_$close entry (ptr);
dcl msf_manager_$msf_get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));
dcl msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35));
dcl nd_handler_ entry (char (*), char (*), char (*), fixed bin (35));
dcl pathname_ entry (char (*), char (*)) returns (char (168));


/* Builtins */

dcl (addr, mod, null, string, substr, verify) builtin;


/* Conditions */

dcl cleanup condition;

%include create_branch_info;

dcl 1 branch_template aligned like create_branch_info;

dcl WHITE_SPACE char (4) aligned int static options (constant) init (/* NL HT SP FF */ "
	 ");

	whoami = "create";
	create_dir_sw = "0"b;
	go to CHECK_ARGS;



create_dir: createdir: cd: entry;

	whoami = "create_dir";
	create_dir_sw = "1"b;

CHECK_ARGS:
	access_class = get_authorization_ ();

	call cu_$arg_count (arg_count, code);
	if code ^= 0 then do;
	     call com_err_ (code, whoami);
	     return;
	end;
	if arg_count = 0 then do;
USAGE:	     call com_err_$suppress_name (0, whoami, "Usage:  ^a paths {-control_args}", whoami);
	     return;
	end;

	call cu_$arg_list_ptr (alp);

	create_msf_sw = "0"b;
	ac_specified_sw, lv_specified_sw, quota_specified_sw, dir_quota_specified_sw = "0"b;
	acct_specified_sw, owner_specified_sw = "0"b;
	msf_max_length = 0;				/* can be changed by -max_length */
	quota, dir_quota = 0;

	if create_dir_sw then rb (1), rb (2), rb (3) = 7;	/* default for dirs */
	else rb (1), rb (2), rb (3) = cu_$level_get ();	/* for segments */
	account = "";	/* defaults to user's proccess group id */
	owner = "";	/* defaults to user's proccess group id */

begin;

dcl name_sw (arg_count) bit (1) unaligned;
dcl path_sw (arg_count) bit (1) unaligned;

	string (name_sw) = "0"b;
	string (path_sw) = "0"b;

	do i = 1 to arg_count;

	     call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
	     if code ^= 0 then do;
		call com_err_ (code, whoami);
		return;
	     end;

/* Control args only for create_dir */

	     if arg = "-access_class" | arg = "-acc" then do;
		if ^create_dir_sw then go to BAD_CTL_ARG;
		ctl_arg_name = "-access_class";	/* save arg name in case error printed */
		i = i + 1;
		if i &gt; arg_count then do;
MISSING_VALUE:	     call com_err_ (0, whoami, "No value specified for ^a", ctl_arg_name);
		     return;
		end;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
		call convert_authorization_$from_string (access_class, arg, code);
		if code ^= 0 then do;		/* all errors are fatal */
		     call com_err_ (code, whoami, arg);
		     return;
		end;
		ac_specified_sw = "1"b;
	     end;

	     else if arg = "-logical_volume" | arg = "-lv" then do;
		if ^create_dir_sw then go to BAD_CTL_ARG;
		ctl_arg_name = "-logical_volume";
		i = i + 1;
		if i &gt; arg_count then go to MISSING_VALUE;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
		lv_specified_sw = "1"b;
		lv_name = arg;
	     end;

	     else if arg = "-quota" then do;
		if ^create_dir_sw then go to BAD_CTL_ARG;
		ctl_arg_name = "-quota";
		i = i + 1;
		if i &gt; arg_count then go to MISSING_VALUE;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
		quota = cv_dec_check_ (arg, code);
		if code ^= 0 then do;
BAD_VALUE:	     call com_err_ (code, whoami, "Cannot convert ^a value ^a", ctl_arg_name, arg);
		     return;
		end;
		quota_specified_sw = "1"b;
	     end;

	     else if arg = "-dir_quota" then do;
		if ^create_dir_sw then go to BAD_CTL_ARG;
		ctl_arg_name = "-dir_quota";
		i = i + 1;
		if i &gt; arg_count then go to MISSING_VALUE;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
		dir_quota = cv_dec_check_ (arg, code);
		if code ^= 0 then go to BAD_VALUE;
		dir_quota_specified_sw = "1"b;
	     end;

	     else if arg = "-account" | arg = "-acct" then do;
		if ^create_dir_sw then go to BAD_CTL_ARG;
		ctl_arg_name = "-account";
		i = i + 1;
		if i &gt; arg_count then go to MISSING_VALUE;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
		account = arg;
		acct_specified_sw = "1"b;
	     end;

	     else if arg = "-owner" | arg = "-ow" then do;
		if ^create_dir_sw then go to BAD_CTL_ARG;
		ctl_arg_name = "-owner";
		i = i + 1;
		if i &gt; arg_count then go to MISSING_VALUE;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
		owner = arg;
		owner_specified_sw = "1"b;
	     end;

/* Control args only for create */

	     else if arg = "-max_length" | arg = "-ml" then do;
		if create_dir_sw then go to BAD_CTL_ARG;
		ctl_arg_name = "-max_length";
		i = i + 1;
		if i &gt; arg_count then go to MISSING_VALUE;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
		msf_max_length = cv_dec_check_ (arg, code);
		if code ^= 0 then go to BAD_VALUE;
		if msf_max_length &lt;= 0 then go to BAD_VALUE;
	     end;

	     else if arg = "-multisegment_file" | arg = "-msf" then do;
		if create_dir_sw then go to BAD_CTL_ARG;
		create_msf_sw = "1"b;
	     end;

	     else if arg = "-segment" | arg = "-sm" then do;
		if create_dir_sw then go to BAD_CTL_ARG;
		create_msf_sw = "0"b;
	     end;

/* Control args for both commands */

	     else if arg = "-name" | arg = "-nm" then do;
		ctl_arg_name = "-name";
		i = i + 1;
		if i &gt; arg_count then go to MISSING_VALUE;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
		if verify (arg, WHITE_SPACE) = 0 then do;
		     call com_err_ (0, whoami, "Invalid name ""^a""", arg);
		     return;
		end;
		path_sw (i), name_sw (i) = "1"b;
	     end;

	     else if arg = "-ring_brackets" | arg = "-rb" then do;
		ctl_arg_name = "-ring_brackets";
		i = i + 1;
		if i &gt; arg_count then go to MISSING_VALUE;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
		rb (1) = cv_dec_check_ (arg, code);
		if code ^= 0 then go to BAD_VALUE;
		if i &lt; arg_count then do;
		     call cu_$arg_ptr_rel (i + 1, arg_ptr, arg_len, code, alp);
		     rb (2) = cv_dec_check_ (arg, code);
		     if code = 0 then do;
			i = i + 1;
			if i &lt; arg_count &amp; ^create_dir_sw then do;
			     call cu_$arg_ptr_rel (i + 1, arg_ptr, arg_len, code, alp);
			     rb (3) = cv_dec_check_ (arg, code);
			     if code = 0 then i = i + 1;
			     else rb (3) = rb (2);
			end;
			else rb (3) = rb (2);
		     end;
		     else rb (2), rb (3) = rb (1);
		end;
		else rb (2), rb (3) = rb (1);
	     end;

	     else if substr (arg, 1, 1) = "-" then do;
BAD_CTL_ARG:	call com_err_ (error_table_$badopt, whoami, arg);
		return;
	     end;

	     else do;
		if verify (arg, WHITE_SPACE) = 0 then do;  /* blank arg */
		     call com_err_ (0, whoami, "Invalid name ""^a""", arg);
		     return;
		end;
		path_sw (i) = "1"b;
	     end;
	end;

	if string (path_sw) = "0"b then go to USAGE;

	if msf_max_length ^= 0 &amp; ^create_msf_sw then do;
	     call com_err_ (0, whoami, "-max_length can only be specified with -msf.");
	     return;
	end;

	if msf_max_length &gt; sys_info$max_seg_size then do;
	     call ioa_ ("^a: Max length ^d greater than limit of ^d; using ^d for max length.",
		whoami, msf_max_length, sys_info$max_seg_size, sys_info$max_seg_size);
	     msf_max_length = sys_info$max_seg_size;
	end;
	if mod (msf_max_length, 1024) ^= 0 then do;
	     specified_max_length = msf_max_length;
	     msf_max_length = msf_max_length - mod (msf_max_length, 1024) + 1024;
	     call ioa_ ("^a: ^d is not a multiple of 1024; ^d will be used for max length.",
		whoami, specified_max_length, msf_max_length);
	end;

	if ^quota_specified_sw &amp; (lv_specified_sw | ac_specified_sw) then do; /* special directories need quota */
	     if lv_specified_sw &amp; ac_specified_sw then type_name = "upgraded master";
	     else if lv_specified_sw then type_name = "master";
	     else type_name = "upgraded";
	     call com_err_ (error_table_$noarg, whoami, "-quota needed to create ^a directory.", type_name);
	     return;
	end;

	if (acct_specified_sw | owner_specified_sw) &amp; ^lv_specified_sw then do;
	     call com_err_ (error_table_$noarg, whoami,
		"^[-account^]^[ and ^]^[-owner^] may only be specified when using -logical_volume to create a master directory.",
		acct_specified_sw, (acct_specified_sw &amp; owner_specified_sw), owner_specified_sw);
	     return;
	end;

/* - - - - This is where the real work starts - - - - */

/* Fill in structure that gets passed to hcs_$create_branch_ */

	branch_template.version = create_branch_version_2; /* Fill in version constant defined
						   in include file */
	branch_template.switches.dir_sw = create_dir_sw;
	branch_template.switches.copy_sw = "0"b;
	branch_template.switches.priv_upgrade_sw = "0"b;
	branch_template.switches.mbz1 = (31)"0"b;
	if create_dir_sw then branch_template.mode = SMA;
	else branch_template.mode = RW;
	branch_template.mbz2 = (33)"0"b;
	do i = 1 to 3;
	     branch_template.rings (i) = rb (i);
	end;
	branch_template.userid = get_group_id_$tag_star ();
	branch_template.bitcnt = 0;
	branch_template.quota = quota;
	branch_template.dir_quota = dir_quota;
	branch_template.chase_sw = "0"b;

	do i = 1 to arg_count;

	     if ^path_sw (i) then go to END_LOOP;	/* skip over control args */

	     call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, alp);
	     if code ^= 0 then do;
		call com_err_ (code, whoami, "Arg: ^d", i);
		return;
	     end;

	     if name_sw (i) then do;
		dn = get_wdir_ ();
		en = arg;
	     end;
	     else do;
		call expand_pathname_ (arg, dn, en, code);
		if code ^= 0 then do;
		     call com_err_ (code, whoami, arg);
		     go to END_LOOP;
		end;

		call check_star_name_$entry (en, code);
		if code ^= 0 then do;
		     if code &lt; 3 then code = error_table_$nostars;  /* star convention not allowed */
		     go to COMPLAIN;
		end;
	     end;

	     branch_template.parent_ac_sw = ^ac_specified_sw;
	     branch_template.access_class = access_class;

TRY_AGAIN:	
	     if lv_specified_sw then
		call mdc_$create_dirx_acct (dn, en, lv_name, addr (branch_template), account, owner, code);

	     else if create_msf_sw then code = create_msf ();

	     else call hcs_$create_branch_ (dn, en, addr (branch_template), code);

	     if code ^= 0 then
		if code = error_table_$namedup then do;

		     call nd_handler_ (whoami, dn, en, code);
		     if code = 0 then go to TRY_AGAIN;	/* user deleted it */
		     if code &gt; 1 &amp; code ^= error_table_$action_not_performed then
COMPLAIN:			call com_err_ (code, whoami, "^a^[^/^-Specified ring brackets: ^d,^d,^d^]",
			     pathname_ (dn, en),
			     code = error_table_$bad_ring_brackets | code = error_table_$invalid_ring_brackets,
			     rb (1), rb (2), rb (3));
		     go to END_LOOP;
		end;
		else go to COMPLAIN;

END_LOOP:	end;

end;  /* begin block */

	return;
%page;
create_msf: proc returns (fixed bin (35));

/* Creates an MSF with pathname dn&gt;en, returns the status code */

dcl code fixed bin (35);

	call hcs_$status_minf (dn, en, 0, 0, 0, code);
	if code = 0 | code = error_table_$no_s_permission then return (error_table_$namedup);
	else if code ^= error_table_$noentry then return (code);

	fcb_ptr = null;

	on cleanup begin;
	     if fcb_ptr ^= null then call msf_manager_$close (fcb_ptr);
	end;

	call msf_manager_$open (dn, en, fcb_ptr, code);
	if fcb_ptr = null then return (code);

	call msf_manager_$msf_get_ptr (fcb_ptr, 0, "1"b, null, 0, code);  /* creates the MSF */

	call msf_manager_$close (fcb_ptr);

	if msf_max_length ^= 0 then do;
	     call hcs_$set_max_length (pathname_ (dn, en), "0", msf_max_length, code);
	     if code ^= 0 then
		call com_err_ (code, whoami, "Could not set max length of ^a&gt;0", pathname_ (dn, en));
	end;

	return (code);

end create_msf;


end create;
��



		    equal_.pl1                      10/25/83  1546.8r w 10/25/83  1444.6       22410



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



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e:  equal_								*/
	/*									*/
	/*      This program provides an interface between the obsolete routine, equal_, and	*/
	/* the routine which has replaced it, get_equal_name_.  equal_ scans its character string	*/
	/* arguments to compute their length, according to the algorithm:			*/
	/*									*/
	/*	do Larg = 1 to 32 while (substr (arg, Larg, 1) ^= " ");			*/
	/*	     end;								*/
	/*	Larg = Larg - 1;							*/
	/*									*/
	/* and then calls get_equal_name_ with these arguments, and returns its results.	*/
	/* Eventually, this obsolete routine should be deleted.				*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 0) Created:  July, 1973 by G. C. Dixon					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

equal_:	procedure	(Pentry, Pequal, Ptarget, code);

     dcl	Pentry			ptr,		/* ptr to an entry name of 32 or fewer chars.(In)	*/
	Pequal			ptr,		/* ptr to an equal name of 32 or fewer chars.(In)	*/
	Ptarget			ptr,		/* ptr to a target name of 32 chars.(In)	*/
	code			fixed bin(35);	/* a status code.				*/

     dcl	Lentry			fixed bin,	/* length of entry name.			*/
	Lequal			fixed bin,	/* length of equal name.			*/
	entry			char(Lentry) based (Pentry),
	equal			char(Lequal) based (Pequal),
         (error_table_$bad_equal_name,
	error_table_$badequal)	fixed bin(35) ext static,
	get_equal_name_		entry (char(*), char(*), char(*), fixed bin(35)),
	substr			builtin,
	target			char(32) based (Ptarget);

	do Lentry = 1 to 32 while (substr (entry, Lentry, 1) ^= " ");
	     end;
	Lentry = Lentry - 1;
	do Lequal = 1 to 32 while (substr (equal, Lequal, 1) ^= " ");
	     end;
	Lequal = Lequal - 1;
	call get_equal_name_ (entry, equal, target, code);
	if code = error_table_$bad_equal_name then
	     code = error_table_$badequal;

	end equal_;
��



		    link.pl1                        02/06/84  1012.8re  02/06/84  1008.2       86094



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
link: lk: proc;

/* The link command:   link target1 path1 ... targetN {pathN} */
/* Written 12/05/80 S. Herbst */
/* Added -chase, -check, -copy_names, -name, reject -foo and blank names 06/30/82 S. Herbst */
/* Fixed to print usage message if no pathnames specified 04/04/83 S. Herbst */
/* Fixed not to try to -copy_names if link cannot be created 12/12/83 S. Herbst */

/* Constants */

dcl WHITE_SPACE char (5) int static options (constant) init (" 	
");						/* SP HT VT NL FF */
dcl ALL_ENTRIES fixed bin (2) int static options (constant) init (3);
dcl (CHASE init (1), NO_CHASE init (0)) fixed (1) int static options (constant);
dcl LINK_TYPE fixed (2) int static options (constant) init (0);

/* Based */

dcl arg char (arg_len) based (arg_ptr);

/* Automatic */

dcl (dn, first_arg, target_dn) char (168);
dcl (en, target_en) char (32);

dcl (chase_sw, check_sw, copy_names_sw, errsw, got_path_sw, name_sw, second_arg_sw, star_sw) bit (1);

dcl arg_ptr ptr;

dcl (arg_count, arg_len, i) fixed;
dcl type fixed bin (2);
dcl code fixed bin (35);

dcl error_table_$action_not_performed fixed (35) ext;
dcl error_table_$badopt fixed (35) ext;
dcl error_table_$namedup fixed (35) ext;
dcl error_table_$no_s_permission fixed (35) ext;
dcl error_table_$noentry fixed (35) ext;
dcl error_table_$segnamedup fixed (35) ext;

dcl check_star_name_$entry entry (char (*), fixed (35));
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl copy_names_ entry (char (*), char (*), char (*), char (*), char (*), bit (1), fixed (35));
dcl cu_$arg_count entry (fixed, fixed (35));
dcl cu_$arg_ptr entry (fixed, ptr, fixed, fixed (35));
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed (35));
dcl get_equal_name_ entry (char (*), char (*), char (*), fixed (35));
dcl get_system_free_area_ entry returns (ptr);
dcl get_wdir_ entry returns (char (168));
dcl hcs_$append_link entry (char (*), char (*), char (*), fixed (35));
dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed (35));
dcl hcs_$star_ entry (char (*), char (*), fixed (2), ptr, fixed, ptr, ptr, fixed (35));
dcl hcs_$status_minf entry (char (*), char (*), fixed (1), fixed (2), fixed (24), fixed (35));
dcl nd_handler_ entry (char (*), char (*), char (*), fixed (35));
dcl pathname_ entry (char (*), char (*)) returns (char (168));

dcl (fixed, null, search, verify) builtin;

dcl cleanup condition;
%page;
	call cu_$arg_count (arg_count, code);
	if code ^= 0 then do;
	     call com_err_ (code, "link");
	     return;
	end;

	chase_sw, check_sw, copy_names_sw, got_path_sw = "0"b;

	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if verify (arg, WHITE_SPACE) = 0 then do;	/* blank arg */
		call com_err_ (0, "link", "Invalid name ""^a""", arg);
		return;
	     end;

	     if substr (arg, 1, 1) = "-" then
		if arg = "-chase" then chase_sw = "1"b;
		else if arg = "-no_chase" then chase_sw = "0"b;
		else if arg = "-check" | arg = "-ck" then check_sw = "1"b;
		else if arg = "-no_check" | arg = "-nck" then check_sw = "0"b;
		else if arg = "-copy_names" | arg = "-cpnm" then copy_names_sw = "1"b;
		else if arg = "-no_copy_names" | arg = "-ncpnm" then copy_names_sw = "1"b;
		else if arg = "-name" | arg = "-nm" then i = i + 1;
		else do;
		     call com_err_ (error_table_$badopt, "link", "^a", arg);
		     return;
		end;

	     else got_path_sw = "1"b;
	end;

	if ^got_path_sw then do;
	     call com_err_$suppress_name (0, "link",
		"Usage:  link target_path1 link_path1 ... target_pathN {link_pathN} {-control_args}");
	     return;
	end;

	second_arg_sw = "0"b;			/* ON if already got first arg of pair */
	name_sw = "0"b;				/* ON if -name just encountered */

	do i = 1 to arg_count;

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

	     if substr (arg, 1, 1) = "-" then
		if arg = "-name" | arg = "-nm" then do;
		     i = i + 1;
		     if i &gt; arg_count then do;
			call com_err_ (0, "link", "No value specified for -name");
			return;
		     end;
		     name_sw = "1"b;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if second_arg_sw then go to SECOND_ARG;
		     else do;
			call com_err_ (0, "link", "-name not allowed before target path.");
			return;
		     end;
		end;
		else;

	     else if ^second_arg_sw then do;
FIRST_ARG:
		second_arg_sw = "1"b;			/* for next time through */
		first_arg = arg;

		call expand_pathname_ (arg, target_dn, target_en, code);
		if code ^= 0 then do;
PATH_ERR:		     call com_err_ (code, "link", "^a", arg);
		     return;
		end;

		call check_star_name_$entry (target_en, code);
		if code ^= 0 then
		     if code = 1 | code = 2 then star_sw = "1"b;
		     else do;
			call com_err_ (code, "link", "^a", target_en);
			return;
		     end;
		else star_sw = "0"b;
	     end;

	     else do;

		name_sw = "0"b;
SECOND_ARG:
		second_arg_sw = "0"b;		/* for next time through */

		if name_sw then do;
		     name_sw = "0"b;
		     dn = get_wdir_ ();
		     en = arg;
		end;
		else do;
		     call expand_pathname_ (arg, dn, en, code);
		     if code ^= 0 then go to PATH_ERR;

		     call check_star_name_$entry (en, code);
		     if code ^= 0 then do;
			if code = 1 | code = 2 then call com_err_ (0, "link",
			     "Stars not allowed in link pathname.  ^a", arg);
			else call com_err_ (code, "link", "^a", en);
			return;
		     end;
		end;

		if star_sw then call link_stars (dn, en, target_dn, target_en);

		else call link_one (dn, en, target_dn, target_en);
	     end;
	end;

	if second_arg_sw then do;			/* second arg in pair missing */
	     if search (first_arg, "&lt;&gt;") = 0 then do;	/* first is in wdir */
		call com_err_ (0, "link", "Link points to itself; not created.  ^a",
		     pathname_ (target_dn, target_en));
		return;
	     end;

	     dn = get_wdir_ ();
	     en = "===";

	     if star_sw then call link_stars (dn, en, target_dn, target_en);

	     else call link_one (dn, en, target_dn, target_en);
	end;

RETURN:	return;
%page;
link_one: proc (P_dn, P_en, P_target_dn, P_target_en);

dcl (P_dn, P_en, P_target_dn, P_target_en) char (*);
dcl (target_dn, target_path, ultimate_dn) char (168);
dcl (en, target_en, ultimate_en) char (32);

	target_dn = P_target_dn;
	target_en = P_target_en;
	target_path = pathname_ (target_dn, target_en);

	call get_equal_name_ (target_en, P_en, en, code);
	if code ^= 0 then do;
	     call com_err_ (code, "link", "^a for ^a", en, target_en);
	     return;
	end;

	if check_sw then do;
	     call hcs_$status_minf (target_dn, target_en, CHASE, type, 0, code);
	     if code ^= 0 &amp; code ^= error_table_$no_s_permission then do;
		if code = error_table_$noentry then do;
		     call hcs_$status_minf (target_dn, target_en, NO_CHASE, 0, 0, code);
		     if code ^= error_table_$noentry then do;
			call com_err_ (0, "link", "No ultimate target for intended target ^a",
			     pathname_ (target_dn, target_en));
			go to RETURN;
		     end;
		end;
		call com_err_ (code, "link", "Link target ^a", pathname_ (target_dn, target_en));
		go to RETURN;
	     end;
	end;

	if chase_sw then do;
	     call hcs_$get_link_target (target_dn, target_en, ultimate_dn, ultimate_en, code);
	     if ultimate_dn ^= "" then do;
		target_dn = ultimate_dn;
		target_en = ultimate_en;
		target_path = pathname_ (target_dn, target_en);
	     end;
	end;

LINK:	call hcs_$append_link (P_dn, en, target_path, code);
	if code ^= 0 then
	     if code = error_table_$namedup then do;	/* ask whether to replace existing link */
		call nd_handler_ ("link", P_dn, en, code);
		if code = 0 then go to LINK;
		else if code = error_table_$action_not_performed then return;
		else go to RETURN;			/* an error occurred */
	     end;
	     else call com_err_ (code, "link", "^a^[&gt;^]^a", dn, dn ^= "&gt;", en);

	else if copy_names_sw then do;
	     call copy_names_ (target_dn, target_en, P_dn, en, "link -copy_names", errsw, code);
	     if code ^= 0 &amp; code ^= error_table_$namedup &amp; code ^= error_table_$segnamedup then
		if errsw then call com_err_ (code, "link", "^a", pathname_ (P_dn, en));
		else call com_err_ (code, "link", "^a", pathname_ (target_dn, target_en));
	end;

end link_one;
%page;
link_stars: proc (P_dn, P_en, P_target_dn, P_target_en);

dcl (P_dn, P_en, P_target_dn, P_target_en) char (*);
dcl 1 entries (entry_count) based (entries_ptr),
   2 pad bit (18) unaligned,
   2 nindex bit (18) unaligned;
dcl names (999) char (32) aligned based (names_ptr);
dcl target_en char (32);
dcl area area based (area_ptr);
dcl (area_ptr, entries_ptr, names_ptr) ptr;
dcl (entry_count, j) fixed bin;

	area_ptr = get_system_free_area_ ();
	entries_ptr, names_ptr = null;

	on cleanup call star_cleanup;

	call hcs_$star_ (P_target_dn, P_target_en, ALL_ENTRIES, area_ptr, entry_count, entries_ptr, names_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, "link", "^a", pathname_ (P_target_dn, P_target_en));
	     return;
	end;

	do j = 1 to entry_count;

	     target_en = names_ptr -&gt; names (fixed (entries_ptr -&gt; entries (j).nindex));

	     call link_one (P_dn, P_en, P_target_dn, target_en);
	end;

	call star_cleanup;

	return;

star_cleanup: proc;

	if entries_ptr ^= null then free entries in (area);
	if names_ptr ^= null then free names in (area);

end star_cleanup;

end link_stars;

end link;
��



		    move_quota.pl1                  02/22/85  0836.4rew 02/21/85  0927.6      193833



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
move_quota: movequota: mq: proc;

/* Implements the get_quota and move_quota commands and the get_quota active function. */
/* Coded November 1969 by M.R. Thompson */
/* Converted to pl1 1970 J.W. Gintell */
/* Star convention added September 1971 J. W. Gintell */
/* Converted to Version 2 December 1971 J.W. Gintell */
/* Removed set_quota entry point to tools May 1975 J. Whitmore */
/* Extra blank line removed from output 07/14/76 S. Herbst */
/* Rewrote, added gq af and -quota, -records_left, -records_used 09/29/82 S. Herbst */
/* Fixed to print table when multiple paths specified 10/29/82 S. Herbst */
/* Fixed error message for invalid numeric arg 01/03/83 S. Herbst */
/* Fixed bug in gq active function 03/17/83 S. Herbst */
/* Fixed -rec_left on link to use target's parent quota not link's parent quota 07/06/84 S. Herbst */
/* Added -nonzero, -total, -zero 07/06/84 S. Herbst */
/* Changed -all to print trp price at current rate structure 07/09/84 S. Herbst */
/* Added -sort 07/12/84 S. Herbst */
/* Fixed bug truncating record-days to an integer 11/15/84 Steve Herbst */
/* Fixed -long to align its output data in a column 11/26/84 Steve Herbst */
/* Fixed bug in error message when no directories match a starname 02/15/85 Steve Herbst */


/* Constants */

dcl NO_ACCESS fixed bin int static options (constant) init (-1);
dcl (QUOTA init (1), RECORDS_LEFT init (2), RECORDS_USED init (3)) fixed bin int static options (constant);

/* Based */

dcl area area based (area_ptr);

dcl 1 node aligned based,
   2 sort_value fixed bin (35),
   2 next ptr,
   2 info,
    3 path char (168) unaligned,
    3 lvname char (36),
    3 trp fixed bin (71),
    3 time_updated fixed bin (36),
    3 (terminal_quota, quota_value, records_left, records_used) fixed bin;

dcl arg char (arg_len) based (arg_ptr);
dcl return_arg char (return_len) varying based (return_ptr);

/* Automatic */

dcl (dn, path) char (168);
dcl lvname_string char (36);
dcl (default_lvname, en, lvname, me, time_string) char (32);

dcl sons_lvid bit (36);
dcl (af_sw, dir_quota_sw, long_sw, nonzero_sw, print_header_sw, quota_sw, records_left_sw, records_used_sw) bit (1);
dcl (some_matches, some_nonzero, some_zero, sort_sw, star_sw, total_sw, type_specified_sw, wdir_sw, zero_sw) bit (1);

dcl (area_ptr, arg_ptr, first_node_ptr, last_node_ptr, p, return_ptr) ptr;

dcl rate_structure_number fixed bin (9);
dcl (arg_count, i, j, node_count, path_count, quota_value, records_left, records_used) fixed bin;
dcl (sort_by, terminal_quota, total_quota, total_records_used) fixed bin;
dcl (arg_len, return_len) fixed bin (21);
dcl (code, time_updated) fixed bin (35);
dcl trp fixed bin (71);
dcl record_days float bin;
dcl dummy_rate (0:7) float bin;
dcl (disk_rate, dummy_float) float bin;

dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$badstar fixed bin (35) ext;
dcl error_table_$nomatch fixed bin (35) ext;
dcl error_table_$nostars fixed bin (35) ext;
dcl error_table_$not_act_fnc fixed bin (35) ext;

dcl complain variable entry options (variable);
dcl get_arg variable entry (fixed bin, ptr, fixed bin (21), fixed bin (35));

dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl active_fnc_err_ entry options (variable);
dcl check_star_name_$path entry (char (*), fixed bin (35));
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$arg_count entry (fixed bin, fixed bin (35));
dcl (cu_$af_arg_ptr, cu_$arg_ptr) entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl date_time_$fstime entry (fixed bin (35), char (*));
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl get_system_free_area_ entry returns (ptr);
dcl get_wdir_ entry returns (char (168));
dcl (hcs_$dir_quota_move, hcs_$quota_move) entry (char (*), char (*), fixed bin, fixed bin (35));
dcl (hcs_$dir_quota_read, hcs_$quota_read) entry (char (*), fixed bin, fixed bin (71), fixed bin (35),
	bit (36), fixed bin, fixed bin, fixed bin (35));
dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, fixed bin,
	ptr, ptr, fixed bin (35));
dcl (ioa_, ioa_$rsnnl) entry options (variable);
dcl mdc_$find_lvname entry (bit (36), char (*), fixed bin (35));
dcl pathname_ entry (char (*), char (*)) returns (char (168));
dcl sort_items_$fixed_bin entry (ptr);
dcl system_info_$prices_rs entry (fixed bin (9), (0:7)float bin, (0:7)float bin, (0:7)float bin, (0:7)float bin,
	float bin, float bin);
dcl user_info_$rs_number entry (fixed bin (9));

dcl (addr, binary, divide, float, index, length, mod, null, reverse, substr, sum, unspec) builtin;

dcl cleanup condition;
%page;
	me = "move_quota";
	dir_quota_sw = "0"b;
	go to MOVE_COMMON;

move_dir_quota: entry;

	me = "move_dir_quota";
	dir_quota_sw = "1"b;

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

	if arg_count &lt; 2 | mod (arg_count, 2) ^= 0 then do;
	     call com_err_$suppress_name (0, me, "Usage:  ^a path1 records1 ... pathN recordsN", me);
	     return;
	end;

	do i = 1 by 2 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if index (arg, "-") = 1 then
		if arg = "-working_directory" | arg = "-working_dir" | arg = "-wd" then do;
		     dn = get_wdir_ ();
		     en = "";
		end;
		else do;
		     call com_err_ (error_table_$badopt, me, "^a", arg);
		     return;
		end;
	     else do;
		call expand_pathname_ (arg, dn, en, code);
		if code ^= 0 then do;
		     call com_err_ (code, me, "^a", arg);
		     return;
		end;
	     end;

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

	     quota_value = cv_dec_check_ (arg, code);
	     if code ^= 0 then do;
		call com_err_ (0, me, "Invalid numeric argument.  ^a", arg);
		return;
	     end;

	     if dir_quota_sw then call hcs_$dir_quota_move (dn, en, quota_value, code);
	     else call hcs_$quota_move (dn, en, quota_value, code);

	     if code ^= 0 then do;
		call com_err_ (code, me, "^a", pathname_ (dn, en));
		return;
	     end;
	end;

	return;
%page;
get_quota: getquota: gq: entry;

	me = "get_quota";
	dir_quota_sw = "0"b;
	go to GET_COMMON;

get_dir_quota: entry;

	me = "get_dir_quota";
	dir_quota_sw = "1"b;

GET_COMMON:
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = 0 then do;
	     af_sw = "1"b;
	     get_arg = cu_$af_arg_ptr;
	     complain = active_fnc_err_;
	end;
	else if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     get_arg = cu_$arg_ptr;
	     complain = com_err_;
	end;
	else do;
	     call com_err_ (code, me);
	     return;
	end;

	long_sw, nonzero_sw, quota_sw, records_left_sw, records_used_sw = "0"b;
	sort_sw, total_sw, type_specified_sw, wdir_sw, zero_sw = "0"b;
	path_count = 0;

	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if index (arg, "-") = 1 then
		if arg = "-all" | arg = "-a" then do;
LONG:
		     if af_sw then do;
BAD_OPT:			call complain (error_table_$badopt, me, "^a", arg);
			return;
		     end;
		     long_sw, quota_sw, records_left_sw, records_used_sw = "1"b;
		end;
		else if arg = "-long" | arg = "-lg" then go to LONG;
		else if arg = "-nonzero" | arg = "-nz" then
		     if af_sw then go to BAD_OPT;
		     else nonzero_sw = "1"b;
		else if arg = "-quota" then quota_sw, type_specified_sw = "1"b;
		else if arg = "-records_left" | arg = "-rec_left" | arg = "-left" then
		     records_left_sw, type_specified_sw = "1"b;
		else if arg = "-records_used" | arg = "-rec_used" | arg = "-ru" | arg = "-used" then
		     records_used_sw, type_specified_sw = "1"b;
		else if arg = "-sort" then
		     if af_sw then go to BAD_OPT;
		     else sort_sw = "1"b;
		else if arg = "-total" | arg = "-tt" then total_sw = "1"b;
		else if arg = "-working_directory" | arg = "-working_dir" | arg = "-wd" then
		     if af_sw &amp; path_count &gt; 0 then go to AF_TWO_PATHS;
		     else do;
			wdir_sw = "1"b;
			path_count = path_count + 1;
		     end;
		else if arg = "-zero" then
		     if af_sw then go to BAD_OPT;
		     else zero_sw = "1"b;
		else go to BAD_OPT;
	     else do;
		if af_sw &amp; path_count &gt; 0 then do;
AF_TWO_PATHS:
		     call complain (0, me, "Only one directory allowed.");
		     return;
		end;
		path_count = path_count + 1;
	     end;
	end;

	if nonzero_sw &amp; zero_sw then do;
	     call complain (0, me, "Incompatible control arguments -zero and -nonzero");
	     return;
	end;

	if af_sw then
	     if (quota_sw &amp; records_left_sw) |
	        (records_left_sw &amp; records_used_sw) |
	        (quota_sw &amp; records_used_sw) then do;
		call complain (0, me, "Only one of -quota, -records_left, -records_used is allowed.");
		return;
	     end;

	if ^type_specified_sw then
	     if af_sw then quota_sw = "1"b;		/* af default: just return quota */
	     else quota_sw, records_used_sw = "1"b;

	if sort_sw then do;				/* decide which value to sort by */
	     if quota_sw &amp; ^records_left_sw &amp; ^records_used_sw then sort_by = QUOTA;
	     else if records_left_sw &amp; ^quota_sw &amp; ^records_used_sw then sort_by = RECORDS_LEFT;
	     else sort_by = RECORDS_USED;
	     node_count = 0;
	end;

	default_lvname = "";
	print_header_sw = "1"b;
	some_nonzero, some_zero, star_sw = "0"b;
	total_quota, total_records_used = 0;

	star_entry_ptr, star_names_ptr = null;
	first_node_ptr, last_node_ptr = null;
	area_ptr = get_system_free_area_ ();

	on cleanup call clean_up;

	if wdir_sw | path_count = 0 then do;
	     call process_path (get_wdir_ ());
	     if path_count &lt; 2 then go to TOTAL;	/* no args or -wd by itself */
	end;

	do i = 1 to arg_count;

	     call get_arg (i, arg_ptr, arg_len, code);

	     if index (arg, "-") ^= 1 then do;		/* pathname */

		call absolute_pathname_ (arg, path, code);
		if code ^= 0 then do;
		     call complain (code, me, "^a", arg);
		     return;
		end;

		star_sw = "0"b;
		if path ^= "&gt;" then do;
		     call check_star_name_$path (path, code);
		     if code = error_table_$badstar then do;
			call complain (code, me, "^a", path);
			return;
		     end;
		     star_sw = (code ^= 0);
		end;

		if ^star_sw then call process_path (path);

		else do;				/* starname */

		     if af_sw then do;
			call complain (error_table_$nostars, me, "^a", path);
			return;
		     end;

		     call expand_pathname_ (path, dn, en, code);
		     if code ^= 0 then do;		/* absolute_pathname_ probably caught this */
			call complain (code, me, "^a", path);
			return;
		     end;

		     if dir_quota_sw then call hcs_$dir_quota_read (dn, quota_value, trp, time_updated,
			sons_lvid, terminal_quota, records_used, code);
		     else call hcs_$quota_read (dn, quota_value, trp, time_updated,
			sons_lvid, terminal_quota, records_used, code);
		     if code ^= 0 then do;
			call complain (code, me, "^a", dn);
			return;
		     end;

		     call mdc_$find_lvname (sons_lvid, default_lvname, code);
		     if code ^= 0 then do;
			call complain (code, me, "^a ^w", dn, sons_lvid);
			return;
		     end;

		     call hcs_$star_ (dn, en, star_BRANCHES_ONLY, area_ptr, star_entry_count,
			star_entry_ptr, star_names_ptr, code);
		     if code ^= 0 then do;
			call complain (code, me, "^a", pathname_ (dn, en));
			return;
		     end;

		     some_matches = "0"b;

		     do j = 1 to star_entry_count;

			if star_entries (j).type = star_DIRECTORY then do;

			     some_matches = "1"b;

			     call process_path (pathname_ (dn, star_names (star_entries (j).nindex)));
			end;
		     end;

		     if ^some_matches then call complain (0, me, "No directories match starname ^a",
			pathname_ (dn, en));

		     call clean_up_stars;
		end;
	     end;
	end;

TOTAL:
	if nonzero_sw &amp; ^some_nonzero then
	     call com_err_ (0, me, "No directories with nonzero quota-used.");
	else if zero_sw &amp; ^some_zero then
	     call com_err_ (0, me, "No directories with zero quota-used.");

	if sort_sw then
begin;
dcl 1 sort_array aligned,
   2 n fixed bin (18),
   2 eltp (node_count) ptr unaligned;

	sort_array.n = node_count;
	i = 0;

	do p = first_node_ptr repeat (p -&gt; node.next) while (p ^= null);
	     i = i + 1;
	     sort_array.eltp (i) = addr (p -&gt; node.sort_value);
	end;

	call sort_items_$fixed_bin (addr (sort_array));

	do i = sort_array.n by -1 to 1;
	     p = eltp (i);
	     lvname = p -&gt; node.lvname;
	     trp = p -&gt; node.trp;
	     time_updated = p -&gt; node.time_updated;
	     terminal_quota = p -&gt; node.terminal_quota;
	     quota_value = p -&gt; node.quota_value;
	     records_left = p -&gt; node.records_left;
	     records_used = p -&gt; node.records_used;

	     call print_line (p -&gt; node.path);
	end;
end;

	if star_sw &amp; ^af_sw &amp; ^print_header_sw &amp; ^long_sw then
	     if (quota_sw | records_used_sw) then call ioa_ ("^/^[^6d^-^;^s^]^[^6d^-^;^s^]^[^-^]^-Total^/",
		quota_sw, total_quota, records_used_sw, total_records_used, records_left_sw);
	     else call ioa_ ("");

	return;
%page;
add_node: proc () returns (ptr);

dcl newp ptr;

	allocate node in (area) set (newp);
	unspec (newp -&gt; node) = "0"b;
	newp -&gt; node.next = null;
	if first_node_ptr = null then first_node_ptr, last_node_ptr = newp;
	else do;
	     last_node_ptr -&gt; node.next = newp;
	     last_node_ptr = newp;
	end;

	node_count = node_count + 1;

	return (newp);

end add_node;
%page;
clean_up: proc;

dcl (nextp, p) ptr;

	call clean_up_stars;

	if first_node_ptr ^= null then
	     do p = first_node_ptr repeat (nextp) while (p ^= null);
		nextp = p -&gt; node.next;
		free p -&gt; node in (area);
	     end;

end clean_up;
%page;
clean_up_stars: proc;

	if star_names_ptr ^= null then free star_names in (area);
	if star_entry_ptr ^= null then free star_entries in (area);
	star_entry_ptr, star_names_ptr = null;

end clean_up_stars;
%page;
entryname: proc (P_path) returns (char (*));

dcl P_path char (*);
dcl (i, j) fixed bin;

	if P_path = "&gt;" then return ("&gt;");
	i = index (reverse (P_path), "&gt;");
	if i = 0 then return (P_path);
	j = length (P_path) - i + 2;
	return (substr (P_path, j));

end entryname;
%page;
get_records_left: proc (P_path, P_quota_value, P_records_used, P_terminal_quota) returns (fixed bin);

/* This procedure calls itself recursively */

dcl P_path char (*);
dcl (P_quota_value, P_records_used, P_terminal_quota) fixed bin;
dcl (dn, target_dn) char (168);
dcl (en, target_en) char (32);
dcl (quota_value, records_used, terminal_quota) fixed bin;
dcl code fixed bin (35);

	if P_terminal_quota ^= 0 then return (P_quota_value - P_records_used);

	else do;

	     call expand_pathname_ (P_path, dn, en, code);

	     call hcs_$get_link_target (dn, en, target_dn, target_en, code);
						/* if nonlink, target_foo set same as foo */
	     if code ^= 0 then return (NO_ACCESS);

	     if dir_quota_sw then call hcs_$dir_quota_read (target_dn, quota_value, 0, 0, "0"b, terminal_quota,
		records_used, code);
	     else call hcs_$quota_read (target_dn, quota_value, 0, 0, "0"b, terminal_quota,
		records_used, code);

	     if code ^= 0 then return (NO_ACCESS);

	     else return (get_records_left (target_dn, quota_value, records_used, terminal_quota));
	end;

end get_records_left;
%page;
print_line: proc (P_path);

dcl P_path char (*);

	if ^long_sw then
	     if ^star_sw &amp; path_count &lt; 2 then call ioa_
		("^[quota = ^d^[; ^]^;^2s^]^[used = ^d^[; ^]^;^2s^]^[remaining = ^[(no access)^;^d^]^]",
		quota_sw, quota_value, records_left_sw | records_used_sw,
		records_used_sw, records_used, records_left_sw,
		records_left_sw, records_left = NO_ACCESS, records_left);

	     else do;				/* star case */
		if print_header_sw then do;		/* print heading first time */
		     call ioa_ ("^/^[^xquota^-^]^[^2xused^-^]^[^2xremaining^-^]^-directory name^/",
			quota_sw, records_used_sw, records_left_sw);
		     print_header_sw = "0"b;
		end;
		if lvname = default_lvname then lvname_string = "";
		else call ioa_$rsnnl ("(^a)", lvname_string, 0, lvname);
		call ioa_ ("^[^6d^-^;^s^]^[^6d^-^;^s^]^[^[no access^s^;^6d^]^-^;^2s^]^-^a  ^a",
		     quota_sw, quota_value,
		     records_used_sw, records_used,
		     records_left_sw, records_left = NO_ACCESS, records_left,
		     entryname (P_path), lvname_string);
	     end;

	else do;					/* -long */
	     call ioa_ ("^/quota for:   ^a^/", P_path);
	     call date_time_$fstime (time_updated, time_string);
	     record_days = (float (trp) + 43200.) / 86400.;
	     call ioa_ ("quota:^28t^d pages ^[(space is charged to superior directory)^]",
		quota_value, terminal_quota = 0);
	     call ioa_ ("used:^28t^d pages", records_used);
	     call ioa_ ("remaining:^28t^[(no access)^;^d pages^]", records_left = NO_ACCESS, records_left);
	     call ioa_ ("sons volume:^28t^a", lvname);
	     if time_updated ^= 0 then do;
		call ioa_ ("time-record-product:^28t^.3f record-days", record_days);
		call ioa_ ("trp last updated:^28t^a", time_string);
		call user_info_$rs_number (rate_structure_number);
		disk_rate = 0;
		call system_info_$prices_rs (rate_structure_number,
		     dummy_rate, dummy_rate, dummy_rate, dummy_rate, disk_rate, dummy_float);
		if disk_rate &gt; 0 then
		     call ioa_ ("trp price at current rate:^28t$^.2f", trp * disk_rate);
		call ioa_ ("");
	     end;
	end;

end print_line;
%page;
process_path: proc (P_path);

dcl P_path char (*);

	if dir_quota_sw then call hcs_$dir_quota_read (P_path, quota_value, trp, time_updated,
	     sons_lvid, terminal_quota, records_used, code);
	else call hcs_$quota_read (P_path, quota_value, trp, time_updated,
	     sons_lvid, terminal_quota, records_used, code);
	if code ^= 0 then do;
	     call complain (code, me, "^a", P_path);
	     return;
	end;

	if total_sw &amp; terminal_quota ^= 0 then
	     records_used = records_used + subdir_records_used (P_path);

	if nonzero_sw then
	     if records_used = 0 then return;
	     else some_nonzero = "1"b;
	else if zero_sw then
	     if records_used ^= 0 then return;
	     else some_zero = "1"b;

	call mdc_$find_lvname (sons_lvid, lvname, code);
	if code ^= 0 then call complain (code, me, "^a ^w", P_path, sons_lvid);

	total_quota = total_quota + quota_value;
	total_records_used = total_records_used + records_used;

	if records_left_sw then records_left = get_records_left (P_path, quota_value, records_used, terminal_quota);

	if af_sw then do;
	     call ioa_$rsnnl ("^[^d^;^s^]^[^d^;^s^]^[^d^]", return_arg, return_len,
		quota_sw, quota_value, records_left_sw, records_left, records_used_sw, records_used);
	     return;
	end;

	if ^sort_sw then call print_line (P_path);

	else do;					/* -sort: save data for sorting */
	     p = add_node ();
	     p -&gt; node.path = P_path;
	     p -&gt; node.lvname = lvname;
	     p -&gt; node.trp = trp;
	     p -&gt; node.time_updated = time_updated;
	     p -&gt; node.terminal_quota = terminal_quota;
	     p -&gt; node.quota_value = quota_value;
	     p -&gt; node.records_left = records_left;
	     p -&gt; node.records_used = records_used;
	     if sort_by = QUOTA then p -&gt; node.sort_value = quota_value;
	     else if sort_by = RECORDS_LEFT then p -&gt; node.sort_value = records_left;
	     else p -&gt; node.sort_value = records_used;
	end;

end process_path;
%page;
subdir_records_used: proc (P_dn) returns (fixed bin);

dcl P_dn char (*);
dcl path char (168);
dcl (eptr, nptr) ptr;
dcl (ecount, j, lcount, records_used, terminal_quota, total_ru) fixed bin;
dcl code fixed bin (35);

	eptr, nptr = null;
	on cleanup call local_cleanup;

	total_ru = 0;

	call hcs_$star_dir_list_ (P_dn, "**", star_BRANCHES_ONLY, area_ptr, ecount, lcount, eptr, nptr, code);
	if code = 0 &amp; ecount &gt; 0 then do;
	     star_branch_count = ecount;		/* to satisfy the structure declarations */
	     star_link_count = lcount;
	     star_select_sw = star_BRANCHES_ONLY;
	     do j = 1 to ecount;
		if eptr -&gt; star_dir_list_branch (j).type = star_DIRECTORY then do;
		     path = pathname_
			(P_dn, (nptr -&gt; star_list_names (eptr -&gt; star_dir_list_branch (j).nindex)));
		     if eptr -&gt; star_dir_list_branch (j).master_dir then call complain (0, me,
			"^a is a master directory; its quota will not be included in the total.", path);
		     else do;
			if dir_quota_sw then call hcs_$dir_quota_read (path, 0, 0, 0, "0"b,
			     terminal_quota, records_used, code);
			else call hcs_$quota_read (path, 0, 0, 0, "0"b,
			     terminal_quota, records_used, code);
			if code ^= 0 then call complain (code, me,
			     "^a^/Directory's quota will not be included in the total.", path);
			else if terminal_quota ^= 0 then
			     total_ru = total_ru + records_used + subdir_records_used (path);
		     end;
		end;
	     end;
	     call local_cleanup;
	end;
	else if code ^= 0 &amp; code ^= error_table_$nomatch then call complain (code, me, "^a", P_dn);

	return(total_ru);

local_cleanup: proc;

	star_list_branch_ptr = eptr;			/* to make the declaration happy */
	if nptr ^= null then free nptr -&gt; star_list_names in (area);
	if eptr ^= null then free eptr -&gt; star_dir_list_branch in (area);

end local_cleanup;

end subdir_records_used;
%page;
%include star_structures;

end move_quota;
���



		    nd_handler_.pl1                 10/06/92  0059.9r w 10/06/92  0057.3      136305



/****^  **************************************************************
        *                                                            *
        * Copyright, (C) BULL HN Information Systems Inc., 1992      *
        *                                                            *
        * Copyright, (C) Honeywell Information Systems Inc., 1983    *
        *                                                            *
        * Copyright, (C) Massachusetts Institute of Technology, 1983 *
        *                                                            *
        ************************************************************** */







/****^  HISTORY COMMENTS:
  1) change(92-09-24,Vu), approve(92-09-24,MCR8266), audit(92-09-24,Zimmerman),
     install(92-10-06,MR12.5-1025):
     Fix bug for add_name when adding a name to a forum meeting which is the
     only remaining name of another forum.
                                                   END HISTORY COMMENTS */


/* format: style2 */
nd_handler_:
     proc (caller, pname, ename, code);

/* this is an updated version of the name_dup
   handler for SSS commands. It attempts
   to remove an existing entry name from a directory,
   asking questions of the console as necessary.  */

/* initial coding 8 Aug 1969 David Clark */
/* revised 25 Aug 1969 DDC  */

/* modified on October 30, 1969 at 11:50 A. M. by V Voydock */
/* modified by E Stone on Dec 3 1970 */
/* modified by Dan Bricklin 9 Dec 1970 */
/* Modified by Dennis Capps on 11/04/71 */
/* Modified by Steve Herbst 4/15/76 */
/* Modified by C. D. Tavares 06/22/77 for force and del_force entries */
/* Changed to print link targets 11/02/79 S. Herbst */
/* Made to work on mailboxes and queues 03/28/80 S. Herbst */
/* 09/29/81 by Lindsey Spratt:Changed to return actual error code when
               unexpected error occurs.  Also, changed to ignore
               error_table_$vtoce_connection_fail from status_long. */
/* New message added "(Target PATH is a null link)" instead of "exists" 07/01/82 S. Herbst */
/* changed for object_type_, added switches entry 2/17/83 Jay Pattin */
/* removed check for connection failure, hardcore does not return entry information in this case. 6/10/83 Jay Pattin */
/* 830924 object_type_ --&gt; fs_util_ BIM  */

          dcl     (caller, pname, ename) char (*),
                  options                bit (36) aligned,
                  code                   fixed bin (35);

/* Link messages */

          dcl     TARGET_NULL_LINK       char (64) int static options (constant)
                                         init ("^/^8x(Target ^a^[&gt;^]^a is a null link.)");
          dcl     TARGET_EXISTS          char (64) int static options (constant) init ("^/^8x(Target ^a^[&gt;^]^a exists.)");
          dcl     TARGET_NOT_EXISTS      char (64) int static options (constant)
                                         init ("^/^8x(Target ^a^[&gt;^]^a does not exist.)");
          dcl     TARGET_NO_INFO         char (64) int static options (constant)
                                         init ("^/^8x(Cannot get info for target ^a^[&gt;^]^a)");
          dcl     TARGET_NO_PATH         char (64) int static options (constant) init ("^/^8x(No target pathname.)");

          dcl     LINK_TYPE              fixed bin (2) int static options (constant) init (0);

          dcl     icode                  fixed bin (35),
                  type                   fixed bin,
                  minf_type              fixed bin (2),
                  bit                    fixed bin (24);
          dcl     (link_msg, query_msg)  char (256);
          dcl     buff                   char (132) varying;
          dcl     fs_util_type           char (32);
          dcl     target_path            char (target_len) based (target_ptr);
          dcl     target_ptr             ptr init (null);
          dcl     target_len             fixed bin;
          dcl     target_dn              char (168);
          dcl     target_en              char (32);
          dcl     noun                   char (18) aligned;
          dcl     verb                   char (6) aligned;

          dcl     (
                  LINK                   init (0),
                  SEGMENT                init (1)
                  )                      fixed bin int static options (constant);
%page;
%include nd_handler_options;
%page;
%include delete_options;
%page;
%include query_info;
%page;
%include branch_status;

          dcl     1 link_status          aligned based (addr (branch_status)),
                  ( 2 type               bit (2),
                    2 nnames             fixed bin (15),
                    2 nrp                bit (18),
                    2 dtem               bit (36),
                    2 dtd                bit (36),
                    2 pnl                fixed bin (17),
                    2 pnrp               bit (18)
                    )                    unaligned;

          dcl     names                  (2) char (32) aligned based (np),
                  np                     pointer init (null),
                  old_seg                char (32) aligned;

          dcl     area_ptr               ptr int static init (null);
          dcl     area                   area based (area_ptr);

          dcl     error_table_$action_not_performed
                                         fixed bin (35) ext;
          dcl     error_table_$improper_data_format
                                         fixed bin (35) ext;
          dcl     error_table_$namedup   fixed bin (35) ext;
          dcl     error_table_$noentry   fixed bin (35) ext;
          dcl     error_table_$nonamerr  fixed bin (35) ext;

          dcl     (com_err_, command_query_)
                                         entry options (variable),
                  delete_$path           entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35)),
                  expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35)),
                  get_system_free_area_  entry returns (ptr),
                  hcs_$chname_file       entry (char (*), char (*), char (*), char (*), fixed bin (35)),
                  hcs_$get_link_target   entry (char (*), char (*), char (*), char (*), fixed bin (35)),
                  hcs_$status_minf       entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
                                         fixed bin (35)),
                  hcs_$status_long       entry (char (*), char (*), fixed bin, ptr, ptr, fixed bin (35)),
                  installation_tools_$chname_file
                                         entry (char (*), char (*), char (*), char (*), fixed bin (35)),
                  fs_util_$chname_file   entry (char (*), char (*), char (*), char (*), fixed bin (35));

	dcl     fs_util_$get_type      entry (character (*), character (*), character (*), fixed binary (35));
          dcl     (addr, fixed, null, ptr, rtrim, string, substr, unspec)
                                         builtin;

          dcl     cleanup                condition;
%page;
          string (nd_handler_options) = ""b;
          goto COMMON;

force:
     entry (caller, pname, ename, code);

/* nd_handler_$force is used to forcibly delete conflicting seg if necessary */

          string (nd_handler_options) = ""b;
          nd_handler_options.delete_force = "1"b;
          goto COMMON;

switches:
     entry (caller, pname, ename, options, code);

          string (nd_handler_options) = options;
          if nd_handler_options.mbz ^= ""b
          then do;
                    code = error_table_$improper_data_format;
                    return;
               end;

          if nd_handler_options.delete | nd_handler_options.delete_force
          then goto COMMON2;
          nd_handler_options.delete_force = nd_handler_options.force;

COMMON:
          code, icode = 0;
          if area_ptr = null
          then area_ptr = get_system_free_area_ ();
          on cleanup call clean_up;

          call hcs_$status_long (pname, ename, 0, addr (branch_status), area_ptr, code);
          if code ^= 0
          then do;
                    call com_err_ (code, caller, "^/Unable to get status information about ^a^[&gt;^]^a.", pname,
                         pname ^= "&gt;", ename);
                    return;
               end;

          code = 0;
          np = ptr (area_ptr, branch_status.names_rel_pointer);

          if names (1) = ename
          then if fixed (branch_status.number_names, 17) = 1
               then go to DELETE;
               else old_seg = names (2);
          else old_seg = names (1);

          if nd_handler_options.library
          then call installation_tools_$chname_file (pname, ename, ename, "", icode);
          else if nd_handler_options.raw
          then call hcs_$chname_file (pname, ename, ename, "", icode);
          else call fs_util_$chname_file (pname, ename, ename, "", icode);
                                                            /* works even for MSF's ! */

          if icode = 0
          then do;
                    call com_err_ (0, caller, "Name duplication. Old name ^a removed from ^a&gt;^a", ename, pname, old_seg);
                    return;
               end;

          if icode ^= error_table_$nonamerr
          then do;
                    code = icode;
                    call com_err_ (code, caller, "^/Unable to remove the old name ^a from ^a^[&gt;^]^a.", ename, pname,
                         pname ^= "&gt;", old_seg);
                    return;
               end;
          else /* only one name left, delete it */
               go to DELETE;

del:
     entry (caller, pname, ename, code);

/* This entry used if caller knows deletion is necessary */

          string (nd_handler_options) = ""b;
          goto COMMON2;

del_force:
     entry (caller, pname, ename, code);

/* This entry used if caller wants deletion performed forcibly */

          string (nd_handler_options) = ""b;
          nd_handler_options.delete_force = "1"b;

COMMON2:
          code = 0;
          if area_ptr = null
          then area_ptr = get_system_free_area_ ();
          on cleanup call clean_up;

          call hcs_$status_long (pname, ename, 0, addr (branch_status), area_ptr, code);
          if code ^= 0
          then do;
                    call com_err_ (code, caller, "^/Unable to get status information about ^a^[&gt;^]^a.", pname,
                         pname ^= "&gt;", ename);
                    return;
               end;
          code = 0;

DELETE:
          type = fixed (branch_status.type, 17);
          bit = fixed (branch_status.bit_count, 24);
          string (delete_options) = ""b;
          delete_options.force = "1"b;
          delete_options.raw = nd_handler_options.raw;

          if type = SEGMENT
          then do;
                    verb = "delete";
                    noun = "segment";
                    delete_options.segment = "1"b;
               end;

          else if type = LINK
          then do;
                    verb = "unlink";
                    delete_options.link = "1"b;
                    noun = "link";
                    target_len = link_status.pnl;
                    target_ptr = ptr (area_ptr, link_status.pnrp);
                    if target_path = ""
                    then link_msg = TARGET_NO_PATH;
                    else do;
                              call hcs_$get_link_target (pname, ename, target_dn, target_en, code);
                              if target_dn = ""
                              then call expand_pathname_ (target_path, target_dn, target_en, code);
                              call hcs_$status_minf (target_dn, target_en, 0, minf_type, 0, icode);
                              if icode = 0
                              then if minf_type = LINK_TYPE
                                   then link_msg = TARGET_NULL_LINK;
                                   else link_msg = TARGET_EXISTS;
                              else if icode = error_table_$noentry
                              then link_msg = TARGET_NOT_EXISTS;
                              else link_msg = TARGET_NO_INFO;
                         end;
               end;

          else do;
                    if bit ^= 0
                    then do;                                /* a multi-segment file */
                              verb = "delete";
                              noun = "multisegment file";
                              delete_options.segment = "1"b;
                         end;
                    else do;                                /* it is a directory */
                              verb = "delete";
                              noun = "directory";
                              call fs_util_$get_type (pname,ename,fs_util_type,code);
                              if code ^= 0 then return;
                              if substr (fs_util_type, 1, 1) ^= "-" then
                                 delete_options.segment = "1"b;
                              else delete_options.directory = "1"b;
                         end;
               end;

          call clean_up;                                    /* free hcs_$status storage */

          if ^nd_handler_options.delete_force
          then do;
                    unspec (query_info) = "0"b;
                    query_info.version = query_info_version_4;
                    query_info.yes_or_no_sw = "1"b;
                    query_info.question_iocbp, query_info.answer_iocbp = null;
                    query_info.status_code = error_table_$namedup;
                    query_msg = "Name duplication. Do you want to ^a the old ^a ^a&gt;^a?";
                    if type = LINK
                    then query_msg = rtrim (query_msg) || link_msg;
                    call command_query_ (addr (query_info), buff, caller, rtrim (query_msg) || "^3x", verb, noun, pname,
                         ename, target_dn, target_dn ^= "&gt;", target_en);
                    if buff = "no"
                    then do;
                              code = error_table_$action_not_performed;
                              return;
                         end;
               end;

          else do;
                    if type = LINK
                    then call com_err_ (error_table_$namedup, caller, "Unlinking the old link ^a&gt;^a" || link_msg, pname,
                              ename, target_dn, target_dn ^= "&gt;", target_en);
                    else call com_err_ (error_table_$namedup, caller, "Deleting the old ^a ^a&gt;^a", noun, pname, ename);
               end;

/* You really must want to get rid of it ... */

          call delete_$path (pname, ename, string (delete_options), caller, code);
          if code ^= 0
          then call com_err_ (code, caller, "^/Unable to remove old entry ^a^[&gt;^]^a.", pname, pname ^= "&gt;", ename);
          return;



clean_up:
     proc;

          if np ^= null
          then free names in (area);
          if target_ptr ^= null
          then free target_path in (area);

     end clean_up;

     end nd_handler_;
���



		    rename.pl1                      09/30/88  1303.1rew 09/30/88  1301.8      165933



/****^  **************************************************************
        *                                                            *
        * Copyright, (C) Honeywell Bull Inc., 1988                   *
        *                                                            *
        * Copyright, (C) Honeywell Information Systems Inc., 1983    *
        *                                                            *
        * Copyright, (C) Massachusetts Institute of Technology, 1983 *
        *                                                            *
        ************************************************************** */






/****^  HISTORY COMMENTS:
  1) change(88-09-20,TLNguyen), approve(88-09-20,MCR7976),
     audit(88-09-28,Parisek), install(88-09-30,MR12.2-1123):
     The rename command will print an appropriate error message when it
     finds that
        1. The new name of a specified storage system entry is improperly
           constructed without specifying the -name control argument.
        2. The returned code from XXX_$chname_file is non zero in value,
           where XXX can be either installation_tool_, hcs_, or fs_util_
                                                   END HISTORY COMMENTS */


/* format: style4,ifthenstmt,ifthen,^indcomtxt,^indproc,initcol1,declareind8,dclind4,struclvlind1 */
rename:
rn:
     procedure () options (variable);

/* This module implements the rename, add_name and delete_name commands.

   Usage:
   rename {-name} path1 {-name} name1 ... {-name} pathj {-name} namej

   where -name causes the following pathi or namei as a literal name
   (for pathi, in the working directory) without applying the star or
   equal conventions.

   add_name {-name} path {-name} name1 ... {-name} namej

   delete_name {-name} path1 ... {-name} pathj

   Written by Steve Herbst 12/09/76 */
/* Cleanup handling and control arg processing fixed 10/25/79 S. Herbst */
/* Made to work on mailboxes and queues 03/28/80 S. Herbst */
/* Bug fixes on 06/30/80 by G. Palter */
/* Fixed to not try to add the same name twice to the same seg 12/09/82 S. Herbst */
/* modified for object_type_ convention 1/26/83 Jay Pattin */
/* fixed -name, added l_rename and friends 2/27/83 Jay Pattin */
/* 830924 object_type_ --&gt; fs_util_ BIM */
/* Modified 2/10/84 by C Spitzer. allow $, disallow ? in added or renamed names */
/* Changed to allow -name before all args of all commands 03/27/84 S. Herbst */
/* Modified 1984.08.27 by M. Pandolf to use pathname_ and report pathname when starname doesn't match */
/* 850206 MSharpe to replace -fcnt with -inase/inaee */
/* Fixed cleanup bug causing null ptr fault for "rn a b x.* y.=" 04/05/85 Steve Herbst */


dcl 1 entries (ecount) aligned based (eptr),		/* entry info from hcs_$star_ */
     2 type bit (2) unaligned,
     2 nnames fixed bin (15) unaligned,
     2 nindex fixed bin (17) unaligned;

dcl names (99) char (32) aligned based (nptr);		/* names from hcs_$star_ */

dcl 1 added_names aligned based (added_names_ptr),
     2 (count, bound) fixed bin,
     2 array (added_names_bound refer (added_names.bound)),
      3 dn char (168),
      3 match fixed bin,				/* the number of the starname match from hcs_$star_ */
      3 name char (32);

dcl arg char (arg_len) based (arg_ptr);
dcl dn char (168);
dcl (command, en, name) char (32);

dcl (brief_sw, force_no_type, library_sw, literal_source, literal_target, stars) bit (1);

dcl area area based (area_ptr);

dcl area_ptr ptr int static init (null);
dcl (added_names_ptr, eptr, nptr) ptr init (null);
dcl arg_ptr ptr;

dcl (added_names_bound, arg_count, arg_len, ecount, i, k, match_index) fixed bin;
dcl code fixed bin (35);

dcl error_table_$bad_equal_name fixed bin (35) ext;
dcl error_table_$bad_file_name fixed bin (35) ext;
dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$entlong fixed bin (35) ext;
dcl error_table_$namedup fixed bin (35) ext;
dcl error_table_$noarg fixed binary (35) ext;
dcl error_table_$nomatch fixed binary (35) ext;
dcl error_table_$noentry fixed bin (35) ext;
dcl error_table_$nostars fixed bin (35) ext;
dcl error_table_$segnamedup fixed bin (35) ext;

dcl check_star_name_$entry entry (char (*), fixed bin (35));
dcl (
    active_fnc_err_,
    com_err_,
    com_err_$suppress_name
    ) entry options (variable);
dcl cu_$af_return_arg entry (fixed bin, pointer, fixed bin (21), 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_equal_name_ entry (char (*), char (*), char (32), fixed bin (35));
dcl get_system_free_area_ entry returns (ptr);
dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl installation_tools_$chname_file
         entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl nd_handler_$switches entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35));
dcl  pathname_ entry (char(*), char(*)) returns(char(168));
dcl fs_util_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35));

dcl (index, length, null, string) builtin;

dcl (cleanup, linkage_error) condition;
%page;
	command = "rename";
	library_sw = "0"b;
	goto RENAME_COMMON;

l_rename:
lrename:
lren:
     entry;

	library_sw = "1"b;
	command = "l_rename";

RENAME_COMMON:
	call cu_$af_return_arg (arg_count, (null ()), (0), code);
	if code = 0 then do;
NOT_ACT_FNC:
	     call active_fnc_err_ (0, command, "This command cannot be invoked as an active function.");
	     return;
	end;

	if arg_count &lt; 2 then do;
	     call com_err_$suppress_name (0, "rename", "Usage:  ^a path1 name1 ... pathj namej {-control_args}",
		command);
RETURN:
	     return;
	end;

	force_no_type = "0"b;
	do i = 1 to arg_count;			/* prescan for bad control arguments */
	     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
	     if index (arg, "-") = 1 then
		if (arg = "-name") | (arg = "-nm") then do;
		     i = i + 1;
		     if i &gt; arg_count then do;
NO_NAME_VALUE:
			call com_err_ (error_table_$noarg, command, "Value for -name");
			return;
		     end;
		end;
		else if ^library_sw &amp; (arg = "-interpret_as_standard_entry" | arg = "-inase")
		     then force_no_type = "1"b;

		else if (arg = "-interpret_as_extended_entry" | arg = "-inaee")
		     then force_no_type = "0"b;

		else do;
		     call com_err_ (error_table_$badopt, command, """^a""", arg);
		     return;
		end;
	end;

	on cleanup call clean_up;

	call allocate_added_names;

	do i = 1 by 2 to arg_count;

NEXT_ARG:
	     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
	     if arg = "-interpret_as_standard_entry" | arg = "-inase"
	      | arg = "-interpret_as_extended_entry" | arg = "-inaee"
	     then do;
		i = i + 1;
		if i &gt; arg_count then return;
		goto NEXT_ARG;
	     end;
	     if arg = "-name" | arg = "-nm" then do;
		literal_source = "1"b;
		i = i + 1;
		call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
	     end;
	     else literal_source = "0"b;

	     call get_path;

	     if code ^= 0
	     then if code = error_table_$nomatch
		then call com_err_ (code, command, "For ^a.", pathname_ (dn, en));
		else call com_err_ (code, command, "^a", arg);
	     else do;
		if (i + 1) &gt; arg_count then do;
		     call com_err_ (error_table_$noarg, command, "New name for ^a.", pathname_ (dn, en));
		     return;
		end;
		call cu_$arg_ptr (i + 1, arg_ptr, arg_len, (0));

		if arg = "-name" | arg = "-nm" then do;
		     literal_target = "1"b;
		     i = i + 1;
		     call cu_$arg_ptr (i + 1, arg_ptr, arg_len, (0));
		end;
		else literal_target = "0"b;

		call get_name;

		if code ^= 0 then call com_err_ (code, command, "^a", arg);

		else call change_names (en, name);
	     end;

	     call clean_up_stars ();
	end;

	return;
%page;
add_name:
addname:
an:
     entry () options (variable);

	command = "add_name";
	library_sw = "0"b;
	goto ADDNAME_COMMON;

l_add_name:
laddname:
lan:
     entry;

	command = "l_add_name";
	library_sw = "1"b;

ADDNAME_COMMON:
	call cu_$af_return_arg (arg_count, (null ()), (0), code);
	if code = 0 then go to NOT_ACT_FNC;

	if arg_count &lt; 2 then do;
ADD_NAME_USAGE:
	     call com_err_$suppress_name (0, "", "Usage:  ^a path names {-control_args}", command);
	     return;
	end;

	brief_sw, force_no_type = "0"b;
	do i = 1 to arg_count;			/* prescan for control arguments */
	     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
	     if index (arg, "-") = 1 then do;
		if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;
		else if arg = "-long" | arg = "-lg" then brief_sw = "0"b;
		else if arg = "-name" | arg = "-nm" then do;
		     i = i + 1;
		     if i &gt; arg_count then go to NO_NAME_VALUE;
		end;
		else if ^library_sw
		      &amp; (arg = "-interpret_as_standard_entry" | arg = "-inase")
		     then force_no_type = "1"b;
		else if arg = "-interpret_as_extended_entry" | arg = "-inaee"
		     then force_no_type = "0"b;
		else do;
		     call com_err_ (error_table_$badopt, command, "^a", arg);
		     return;
		end;
	     end;
	end;

	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
	     if index (arg, "-") ^= 1 then do;
		literal_source = "0"b;
		go to FOUND_NAME;
	     end;
	     else if arg = "-name" | arg = "-nm" then do;
		literal_source = "1"b;
		i = i + 1;
		call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
		go to FOUND_NAME;
	     end;
	end;
	go to ADD_NAME_USAGE;

FOUND_NAME:
	on cleanup call clean_up;

	call get_path;

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

	if i = arg_count then go to ADD_NAME_USAGE;	/* no names to be added */

	call allocate_added_names;

	do i = i + 1 to arg_count;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
	     if index (arg, "-") ^= 1 then do;
		literal_target = "0"b;
ADD_THE_NAME:
		call get_name;

		if code ^= 0 then call com_err_ (code, command, "^a", arg);

		else call change_names ("", name);
	     end;
	     else if arg = "-name" | arg = "-nm" then do;
		literal_target = "1"b;
		i = i + 1;
		call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
		go to ADD_THE_NAME;
	     end;
	end;

	call clean_up;

	return;
%page;
delete_name:
deletename:
dn:
     entry () options (variable);

	command = "delete_name";
	library_sw = "0"b;
	goto DELETE_NAME_COMMON;

l_delete_name:
ldeletename:
ldn:
     entry;

	command = "l_delete_name";
	library_sw = "1"b;

DELETE_NAME_COMMON:
	call cu_$af_return_arg (arg_count, (null ()), (0), code);
	if code = 0 then go to NOT_ACT_FNC;

	if arg_count = 0 then do;
	     call com_err_$suppress_name (0, "", "Usage:  ^a paths {-control_args}", command);
	     return;
	end;

	brief_sw, force_no_type = "0"b;

	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
	     if index (arg, "-") = 1 then do;
		if arg = "-name" | arg = "-nm" then do;
		     i = i + 1;			/* skip arg following -name */
		     if i &gt; arg_count then go to NO_NAME_VALUE;
		end;
		else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;
		else if arg = "-long" | arg = "-lg" then brief_sw = "0"b;
		else if ^library_sw
		      &amp; (arg = "-interpret_as_standard_entry" | arg = "-inase")
		     then force_no_type = "1"b;
		else if arg = "-interpret_as_extended_entry" | arg = "-inaee"
		     then force_no_type = "0"b;

		else do;
		     call com_err_ (error_table_$badopt, command, "^a", arg);
		     return;
		end;
	     end;
	end;

	on cleanup call clean_up;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));

	     if index (arg, "-") ^= 1 then do;
		literal_source = "0"b;
DELETE_THE_NAME:
		call get_path;

		if code ^= 0 then do;
		     if ^brief_sw | code ^= error_table_$nomatch then
			call com_err_ (code, command, "^a", arg);
		end;

		else call change_names (en, "");

		call clean_up_stars ();
	     end;
	     else if arg = "-name" | arg = "-nm" then do;
		literal_source = "1"b;
		i = i + 1;
		call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
		go to DELETE_THE_NAME;
	     end;
	end;

	return;
%page;
get_path:
     procedure ();

/* This internal procedure expands a pathname argument and applies the star convention. */

	code = 0;

	if index (arg, "-") = 1 &amp; ^literal_source then do;
	     call com_err_ (error_table_$badopt, command, "^a", arg);
	     go to RETURN;
	end;

	call expand_pathname_ (arg, dn, en, code);
	if code ^= 0 then return;

	if literal_source then do;
	     stars = "0"b;
	     return;
	end;

	if en ^= "" then call check_star_name_$entry (en, code);
	if code = 0 then stars = "0"b;
	else if code &lt; 3 then do;			/* star convention */
	     stars = "1"b;
	     if area_ptr = null then area_ptr = get_system_free_area_ ();

	     call hcs_$star_ (dn, en, 3, area_ptr, ecount, eptr, nptr, code);
	end;

end get_path;
%page;
get_name:
     procedure ();

/* This internal procedure checks for a valid entryname and applies the equal convention. */

dcl type fixed bin (2);

dcl check_star_name_       entry (char (*), bit (36) aligned, fixed bin (2), fixed bin (35));

	code = 0;
	type = 0;

	if arg_len &gt; length (name) then do;
	     code = error_table_$entlong;
	     return;
	end;

	name = arg;

	if literal_target then return;

	if index (arg, "-") = 1 then do;
	     call com_err_ (error_table_$badopt, command, "^a", arg);
	     go to RETURN;
	end;

	call check_star_name_ (arg, (CHECK_STAR_IGNORE_EQUAL), type, code);
	if code ^= 0 then do;
	     call com_err_ (code, command, "^a", arg);
	     goto RETURN;
	end;

	if type ^= 0 then do;
	     call com_err_ (error_table_$nostars, command, "^a", arg);
	     goto RETURN;
	end;


	call get_equal_name_ ("a.a.a.a.a.a.a.a.a.a.a.a.a.a.a.a", arg, "", code);
						/* see if valid equal name */
	if code ^= error_table_$bad_equal_name then code = 0;	/* might be valid */

/* This call tests for syntax errors in the equal name, for example "a.===.b".
   It is a preliminary test before we know which entry names match the starname en.
   Therefore, the equal name is applied to a dummy containing the maximum number of
   components (16) rather than the starname, which can have too few components
   even though some matching entry names have enough components. */

end get_name;
%page;
change_names:
     procedure (P_old_name, P_equal_name);

/* This internal procedure calls its internal procedure change_name for each starname match. */

dcl (P_old_name, P_equal_name) char (*);
dcl new_name char (32);

	if ^stars	then call change_name;

	else do match_index = 1 to ecount;

	     do k = entries (match_index).nindex
		to entries (match_index).nindex + entries (match_index).nnames - 1;

		en = names (k);

		call change_name;
	     end;
NEXT_STAR:
	end;
%page;
change_name:
     procedure ();

/* This internal procedure performs the name change for all three commands. */

dcl i fixed bin;

	if command = "delete_name" | command = "l_delete_name" then new_name = "";
	else do;
	     if literal_target then new_name = P_equal_name;  /* if -name given, don't apply equals convention */
	     else do;
		call get_equal_name_ (en, P_equal_name, new_name, code);
		if code ^= 0 then do;
		     call com_err_ (code, command, "^a for ^a", P_equal_name, en);
		     return;
		end;
	     end;
	     if stars then do;
		do i = added_names.count by -1 to 1
		     while (dn ^= added_names.dn (i) | match_index ^= added_names.match (i)
		     | new_name ^= added_names.name (i));
		end;
		if i &gt; 0 then			/* already added this name to this segment */
		     if command = "add_name" | command = "l_add_name" then return;
		     else new_name = "";		/* rename: just delete the name to rename */

		added_names.count = added_names.count + 1;
		if added_names.count &gt; added_names.bound then call grow_added_names;
		added_names.dn (added_names.count) = dn;
		added_names.match (added_names.count) = match_index;
		added_names.name (added_names.count) = new_name;
	     end;
	end;

TRY:
	if library_sw then do;
	     on linkage_error begin;
		     call com_err_ (0, command, "The user lacks access to installation_tools_.");
		     goto RETURN;
		end;

	     call installation_tools_$chname_file (dn, en, P_old_name, new_name, code);
	     revert linkage_error;
	end;
	else if force_no_type then call hcs_$chname_file (dn, en, P_old_name, new_name, code);
	else call fs_util_$chname_file (dn, en, P_old_name, new_name, code);

	if code ^= 0 then do;
	     if code = error_table_$namedup then do;
		string (nd_handler_options) = ""b;
		nd_handler_options.raw = force_no_type;
		nd_handler_options.library = library_sw;
		call nd_handler_$switches (command, dn, new_name, string (nd_handler_options), code);
		if code = 0 then go to TRY;
	     end;
	     else if code = error_table_$segnamedup then
		if brief_sw &amp; command = "add_name" then;	/* "an -bf" suppresses this message */
		else call com_err_ (code, command, "^a on ^a.", new_name, pathname_ (dn, en));
	     else if code = error_table_$noentry &amp; (command = "delete_name" | command = "l_delete_name") &amp;
		brief_sw then return;
	     else if code = error_table_$bad_file_name then
		call com_err_ (code, command, "^a", new_name);
	     else do;
		call com_err_ (code, command, "^a", pathname_ (dn, en));
		if command = "add_name" | command = "l_add_name" then
		     if stars then go to NEXT_STAR;
		     else go to RETURN;
	     end;
	end;

end change_name;

end change_names;
%page;
allocate_added_names:
     proc;

	area_ptr = get_system_free_area_ ();
	added_names_bound = 50;

	allocate added_names in (area) set (added_names_ptr);

	added_names.count = 0;

end allocate_added_names;
%page;
grow_added_names:
     proc;

dcl old_ptr ptr;
dcl i fixed bin;

	old_ptr = added_names_ptr;
	added_names_bound = 2 * added_names_bound;

	allocate added_names in (area) set (added_names_ptr);

	added_names.count = old_ptr -&gt; added_names.count;
	do i = 1 to added_names.count;
	     added_names.array (i) = old_ptr -&gt; added_names.array (i);
	end;

	free old_ptr -&gt; added_names in (area);

end grow_added_names;
%page;
clean_up:
     proc;

	if eptr ^= null then free entries in (area);
	if nptr ^= null then free names in (area);
	if added_names_ptr ^= null then free added_names in (area);

     end clean_up;
%page;
clean_up_stars:
     proc;

	if eptr ^= null then free entries in (area);
	if nptr ^= null then free names in (area);

     end clean_up_stars;
%page;
%include check_star_name;
%page;
%include nd_handler_options;


end rename;
���



		    set_bit_count.pl1               10/25/83  1546.8r w 10/25/83  1444.6       44415



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */




/* format: style2,idind30,indcomtxt */

set_bit_count:
sbc:
     procedure options (variable);

/* procedure to set the bit count on segments */
/* coded by M. Weaver on  28 November 1969  11:00 A.M.  */
/* modified by M. Weaver  22 January 1970 */
/* modified to reject too large bit count 9/15/76 S. Herbst */
/* Modified 2/20/83 Jay Pattin for object_type_ */
/* 830924 BIM for fs_util_ */

          dcl     dirname                       char (168);
          dcl     arg                           char (argl) based (argp) unaligned;
          dcl     ename                         char (32);
          dcl     bitcnt                        fixed bin (24);
          dcl     bc_35                         fixed bin (35);
          dcl     argl                          fixed bin (21);
          dcl     i                             fixed bin;
          dcl     argp                          ptr;
          dcl     arg_count                     fixed bin;
          dcl     (
                  code,
                  error_table_$noarg            ext
                  )                             fixed bin (35);
          dcl     cv_dec_check_                 entry (char (*), fixed bin (35)) returns (fixed bin (35));
          dcl     err_name                      char (16) static init ("set_bit_count") options (constant);
          dcl     expand_pathname_              entry (char (*), char (*), char (*), fixed bin (35));
          dcl     fs_util_$set_bit_count        entry (char (*), char (*), fixed bin (24), fixed bin (35));
          dcl     com_err_                      entry options (variable);
          dcl     cu_$arg_count                 entry (fixed bin, fixed bin (35));
          dcl     cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
          dcl     check_star_name_$entry        entry (char (*), fixed bin (35));
          dcl     error_table_$nostars          fixed bin (35) ext static;
          dcl     pathname_                     entry (char (*), char (*)) returns (char (168));
          dcl     mod                           builtin;




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

          if arg_count = 0 | mod (arg_count, 2) ^= 0
          then do;
                    call com_err_ (0, err_name, "Usage: set_bit_count path1 bit_count1 ... pathN bit_countN");
                    return;
               end;

          do i = 1 by 2 to arg_count;
               call cu_$arg_ptr (i, argp, argl, (0));
               call expand_pathname_ (arg, dirname, ename, code);
               if code ^= 0
               then do;
                         call com_err_ (code, err_name, "^a", arg);
                         return;
                    end;
               call check_star_name_$entry (ename, code);
               if code = 1 | code = 2
               then code = error_table_$nostars;
               if code ^= 0
               then do;
                         call com_err_ (code, err_name, "^a.", arg);
                         return;
                    end;

               call cu_$arg_ptr (i + 1, argp, argl, (0));
               if argl = 0
               then do;
                         call com_err_ (0, err_name, "Null argument supplied as bit count for ^a.",
                              pathname_ (dirname, ename));
                         return;
                    end;

               bc_35 = cv_dec_check_ (arg, code);
               if code ^= 0
               then do;

                         call com_err_ (0, err_name, "Illegal decimal digits in bit count ^a for ^a", arg,
                              pathname_ (dirname, ename));

                         return;
                    end;

               if bc_35 &gt; 2 ** 24 - 1
               then do;
                         call com_err_ (0, err_name, "Bit count ^d is larger than the maximum 2**24-1.", bc_35);
                         return;
                    end;
               else bitcnt = bc_35;
               call fs_util_$set_bit_count (dirname, ename, bitcnt, code);
               if code ^= 0
               then do;
                         call com_err_ (code, err_name, "^a", pathname_ (dirname, ename));
                         return;
                    end;

          end;

          return;
     end set_bit_count;
�



		    status.pl1                      05/10/89  0951.8rew 05/10/89  0947.5      791460



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(87-02-17,TLNguyen), approve(87-02-17,MCR7622),
     audit(87-02-25,Gilcrease), install(87-03-23,MR12.1-1008):
     - Make "status" active function returns the current length when the
       "-length" control argument is specified.
     - Add the "-nonstandard_names" (-nsn) control argument to the status
       command or active function.
  2) change(87-02-24,TLNguyen), approve(87-02-24,MCR7620),
     audit(87-02-25,Gilcrease), install(87-03-23,MR12.1-1008):
     - Change "status" command to always display an appropriate error message
       if "-chase" control argument is specified and the entry is a null link.
     - Change "status" command to always skip printing an error message if the
       code received from "file_manager_$status" is "A transaction is currently
       in progress."
     - Change "status" to always display an error message if specified paths
       are directories, MSFs, DM files, and links and the "-synchronized_
       switch" is specified.
     - Change "status" to always call "msf_manager_$close" when it finishes for
       an MSF and to always call "cleanup" internal procedure when it finishes.
     - Change "status" to always not display a specified MSF's contents which
       appeared at the end of the error message.
  3) change(87-03-25,TLNguyen), approve(87-03-25,MCR7620),
     audit(87-03-25,Gilcrease), install(87-03-25,MR12.1-1015):
               PBF to last installation, status with no arguments ok now.
  4) change(87-09-04,TLNguyen), approve(87-09-04,PBF7620),
     audit(87-09-04,Farley), install(87-09-09,MR12.1-1099):
     status with MSFs and -all control argument work ok now.
  5) change(88-01-29,TLNguyen), approve(88-01-29,MCR7833),
     audit(88-02-02,Lippard), install(88-02-02,MR12.2-1020):
     Make status with -length work as documented when it is used as a command.
  6) change(88-05-12,Lippard), approve(88-05-02,MCR7881),
     audit(88-06-09,Fawcett), install(88-08-02,MR12.2-1074):
     Add -audit_switch, -asw.
  7) change(89-04-06,Vu), approve(89-04-06,MCR8096), audit(89-04-26,Lee),
     install(89-05-10,MR12.3-1040):
     status -switch SW_NAME yields bogus error for link and the date returned
     by status for the root does not use the user's default date/time format.
     Reformatted status.pl1
                                                   END HISTORY COMMENTS */



/* format: style4,ifthenstmt,^indproc */

status: st: procedure options (variable);

/* WARNING: Some hcs_ entries are mis-declared with char (*) aligned */

/* This command and active function returns selected
   attributes of storage system entries. */

/* Written 5/20/76 by Steve Herbst */
/* Control args -dr, -lk, -sm added and [st -nm] names quoted 09/28/79 S. Herbst */
/* Changed to print damaged switch (if on) by default 03/19/80 S. Herbst */
/* Fix dates reported for MSF's (most recent date of all components) 01/06/81 S. Herbst */
/* Chasing fixed, -chase_if_possible added, -records_used -&gt; -records 01/12/81 S. Herbst */
/* Fixed bug in MSF processing 10/01/81 S. Herbst */
/* fixed not to assume 168 char link pathname BIM 3/82 */
/* Added printing of synchronized switch, J. Bongiovanni, September 1982 */
/* Fixed to handle et_$vtoce_connection_fail like et_$logical_volume_not_connected 11/23/82 S. Herbst */
/* Changed back again to treat VTOCE errors as errors, since no info can be trusted. 12/07/82 S. Herbst */
/* Simple support for object_type_ 2/24/83 Jay Pattin */
/* Added entry_bound, -switch, changed behavior of -all w/switches 6/2/83 Jay Pattin */
/* 830924 object_type_ --&gt; fs_util_, BIM */
/* Modified 11/21/83 by C Spitzer. fix lots of bugs */
/* Fixed to not free switch_list when switch_list_ptr is null, 1984.02.16, MAP */
/* Modified 07/18/84 by Jim Lippard to only allocate names when they're
   asked for and to free them properly */
/* Modified 84-09-17 by JAFalksen. Utilize date_time_$format("date_time",... */
/* Modified 01/11/84 by C Spitzer. work on root (changes adapted by Steve Herbst) */
/* Changed to work on DM files 10/23/84 Steve Herbst */
/* Added extended entry type control args -select_entry_type, changed -force_no_type to -inase 11/20/84 M. Pandolf */
/* Changed -no_(concurrency rollback)_sw to -(concurrency rollback)_sw 12/04/84 Steve Herbst */
/* Fixed mode value for DM files 01/11/85 Steve Herbst */
/* Modified 02/05/85 by M. Sharpe to implement -slet correctly and to complain
   about unsupported operation when type does not have ring brackets, extended
   mode, max length, etc. */
/* Fixed to print DM file switches without a transaction in effect 02/26/85 Steve Herbst */


/* DECLARATIONS */

/* Options structure. Various settings for it are at the back of the listing. */

dcl  1 opt,					/* attributes to be requested */
       (2 primary_name,				/* -primary, -pri */
       2 names,					/* -name, -names, -nm */
       2 type,					/* -type, -tp */
       2 link_path,					/* -link_path, -lp */
       2 unique_id,					/* -unique_id, -uid */
       2 dtu,					/* -date_time_used, -dtu */
       2 dtcm,					/* -date_time_contents_modified, -dtcm */
       2 dtem,					/* -date_time_entry_modified, -dtem */
       2 dtd,					/* -date_time_dumped, -dtd */
       2 dtvd,					/* -date_time_volume_dumped, -dtvd */
       2 author,					/* -author, -at */
       2 bc_author,					/* -bc_author, -bca */
       2 logical_volume,				/* -logical_volume, -lv, -device, -dv */
       2 bit_count,					/* -bit_count, -bc */
       2 records_used,				/* -records, -rec */
       2 current_length,				/* -current_length, -cl */
       2 max_length,				/* -max_length, -ml */
       2 mode,					/* -mode, -md */
       2 access_class,				/* -access_class, -acc */
       2 ring_brackets,				/* -ring_brackets, -rb */
       2 safety_switch,				/* -safety_switch, -ssw */
       2 copy_switch,				/* -copy_switch, -csw */
       2 audit_switch,				/* -audit_switch, -asw */
       2 ivds,					/* -incr_volume_dump_switch, -ivds */
       2 cvds,					/* -comp_volume_dump_switch , -cvds */
       2 usage_count,				/* -usage_count, -use */
       2 damaged_switch,				/* -damaged_switch, -dsw */
       2 synchronized_switch,				/* -synchronized_switch, -synch */
       2 entry_bound				/* -entry_bound, -eb */
       ) bit (1) unaligned,
       2 dm_files_only,
         (3 highest_ci,				/* -highest_control_interval, -hci */
         3 concurrency_switch,			/* -concurrency_sw, -concsw */
         3 rollback_switch,				/* -rollback_sw, -rlbsw */
         3 protected_switch				/* -protected_sw, -psw */
         ) bit (1) unaligned;


dcl  1 explicit_opt like opt;				/* attributes explicitly requested */

dcl  1 saved_options like opt;			/* saved copy of opt */

dcl  ALL_OPTIONS bit (33) aligned int static options (constant) init ((33)"1"b); /* for -all */

dcl  LONG_OPTION (33) char (64) int static options (constant) init
	("-primary", "-name", "-type", "-link_path", "-unique_id",
	"-date_time_used", "-date_time_contents_modified", "-date_time_entry_modified",
	"-date_time_dumped", "-date_time_volume_dumped", "-author", "-bc_author",
	"-logical_volume", "-bit_count", "-records", "-current_length", "-max_length",
	"-mode", "-access_class", "-ring_brackets", "-safety_switch", "-copy_switch",
	"-audit_switch", "-incr_volume_dump_switch", "-comp_volume_dump_switch", "-usage_count",
	"-damaged_switch", "-synchronized_switch", "-entry_bound",
						/* (DM file options:) */
	"-highest_control_interval", "-concurrency_sw", "-rollback_sw", "-protected_sw");

dcl  SHORT_OPTION (33) char (8) int static options (constant) init
	("-pri", "-nm", "-tp", "-lp", "-uid",
	"-dtu", "-dtcm", "-dtem", "-dtd", "-dtvd", "-at", "-bca",
	"-lv", "-bc", "-rec", "-cl", "-ml",
	"-md", "-acc", "-rb", "-ssw", "-csw", "-asw",
	"-ivds", "-cvds", "-use",
	"-dsw", "-synch", "-eb",
	"-hci", "-concsw", "-rlbsw", "-psw");


dcl  1 bks aligned like status_for_backup;

dcl  1 link_status aligned based (addr (branch_status)),	/* status for link entries */
       2 type bit (2) unaligned,
       2 nnames bit (16) unaligned,
       2 nrp bit (18) unaligned,
       2 dtlm bit (36) unaligned,
       2 dtd bit (36) unaligned,
       2 pnl fixed bin (18) uns unaligned,
       2 pnrp bit (18) unaligned;

dcl  1 msf_info aligned,				/* status for MSF components */
       2 type bit (2) unaligned,
       2 nnames bit (16) unaligned,
       2 names_offset bit (18) unaligned,
       2 dtcm bit (36) unaligned,
       2 dtu bit (36) unaligned,
       2 mode bit (5) unaligned,
       2 pad bit (13) unaligned,
       2 records fixed bin (17) unaligned,
       2 dtd bit (36) unaligned,
       2 dtem bit (36) unaligned,
       2 pad3 bit (36) unaligned,
       2 current_length fixed bin (11) unaligned,
       2 bit_count bit (24) unaligned,
       2 pad2 bit (18) unaligned,
       2 rbs (0:2) fixed bin (5) unaligned,
       2 pad4 bit (36) unaligned;

dcl  branch_names (0:99) char (32) based (branch_names_ptr);/* names from hcs_$status_long */

dcl  ROOT_NAMES (1) char (32) int static options (constant) init ("&gt;");

dcl  1 si aligned like suffix_info;

dcl  1 auto_dm_file_status aligned like dm_file_status;

dcl  1 path_array (path_array_size) aligned based (path_array_ptr),
       2 path_ptr ptr,
       2 path_len fixed bin,
       2 nonstandard_names_flag bit (1) aligned;
dcl  1 slet_path_array (slet_path_array_size) aligned based (slet_path_array_ptr) like path_array;
dcl  1 path_array_space (25) like path_array;

dcl  dates_array (5) bit (36);

dcl  1 combined_options,
       (2 access,					/* -access */
       2 all,					/* -all */
       2 dates,					/* -date */
       2 lengths					/* -length */
       ) bit (1) unaligned;

dcl  1 fs_entry_type aligned based (fs_entry_type_ptr),
       2 count fixed bin,
       2 suffix char (32) unaligned dim (fs_entry_type_count refer (fs_entry_type.count));

dcl  1 fs_time_value aligned based,
       2 pad1 bit (20) unal,
       2 time bit (36) unal,
       2 pad2 bit (16) unal;

dcl  temp_clock fixed bin (71);
dcl  stime bit (36);
dcl  switch_names (10) char (32);			/* for -switch */
dcl  mode_bits (5) bit (1) unaligned;
dcl  ring_brackets (8) fixed bin (3);

/* Constants */

dcl  ME char (32) int static options (constant) init ("status");
dcl  INITIALIZER_ID char (32) int static options (constant) init ("Initializer.SysDaemon.z");
dcl  EXTENDED_type fixed bin int static options (constant) init (5);
dcl  (CHASE init (1), NO_CHASE init (0)) fixed bin int static options (constant);

/* Based */

dcl  area area based (area_ptr);
dcl  arg char (arg_len) based (arg_ptr);
dcl  return_string char (return_len) varying based (return_ptr);
dcl  slet_path char (slet_path_len) based (slet_path_ptr);
dcl  target_path char (target_len) based (target_ptr);

/* Automatic */

dcl  slet_area area;

dcl  date_string char (64) varying;
dcl  mode_string char (36) varying;

dcl  (class, temp_string) char (336);			/* ASCII access class */
dcl  (dn, msf_path, saved_dn, target_dn) char (168);
dcl  (author_string, bc_author_string, comp_name, en, fs_type, fs_util_type) char (32);
dcl  (lv_string, saved_en, star_en, target_en) char (32);
dcl  type_string char (32);				/* avoid string size condition while compiling. */

dcl  access_class bit (72) aligned;
dcl  (exmodes, local_unique_id, modes) bit (36) aligned;
dcl  (bc36, msf_dtcm, msf_dtd, msf_dtem, msf_dtu) bit (36);
dcl  switch_mask bit (10) aligned;
dcl  (active_function, chase, chase_if_possible, chased, dir_sw, dm_file_sw, interpret_as_standard_entry) bit (1) aligned;
dcl  (link_sw, matched, msf, msf_error, one_item, printed_pathname, printed_something) bit (1) aligned;
dcl  (root_sw, safety_switch, seg_sw, selecting_by_entry_type, star_sw) bit (1) aligned;

dcl  (area_ptr, arg_ptr, branch_names_ptr, comp_ptr, fs_entry_type_ptr, msf_ptr) ptr;
dcl  (path_array_ptr, return_ptr, slet_path_array_ptr, slet_path_ptr, target_ptr) ptr;

dcl  status_chase fixed bin (1);
dcl  entry_type fixed bin (3);
dcl  (arg_count, arg_len, class_len, cvds, entry_type_index, extended_type_count, fs_entry_type_count, i, ivds) fixed bin;
dcl  (j, k, kk, path_array_size, path_count, return_len, slet_path_array_size, slet_path_len) fixed bin;
dcl  (switch_count, switch_length, target_len, total_length, total_records) fixed bin;
dcl  max_length fixed bin (19);
dcl  total_bit_count fixed bin (24);
dcl  (bc35, code, usage_count) fixed bin (35);

/* External */

dcl  dm_error_$transaction_in_progress fixed bin (35) ext;
dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$inconsistent fixed bin (35) ext;
dcl  error_table_$incorrect_access fixed bin (35) ext;
dcl  error_table_$logical_volume_not_connected fixed bin (35) ext;
dcl  error_table_$logical_volume_not_defined fixed bin (35) ext;
dcl  error_table_$moderr fixed bin (35) ext;
dcl  error_table_$no_s_permission fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  error_table_$noentry fixed bin (35) ext;
dcl  error_table_$nomatch fixed bin (35) ext;
dcl  error_table_$not_act_fnc fixed bin (35) ext;
dcl  error_table_$root fixed bin (35) ext;
dcl  error_table_$segknown fixed bin (35) ext;
dcl  error_table_$unsupported_operation fixed bin (35) ext;

/* Entries */

dcl  complain entry variable options (variable);

dcl  active_fnc_err_ entry options (variable);
dcl  check_star_name_$entry entry (char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_group_id_ entry () returns (char (32));
dcl  get_system_free_area_ entry returns (ptr);
dcl  get_wdir_ entry returns (char (168));
dcl  file_manager_$status entry (char (*), char (*), ptr, fixed bin (35));
dcl  fs_util_$get_type entry (char (*), char (*), char (*), fixed bin (35));
dcl  fs_util_$get_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35));
dcl  fs_util_$get_ring_brackets entry (char (*), char (*), (*) fixed bin (3), fixed bin (35));
dcl  fs_util_$get_switch entry (char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
dcl  fs_util_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
	bit (36) aligned, fixed bin (35));
dcl  fs_util_$list_switches_for_type entry (char (*), char (*), ptr, ptr, fixed bin (35));
dcl  fs_util_$suffix_info_for_type entry (char (*), ptr, fixed bin (35));
dcl  hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35));
dcl  hcs_$get_dates entry (char (*), char (*), (5) bit (36), fixed bin (35));
dcl  hcs_$get_author entry (char (*), char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$get_bc_author entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$get_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35));
dcl  hcs_$get_safety_sw entry (char (*), char (*), bit (1) aligned, fixed bin (35));
dcl  hcs_$get_volume_dump_switches entry (char (*), char (*), fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$status_for_backup entry (char (*), 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  ioa_$nnl entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  mdc_$find_lvname entry (bit (36), char (*), fixed bin (35));
dcl  mhcs_$get_seg_usage entry (char (*), char (*), fixed bin (35), fixed bin (35));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  requote_string_ entry (char (*)) returns (char (*));

/* Builtins */

dcl  (addr, after, before, bin, binary, clock, convert, divide, fixed, hbound, index, null) builtin;
dcl  (length, max, ptr, reverse, rtrim, string, substr, unspec, verify, empty) builtin;

/* Conditions */

dcl  (cleanup, linkage_error) condition;

/* END OF DECLARATIONS */
%page;
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = error_table_$not_act_fnc then do;
	     active_function = "0"b;
	     complain = com_err_;
	end;
	else do;
	     active_function = "1"b;
	     complain = active_fnc_err_;
	end;

	code = 0;					/* must reset code to 0 */
	string (opt) = "0"b;
	string (combined_options) = "0"b;
	chase, chase_if_possible, dir_sw, dm_file_sw, interpret_as_standard_entry, link_sw, root_sw, seg_sw = "0"b;
	area_ptr = get_system_free_area_ ();

	path_array_ptr = addr (path_array_space);
	fs_entry_type_ptr, star_list_branch_ptr, star_list_names_ptr = null;
	selecting_by_entry_type = ""b;

	on cleanup call CLEAN_UP ();

	path_array_size = arg_count;
	if path_array_size &gt; hbound (path_array_space, 1) then
	     allocate path_array in (area) set (path_array_ptr);

	path_count, switch_count = 0;
	switch_length = 13;

	do i = 1 to arg_count;

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

	     if substr (arg, 1, 1) ^= "-" then do;
		path_count = path_count + 1;
		path_array.path_ptr (path_count) = arg_ptr;
		path_array.path_len (path_count) = arg_len;
		path_array.nonstandard_names_flag (path_count) = "0"b;
	     end;

	     else if arg = "-working_dir" | arg = "-wd" then do;
		path_count = path_count + 1;
		path_array.path_len (path_count) = 0;	/* use expand_path_'s working dir feature */
		path_array.nonstandard_names_flag (path_count) = "0"b;
	     end;

	     else if arg = "-chase" then chase = "1"b;
	     else if arg = "-no_chase" then chase = "0"b;
	     else if arg = "-chase_if_possible" | arg = "-cip" then chase_if_possible = "1"b;
	     else if arg = "-no_chase_if_possible" | arg = "-ncip" then chase_if_possible = "0"b;
	     else if arg = "-directory" | arg = "-dr" then dir_sw = "1"b;
	     else if arg = "-link" | arg = "-lk" then link_sw = "1"b;
	     else if arg = "-segment" | arg = "-sm" then seg_sw = "1"b;
	     else if arg = "-switch" then do;
		i = i + 1;
		if i &gt; arg_count then do;
		     call complain (error_table_$noarg, ME, "Following -switch.");
		     return;
		end;
		if switch_count = 10 then do;
		     call complain (0, ME, "Only 10 switch names allowed.");
		     return;
		end;
		call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		switch_count = switch_count + 1;
		switch_names (switch_count) = arg;
		switch_length = max (switch_length, arg_len);
	     end;

	     else do;
		do j = hbound (LONG_OPTION, 1) by -1 to 1
		     while (arg ^= LONG_OPTION (j) &amp; arg ^= SHORT_OPTION (j));
		end;
		if j ^= 0 then substr (string (opt), j, 1) = "1"b;
		else if arg = "-device" | arg = "-dv" then opt.logical_volume = "1"b;
		else if arg = "-entry_type" | arg = "-ettp" then opt.type = "1"b;
		else if arg = "-interpret_as_extended_entry" | arg = "-inaee" then interpret_as_standard_entry = "0"b;
		else if arg = "-interpret_as_standard_entry" | arg = "-inase" then interpret_as_standard_entry = "1"b;
		else if arg = "-names" then opt.names = "1"b; /* synonym for -name and -nm */
		else if arg = "-nonstandard_names" | arg = "-nsn" then do;
		     i = i + 1;
		     if i &gt; arg_count then do;
			call complain (error_table_$noarg, ME, "Need an argument for ^a.", arg);
			return;
		     end;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     path_count = path_count + 1;
		     path_array.path_ptr (path_count) = arg_ptr;
		     path_array.path_len (path_count) = arg_len;
		     path_array.nonstandard_names_flag (path_count) = "1"b;
		end;
		else if arg = "-records_used" | arg = "-ru" then opt.records_used = "1"b; /* syn for -records */
		else if arg = "-select_entry_type" | arg = "-slet" then do;
		     i = i + 1;
		     if i &gt; arg_count then do;
			call complain (error_table_$noarg, ME, "Following ^a", arg);
			return;
		     end;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     call BUILD_ENTRY_TYPE_LIST (arg, fs_entry_type_ptr, selecting_by_entry_type);
		end;
		else if arg = "-length" | arg = "-lengths" | arg = "-ln" then lengths = "1"b;
		else if active_function then do;	/* not any control arg acceptable to status af */
		     call complain (0, ME,
			"Specified control argument is not implemented by this active function.   ^a", arg);
		     return;
		end;
		else if arg = "-access" | arg = "-ac" then access = "1"b;
						/* -all, -a are undocumented synonyms of -long to be retained for compatibility. */
		else if arg = "-all" | arg = "-a" | arg = "-long" | arg = "-lg" then all = "1"b;
		else if arg = "-date" | arg = "-dt" then dates = "1"b;
		else do;
		     call complain (error_table_$badopt, ME, "^a", arg);
		     return;
		end;
	     end;
	end;

/* Adjust the environment for slet processing, if any requested */

	if selecting_by_entry_type then do;

	     if link_sw | seg_sw | dir_sw then do;
		call complain (error_table_$inconsistent, ME,
		     "-select_entry_type is an alternative to -directory, -segment, or -link.");
		return;
	     end;
	     dir_sw, link_sw, seg_sw = "1"b;

	     extended_type_count = 0;
	     do entry_type_index = 1 to fs_entry_type.count;
		if substr (fs_entry_type.suffix (entry_type_index), 1, 1) ^= "-" then
		     extended_type_count = extended_type_count + 1;
	     end;

	     if extended_type_count = fs_entry_type.count then slet_path_array_size = path_count * extended_type_count;
	     else slet_path_array_size = path_count * (extended_type_count + 1);

	     if slet_path_array_size &gt; hbound (path_array_space, 1) then
		allocate slet_path_array in (area) set (slet_path_array_ptr);
	     else slet_path_array_ptr = addr (path_array_space);

	     i = slet_path_array_size;
	     do j = path_count by -1 to 1;

		do entry_type_index = 1 to fs_entry_type.count;
		     if substr (fs_entry_type.suffix (entry_type_index), 1, 1) ^= "-" then do;
			slet_path_len = path_array.path_len (j) + 1 +
			     length (rtrim (fs_entry_type.suffix (entry_type_index)));
			allocate slet_path in (slet_area) set (slet_path_ptr);
			target_len = path_array.path_len (j);
			if ^path_array.nonstandard_names_flag (j) then
			     call expand_pathname_$add_suffix (path_array.path_ptr (j) -&gt; target_path,
				fs_entry_type.suffix (entry_type_index), target_dn,
				slet_path_ptr -&gt; slet_path, code);
			else do;
			     target_dn = get_wdir_ ();
			     arg_len = path_array.path_len (j);
			     arg_ptr = path_array.path_ptr (j);
			     slet_path_ptr -&gt; slet_path = arg;
			end;
			slet_path_array.path_ptr (i) = slet_path_ptr;
			slet_path_array.path_len (i) = slet_path_len;
			i = i - 1;
		     end;
		end;
		if fs_entry_type.count &gt; extended_type_count then do;
		     slet_path_array.path_ptr (i) = path_array.path_ptr (j);
		     slet_path_array.path_len (i) = path_array.path_len (j);
		     i = i - 1;
		end;
	     end;

	     if path_array_ptr ^= addr (path_array_space) then do;
		free path_array in (area);
		path_array_ptr = slet_path_array_ptr;
	     end;

	     path_count = slet_path_array_size;
	end;

/* Set star selection variables */

	if ^dir_sw &amp; ^link_sw &amp; ^seg_sw then dir_sw, link_sw, seg_sw = "1"b; /* default */

	if ^link_sw then star_select_sw = star_BRANCHES_ONLY;
	else if ^dir_sw &amp; ^seg_sw then star_select_sw = star_LINKS_ONLY;
	else star_select_sw = star_ALL_ENTRIES;

	k = 0;
	switch_mask = ""b;
	do i = 1 to switch_count;			/* check for standards */
	     if switch_names (i) = "damaged" then opt.damaged_switch = "1"b;
	     else if switch_names (i) = "safety" then opt.safety_switch = "1"b;
	     else if switch_names (i) = "copy" then opt.copy_switch = "1"b;
	     else if switch_names (i) = "audit" then opt.audit_switch = "1"b;
	     else if switch_names (i) = "synchronized" then opt.synchronized_switch = "1"b;
	     else if switch_names (i) = "complete_volume_dump" then opt.cvds = "1"b;
	     else if switch_names (i) = "incremental_volume_dump" then opt.ivds = "1"b;
	     else substr (switch_mask, i, 1) = "1"b;

	     if ^(substr (switch_mask, i, 1)) then k = k + 1; /* was a standard switch */
	end;

	explicit_opt = opt;

	if all then string (opt) = ALL_OPTIONS;

	if access then string (opt) = string (opt) | string (access_options);
	if dates then string (opt) = string (opt) | string (date_options);
	if lengths then do;
	     if active_function then
		string (opt) = string (opt) | string (active_function_length_options);
	     else string (opt) = string (opt) | string (length_options);
	end;
	if switch_count = 0 &amp; string (opt) = "0"b then
	     if active_function then do;		/* control arg must be supplied to active function */
AF_USAGE:
		call active_fnc_err_ (0, ME, "Usage:  [status path control_arg {-chase}]");
		return;
	     end;
	     else unspec (opt) = unspec (default_options);

/* Shorter output format if only one item of information is requested. */

	j = switch_count - k;
	do i = 1 to hbound (LONG_OPTION, 1);
	     if substr (string (opt), i, 1) then j = j + 1;
	end;
	if j = 1 then one_item = "1"b;
	else if active_function &amp; ^lengths then go to AF_USAGE;
	else one_item = "0"b;

	if path_count = 0 then do;			/* assume working directory */
	     if active_function &amp; arg_count = 2 then go to AF_USAGE;
	     path_count = 1;
	     path_array.path_len (1) = 0;		/* use expand_path_'s working dir feature */
	     path_array.path_ptr (1) = null ();
	end;
	else if active_function &amp; path_count &gt; 1 then go to AF_USAGE;

	saved_options = opt;
%page;
	printed_something = "0"b;			/* haven't output anything yet */

	do i = 1 to path_count;
	     if path_array.nonstandard_names_flag (i) then do;
		dn = get_wdir_ ();
		arg_len = path_array.path_len (i);
		arg_ptr = path_array.path_ptr (i);
		en = arg;
	     end;
	     else do;
		call expand_path_ (path_array.path_ptr (i), path_array.path_len (i), addr (dn), addr (en), code);
		if code ^= 0 then do;
		     arg_ptr = path_array.path_ptr (i);
		     arg_len = path_array.path_len (i);
		     call complain (code, ME, "^a", arg);
		     go to NEXT_PATH;
		end;
		if en ^= "" then call check_star_name_$entry (en, code); /* star convention? */
	     end;
	     if code = 0 then do;
		star_sw = "0"b;
		j, star_entry_count = 1;
		printed_pathname = "0"b;
		msf = "0"b;
		msf_ptr = null ();

		call ENTRY_STATUS ();		/* do the work */

		if msf then
		     if msf_ptr ^= null then call msf_manager_$close (msf_ptr);
		if branch_names_ptr ^= null &amp; ^root_sw then free branch_names in (area);
	     end;
	     else if code &gt; 2 then do;		/* invalid entry name */
		arg_ptr = path_array.path_ptr (i);
		arg_len = path_array.path_len (i);
		call complain (code, ME, "^a", arg);
		go to NEXT_PATH;
	     end;
	     else if active_function then do;
		call active_fnc_err_ (0, ME, "Star convention is not allowed.");
RETURN:
		return;
	     end;
	     else
star_loop:
		begin;
		star_sw = "1"b;
		star_list_branch_ptr, star_list_names_ptr = null;

		on condition (cleanup) call CLEAN_UP ();

		call hcs_$star_dir_list_ (dn, en, star_select_sw, area_ptr, star_branch_count, star_link_count,
		     star_list_branch_ptr, star_list_names_ptr, code);
		if code ^= 0 then do;
		     call complain (code, ME, "^a", pathname_ (dn, en));
		     go to NEXT_PATH;
		end;
		star_en = en;
		matched = "0"b;
		star_entry_count = star_branch_count + star_link_count;
		do j = 1 to star_entry_count;
		     entry_type = star_dir_list_branch (j).type;
		     if entry_type = star_SEGMENT then do;
			if ^seg_sw then go to NEXT_MATCH;
		     end;
		     else if entry_type = star_LINK then do;
			if ^link_sw then go to NEXT_MATCH;
		     end;
		     else do;			/* directory type: dir or MSF */
			if star_dir_list_branch (j).bit_count = 0 then do;
			     if ^dir_sw then go to NEXT_MATCH;
			end;
			else if ^seg_sw then go to NEXT_MATCH;
		     end;
		     matched = "1"b;
		     en = star_list_names (star_dir_list_branch (j).nindex);
		     printed_pathname = "0"b;
		     msf = "0"b;
		     msf_ptr = null ();

		     call ENTRY_STATUS ();		/* do the work */

		     if ^printed_something then	/* if we haven't output anything yet, */
			printed_something = printed_pathname; /* then if we printed the pathname, */
						/* well that's something */

		     if chased | msf_error then dn = saved_dn;
		     if msf then
			if msf_ptr ^= null then call msf_manager_$close (msf_ptr);
		     if branch_names_ptr ^= null &amp; ^root_sw then free branch_names in (area);
NEXT_MATCH:
		end;
		if ^matched | (matched &amp; ^printed_something) then
		     call complain (error_table_$nomatch, ME, "^a", pathname_ (dn, star_en));
		call CLEAN_UP ();
	     end star_loop;

NEXT_PATH:
	end;
STATUS_EXIT:
	call CLEAN_UP ();
	return;
%page;
ENTRY_STATUS: proc;

/* This internal procedure returns the requested attributes of dn&gt;en */
/* It uses a number of global values declared in the external procedure. */
/* It allocates branch names and sets branch_names_ptr. */
/* For multisegment files, it turns on the flag msf. */

dcl  max_switch_length fixed bin;
dcl  not_mounted fixed bin (35);
dcl  msf_mode bit (5) aligned;
dcl  msf_rbs (0:2) fixed bin (5) unaligned;

	max_switch_length = switch_length;
	branch_status.number_names = "0"b;
	opt = saved_options;
	chased, dm_file_sw, msf_error, root_sw = "0"b;
	not_mounted = 0;

	status_chase = NO_CHASE;			/* get info on entry */

/* If it's a link, we'll be coming back here with status_chase = CHASE */

STATUS:
	branch_status.names_rel_pointer = "0"b;

	if opt.names | opt.primary_name | opt.link_path then
	     call hcs_$status_long (dn, en, status_chase, addr (branch_status), area_ptr, code);
	else call hcs_$status_long (dn, en, status_chase, addr (branch_status), null, code);
	branch_names_ptr = null;

	if branch_status.names_rel_pointer ^= "0"b then
	     branch_names_ptr = ptr (area_ptr, branch_status.names_rel_pointer);

	on condition (cleanup) begin;
	     if branch_names_ptr ^= null &amp; ^root_sw then free branch_names in (area);
	end;

	if code ^= 0 then
	     if code = error_table_$no_s_permission then do;
NO_S:
		string (opt) = string (opt) &amp; string (no_s_options);
		if string (opt) = "0"b then call ENTRY_ERROR (code, dn, en);
	     end;
	     else if code = error_table_$logical_volume_not_connected |
		code = error_table_$logical_volume_not_defined then do;
		not_mounted = code;
		string (opt) = string (opt) &amp; string (off_line_options);
		if branch_status.number_names = "0"b then string (opt) = string (opt) &amp; string (no_s_options);
		if string (opt) = "0"b then call ENTRY_ERROR (code, dn, en);
	     end;
	     else if code = error_table_$root then do;	/* now it works on the root */
		root_sw = "1"b;
		string (opt) = string (opt) &amp; string (root_options);
		if string (opt) = "0"b then call ENTRY_WRONG_TYPE ("the root");
		dn = "&gt;";
		en = "";
		branch_names_ptr = addr (ROOT_NAMES);	/* fake hcs_$status info */
		unspec (branch_status) = "0"b;
		branch_status.type = directory_type;
		branch_status.unique_id = (36)"1"b;
		branch_status.number_names = "0001"b4;
		if get_group_id_ () = INITIALIZER_ID then branch_status.mode = "01011"b; /* sma */
		else branch_status.mode = "01"b;	/* s for everybody else */
		branch_status.ring_brackets (*) = "000111"b; /* 7,7,7 */
	     end;
	     else call ENTRY_ERROR (code, dn, en);

/* Check the fs type when we are -inase with -slet, and fake out status if wrong type */

	if selecting_by_entry_type then do;
	     call fs_util_$get_type (dn, en, fs_type, code);
	     if code ^= 0 then do;
		call complain (code, ME, "Getting type of ^a", pathname_ (dn, en));
		return;
	     end;
	     if ^ENTRY_TYPE_SELECTED (fs_type, fs_entry_type_ptr) then do;
		matched = "1"b;
		return;
	     end;
	     else if substr (fs_type, 1, 1) = "-" then ;	/* standard type, no faking necessary */
	     else if star_sw then
		if before (reverse (rtrim (en)), ".") ^= before (reverse (rtrim (star_en)), ".") then do;
		     matched = "1"b;
		     return;
		end;
	end;

/* See if the entry is a special type */

	entry_type = fixed (branch_status.type);
	msf = (entry_type = star_DIRECTORY &amp; branch_status.bit_count ^= "0"b);

	if ^interpret_as_standard_entry &amp; entry_type ^= star_LINK &amp; ^root_sw then
	     if msf | switch_count &gt; 0 | (string (opt) &amp; string (typed_options)) then do;
		call fs_util_$get_type (dn, en, fs_util_type, code);
		dm_file_sw = (code = 0 &amp; fs_util_type = FS_OBJECT_TYPE_DM_FILE);
		if code = 0 &amp; substr (fs_util_type, 1, 1) ^= "-" then do;
						/* for now, handle segs, dirs, DM files, and MSF's by hand */
		     entry_type = EXTENDED_type;
		     msf = "0"b;
		     si.version = SUFFIX_INFO_VERSION_1;
		     call fs_util_$suffix_info_for_type (fs_util_type, addr (si), (0));
		end;
	     end;

	if branch_status.type = link_type then do;	/* process link for -chase or -chase_if_possible */
	     if chase &amp; chased then do;		/* null link */
		call complain (0, ME, "Null link with -chase.  ^a", pathname_ (dn, en));
		return;
	     end;
	     else if (chase_if_possible | chase) then
		if ^chased then do;
		     call hcs_$get_link_target (dn, en, target_dn, target_en, code);
		     if code = 0 &amp; dn ^= "" then do;
			chased = "1"b;
			saved_dn = dn;
			saved_en = en;
			dn = target_dn;
			en = target_en;
			status_chase = CHASE;	/* chase the link this time */
			go to STATUS;		/* go back to get link info */
		     end;
		     else if code = error_table_$noentry then
			if chase then do;		/* null link */
			     call complain (code, ME,
				"Target:  ^a.  Link to a null link with -chase.  Source:  ^a",
				pathname_ (target_dn, target_en), pathname_ (dn, en));
			     return;
			end;
		end;				/* if ^chase */

	     string (opt) = string (opt) &amp; string (link_options);
	     if string (opt) = "0"b &amp; switch_count = 0 then /* no applicable control args */
		call ENTRY_WRONG_TYPE ("a link");
	end;					/* if branch_status.type = link_type */

	else do;					/* non-link */
	     if ^star_sw then
		if branch_status.type = directory_type &amp; ^dm_file_sw then do;
		     if (seg_sw | link_sw) &amp; ^dir_sw then call ENTRY_WRONG_TYPE ("a directory");
		end;
		else if (link_sw | dir_sw) &amp; ^seg_sw then
		     if dm_file_sw then call ENTRY_WRONG_TYPE ("a Data Management file");
		     else call ENTRY_WRONG_TYPE ("a segment");

	     string (opt) = string (opt) &amp; string (nonlink_options);
	     if string (opt) = "0"b &amp; switch_count = 0 then do; /* no applicable control args */
		if ^star_sw then call ENTRY_WRONG_TYPE ("not a link");
		return;
	     end;
	end;

	if lengths &amp; active_function then		/* set up the return value for -length only when status acts as an active function */
	     if branch_status.type = directory_type &amp; branch_status.bit_count = "0"b then opt.current_length = "0"b; /* for directory type -- status active function returns bit count for -length */
	     else opt.bit_count = "0"b;		/* for other types -- status active function returns current length for -length */
	else ;

	if dm_file_sw | root_sw then msf = "0"b;	/* root's not, can't look inside a DM file */

	if dm_file_sw then do;
	     string (opt) = string (opt) &amp; string (dm_file_options);
	     if string (opt) = "0"b &amp; switch_count = 0 then call ENTRY_WRONG_TYPE ("a Data Management file");
	end;
	else do;					/* not DM file; make sure some control args apply */
	     unspec (opt.dm_files_only) = "0"b;

/**** vp: phx20203 ; case when string (opt) = "0"b and switch_count &gt; 0 for a link ****/
	     if string (opt) = "0"b then do;
		if branch_status.type = link_type then call ENTRY_WRONG_TYPE ("a link");
		else call ENTRY_WRONG_TYPE ("not a Data Management file");
	     end;
	end;
%page;
/* Now we know we can proceed to print or return some info */

	if ^active_function &amp; ^one_item then do;	/* multiple entries; print pathname */
	     call PRINT_PATHNAME ();
	     call ioa_ ("");
	end;

	if dm_file_sw then do;
	     if (string (opt) &amp; string (fm_status_options)) ^= "0"b then do;
		unspec (auto_dm_file_status) = "0"b;
		auto_dm_file_status.version = DM_FILE_STATUS_VERSION_1;
		call file_manager_$status (dn, en, addr (auto_dm_file_status), code);
		if code ^= 0 &amp; code ^= dm_error_$transaction_in_progress then do;
		     call complain (code, ME, "^a", pathname_ (dn, en));
		     return;
		end;
	     end;
	end;
%page;
/* Format each item of status info */

	if opt.names | opt.primary_name then do;	/* -name or -primary */
	     if active_function then do;
		return_string = requote_string_ (rtrim (branch_names (0)));
		if opt.names then
		     do k = 1 to bin (branch_status.number_names) - 1;
		     return_string = return_string || " " || requote_string_ (rtrim (branch_names (k)));
		end;
		return;
	     end;
	     call PRINT_PATHNAME ();
	     if opt.names then do;
		if one_item then call ioa_ ("^a", branch_names (0));
		else call ioa_ ("names:^4x^a", branch_names (0));
		do k = 1 to bin (branch_status.number_names) - 1;
		     if one_item then call ioa_ ("^a", branch_names (k));
		     else call ioa_ ("^10x^a", branch_names (k));
		end;
	     end;
	     else if one_item then call ioa_ ("^a", branch_names (0));
	     else call ioa_ ("primary name:^7x^a", branch_names (0));
	end;

	if opt.type then do;			/* -type */
	     if root_sw then type_string = "directory";
	     else if dm_file_sw then type_string = "Data Management file";
	     else if entry_type = EXTENDED_type then type_string = si.type_name;
	     else if entry_type = star_LINK then type_string = "link";
	     else if entry_type = star_SEGMENT then type_string = "segment";
	     else if entry_type = star_DIRECTORY then
		if branch_status.bit_count ^= "0"b then type_string = "multisegment file";
		else if branch_status.mdir then type_string = "master directory";
		else type_string = "directory";

	     if active_function then do;
		return_string = """" || rtrim (type_string) || """";
		return;
	     end;
	     call PRINT_PATHNAME ();
	     if one_item then call ioa_ ("^a", type_string);
	     else call ioa_ ("type:^15x^a", type_string);
	end;

	if opt.link_path then do;			/* -link_path */
	     target_ptr = ptr (area_ptr, link_status.pnrp);
	     target_len = link_status.pnl;
	     if active_function then do;
		return_string = rtrim (target_path);
		return;
	     end;
	     call PRINT_PATHNAME ();
	     if one_item then call ioa_ ("^a", target_ptr -&gt; target_path);
	     else call ioa_ ("links to:^11x^a", target_ptr -&gt; target_path);
	end;

	if opt.unique_id then do;			/* -unique_id */
	     if dm_file_sw then local_unique_id = auto_dm_file_status.fm_unique_id;
	     else local_unique_id = branch_status.unique_id;
	     if active_function then do;
		call ioa_$rsnnl ("^w", return_string, k, local_unique_id);
		return;
	     end;
	     else do;
		call PRINT_PATHNAME ();
		if one_item then call ioa_ ("^w", local_unique_id);
		else call ioa_ ("^[fm unique id:^7x^;unique id:^10x^]^w", dm_file_sw, local_unique_id);
	     end;
	end;

/* Get MSF information */

	if opt.dtu | opt.dtcm | opt.dtem | opt.dtd | opt.bit_count | opt.records_used | opt.current_length |
	     opt.mode | opt.ring_brackets then do;

	     call PRINT_PATHNAME ();

	     if msf then
get_msf_info:
		begin;
		on cleanup begin;
		     if msf_ptr ^= null then call msf_manager_$close (msf_ptr);
		end;

		call msf_manager_$open (dn, en, msf_ptr, code);
		if msf_ptr = null then do;
		     call complain (code, ME, "Unable to open multisegment file ^a&gt;^a", dn, en);
		     msf = "0"b;
		     return;
		end;

		msf_dtu, msf_dtcm, msf_dtem, msf_dtd = "0"b;
		total_records = bin (branch_status.records, 17);
		total_length = bin (branch_status.current_length, 11);
		total_bit_count = 0;
		msf_path = rtrim (dn) || "&gt;" || en;
						/* initialize in case no components */
		msf_mode = branch_status.mode &amp; "01010"b;
		unspec (msf_rbs) = unspec (branch_status.ring_brackets);

		do k = 0 by 1 while (code = 0);	/* look at all components */
		     call msf_manager_$get_ptr (msf_ptr, k, "0"b, comp_ptr, 0, code);
		     if code = 0 | code = error_table_$segknown then do;
			comp_name = convert (comp_name, k);
			comp_name = substr (comp_name, verify (comp_name, " "));
			call hcs_$status_long (msf_path, comp_name, 1, addr (msf_info), null, code);
			if code ^= 0 then
			     if code = error_table_$no_s_permission then do;
				opt.ring_brackets = "0"b;
				if string (opt) = "0"b then do;
				     saved_dn = dn;
				     msf_error = "1"b;
				     call ENTRY_ERROR (code, msf_path, comp_name);
				end;
			     end;
			     else do;
				call complain (code, ME, "^a&gt;^a", msf_path, comp_name);
				return;
			     end;
			code = 0;
			if fixed (msf_info.dtu) &gt; fixed (msf_dtu) then msf_dtu = msf_info.dtu;
			if fixed (msf_info.dtcm) &gt; fixed (msf_dtcm) then msf_dtcm = msf_info.dtcm;
			if fixed (msf_info.dtem) &gt; fixed (msf_dtem) then msf_dtem = msf_info.dtem;
			if fixed (msf_info.dtd) &gt; fixed (msf_dtd) then msf_dtd = msf_info.dtd;
			if k = 0 then do;		/* first component */
			     msf_mode = msf_info.mode;
			     unspec (msf_rbs) = unspec (msf_info.rbs);
			end;
			total_records = total_records + msf_info.records;
			total_bit_count = total_bit_count + bin (msf_info.bit_count);
			total_length = total_length + msf_info.current_length;
		     end;
		     else if code ^= error_table_$noentry then do;
			opt.bit_count, opt.records_used, opt.current_length, opt.dtu, opt.dtcm,
			     opt.dtem, opt.dtd, opt.mode, opt.ring_brackets = "0"b;
			if string (opt) = "0"b then do;
			     saved_dn = dn;
			     msf_error = "1"b;
			     comp_name = convert (comp_name, k);
			     call ENTRY_ERROR (error_table_$moderr,
				dn, en);
			end;
		     end;
		end;
	     end get_msf_info;
	end;

	if opt.dtu then do;				/* -date_time_used */

/**** vp: phx20897; convert the system clock to 36 bits then make use of
      the internal procedure CONVERT_DATE to convert a 36 bits clock time
      into an ASCII date string.  This will effectively check for active
      function as well.                                                  ****/

	     if root_sw then do;
		temp_clock = clock ();		/* This conversion method was taken from date_time_.pl1 routine */
		stime = addr (temp_clock) -&gt; fs_time_value.time;
		call CONVERT_DATE (stime);
	     end;
	     else if msf &amp; msf_dtu ^= "0"b then call CONVERT_DATE (msf_dtu);
	     else call CONVERT_DATE (branch_status.date_time_used);
	     call PRINT_PATHNAME ();
	     if one_item then call ioa_ ("^a", date_string);
	     else if date_string ^= "ZERO" | explicit_opt.dtu then call ioa_ ("date used:^10x^a", date_string);
	end;

	if opt.dtcm then do;			/* -date_time_contents_modified */
	     if msf &amp; msf_dtcm ^= "0"b then call CONVERT_DATE (msf_dtcm);
	     else call CONVERT_DATE (branch_status.date_time_modified);
	     call PRINT_PATHNAME ();
	     if one_item then call ioa_ ("^a", date_string);
	     else if date_string ^= "ZERO" | explicit_opt.dtcm then call ioa_ ("date modified:^6x^a", date_string);
	end;

	if opt.dtem then do;			/* -date_time_entry_modified */
	     call PRINT_PATHNAME ();
	     if entry_type = star_LINK then do;
		call CONVERT_DATE (link_status.dtlm);
		if one_item then call ioa_ ("^a", date_string);
		else if date_string ^= "ZERO" | explicit_opt.dtem then
		     call ioa_ ("date link modified: ^a", date_string);
	     end;
	     else do;
		if msf &amp; msf_dtem ^= "0"b then call CONVERT_DATE (msf_dtem);
		else call CONVERT_DATE (branch_status.date_time_entry_modified);
		if one_item then call ioa_ ("^a", date_string);
		else if date_string ^= "ZERO" | explicit_opt.dtem then
		     call ioa_ ("branch modified:^4x^a", date_string);
	     end;
	end;

	if opt.dtvd then do;			/* -date_time_volume_dumped */
	     call PRINT_PATHNAME ();
	     if entry_type = star_LINK then do;
		call hcs_$get_dates (dn, "", dates_array, code);
		call CONVERT_DATE (dates_array (5));
		if one_item then call ioa_ ("link dtvd: ^a", date_string);
		else if date_string ^= "ZERO" | explicit_opt.dtd then
		     call ioa_ ("link volume dumped:^1x^a", date_string);
	     end;
	     else do;
		call hcs_$get_dates (dn, en, dates_array, code);
		call CONVERT_DATE (dates_array (5));
		if one_item then call ioa_ ("dtvd: ^a", date_string);
		else if date_string ^= "ZERO" | explicit_opt.dtd then
		     call ioa_ ("date volume dumped:^1x^a", date_string);
	     end;
	end;

	if opt.dtd then do;				/* -date_time_dumped */
	     call PRINT_PATHNAME ();
	     if entry_type = star_LINK then do;
		call CONVERT_DATE (link_status.dtd);
		if one_item then call ioa_ ("dtd: ^a", date_string);
		else if date_string ^= "ZERO" | explicit_opt.dtd then
		     call ioa_ ("link dumped:^8x^a", date_string);
	     end;
	     else do;
		if msf &amp; msf_dtd ^= "0"b then call CONVERT_DATE (msf_dtd);
		else call CONVERT_DATE (branch_status.date_time_dumped);
		if one_item then call ioa_ ("br dtd: ^a", date_string);
		else if date_string ^= "ZERO" | explicit_opt.dtd then
		     call ioa_ ("date branch dumped:^1x^a", date_string);
	     end;
	end;

	if opt.author then do;			/* -author */
	     call PRINT_PATHNAME ();
	     if root_sw then do;
		author_string = INITIALIZER_ID;
		code = 0;
	     end;
	     else call hcs_$get_author (dn, en, 0, author_string, code);
	     if active_function then do;
		if code = 0 then return_string = rtrim (author_string);
		else call active_fnc_err_ (code, ME);
		return;
	     end;
	     if code = 0 then do;
		if one_item then call ioa_ ("^a", author_string);
		else call ioa_ ("author:^13x^a", author_string);
	     end;
	     else if one_item then call complain (code, ME);
	     else if explicit_opt.author then call complain (code, ME, "Unable to get author.");
	end;

	if opt.bc_author then do;			/* -bc_author */
	     call PRINT_PATHNAME ();
	     if root_sw then do;
		bc_author_string = INITIALIZER_ID;
		code = 0;
	     end;
	     else call hcs_$get_bc_author (dn, en, bc_author_string, code);
	     if active_function then do;
		if code = 0 then return_string = rtrim (bc_author_string);
		else call active_fnc_err_ (code, ME);
		return;
	     end;
	     if code = 0 then do;
		if one_item then call ioa_ ("^a", bc_author_string);
		else if explicit_opt.bc_author | bc_author_string ^= author_string then
		     call ioa_ ("bit count author:^3x^a", bc_author_string);
	     end;
	     else if one_item then call complain (code, ME);
	     else if explicit_opt.bc_author then call complain (code, ME, "Unable to get bit count author.");
	end;

	if opt.logical_volume then do;		/* -logical_volume */
	     call PRINT_PATHNAME ();
	     if root_sw then do;
		lv_string = "root";
		code = 0;
	     end;
	     else call mdc_$find_lvname (branch_status.lvid, lv_string, code);
	     if active_function then do;
		if code = 0 then return_string = rtrim (lv_string);
		else call active_fnc_err_ (code, ME);
		return;
	     end;
	     else if code = 0 then do;
		if one_item then call ioa_ ("^a", lv_string);
		else if entry_type = star_SEGMENT then call ioa_ ("volume name:^8x^a", lv_string);
		else call ioa_ ("sons volume:^8x^a", lv_string);
	     end;
	     else if one_item then call complain (code, ME);
	     else if explicit_opt.logical_volume then call complain (code, ME, "Unable to get logical volume.");
	end;

	if opt.bit_count then do;			/* -bit_count */
	     call PRINT_PATHNAME ();
	     if root_sw then bc35 = 0;
	     else do;
		bc36 = "0000"b3 || branch_status.bit_count;
		unspec (bc35) = bc36;		/* convert to fixed bin (35) */
	     end;
	     if msf then
		if active_function then do;
		     call ioa_$rsnnl ("^d", return_string, k, total_bit_count);
		     return;
		end;
		else do;
		     call ioa_ ("number of components:^9x^d", k - 1);
		     if k - 1 ^= bin (branch_status.bit_count) then
			call ioa_ ("msf indicator:^6x^d   (inconsistent with number of components)", bc35);
		     call ioa_ ("total bit count:^4x^d", total_bit_count);
		end;
	     else if active_function then do;
		call ioa_$rsnnl ("^d", return_string, k, bc35);
		return;
	     end;
	     else if one_item then call ioa_ ("^d", bc35);
	     else call ioa_ ("bit count:^10x^d", bc35);
	end;

	if opt.records_used then do;			/* -records_used */
	     call PRINT_PATHNAME ();
	     if msf then
		if active_function then do;
		     call ioa_$rsnnl ("^d", return_string, k, total_records);
		     return;
		end;
		else do;
		     if one_item then call ioa_ ("^d", total_records);
		     else call ioa_ ("total records used:^x^d", total_records);
		end;
	     else if active_function then do;
		call ioa_$rsnnl ("^d", return_string, k, fixed (branch_status.records, 18));
		return;
	     end;
	     else do;
		if one_item then call ioa_ ("^d", fixed (branch_status.records, 18));
		else call ioa_ ("records used:^7x^d", fixed (branch_status.records, 18));
	     end;
	end;

	if opt.current_length then do;		/* -current_length */
	     call PRINT_PATHNAME ();
	     if msf then
		if active_function then do;
		     call ioa_$rsnnl ("^d", return_string, k, total_length);
		     return;
		end;
		else do;
		     if one_item then call ioa_ ("^d", total_length);
		     else if explicit_opt.current_length | total_length ^= total_records then
			call ioa_ ("total length:^7x^d", total_length);
		end;
	     else if active_function then do;
		call ioa_$rsnnl ("^d", return_string, k, fixed (branch_status.current_length, 12));
		return;
	     end;
	     else do;
		if one_item then call ioa_ ("^d", fixed (branch_status.current_length, 12));
		else if explicit_opt.current_length |
		     branch_status.current_length ^= substr (branch_status.records, 7, 12) then
		     call ioa_ ("current length:^5x^d", fixed (branch_status.current_length, 12));
	     end;
	end;

	if opt.max_length then do;			/* -max_length */
	     call PRINT_PATHNAME ();
	     if entry_type ^= star_DIRECTORY then do;
		if msf then call hcs_$get_max_length (msf_path, "0", max_length, code);
		else if entry_type = EXTENDED_type then call fs_util_$get_max_length (dn, en, max_length, code);
		else call hcs_$get_max_length (dn, en, max_length, code);
		if active_function then do;
		     if code = 0 then call ioa_$rsnnl ("^d", return_string, k, max_length);
		     else call active_fnc_err_ (code, ME);
		     return;
		end;
		if code = 0 then
		     if one_item then call ioa_ ("^d", max_length);
		     else call ioa_ ("max length:^9x^d", max_length);
		else if code = error_table_$unsupported_operation &amp; ^explicit_opt.max_length then ;
						/* ignore if this type has no max length */
		else if one_item then call complain (code, ME);
		else if explicit_opt.max_length then call complain (code, ME, "Unable to get max length.");
	     end;
	     else if active_function then do;
		call active_fnc_err_ (0, ME, "Unable to get the max length of a directory.  ^a&gt;^a", dn, en);
		return;
	     end;
	     else if explicit_opt.max_length then
		call complain (0, ME, "Unable to get the max length of a directory.  ^a&gt;^a", dn, en);
	end;

	if opt.mode then do;			/* -mode */
	     call PRINT_PATHNAME ();
	     if dm_file_sw then string (mode_bits) = "0"b || substr (auto_dm_file_status.mode, 1, 4); /* prevent string size condition while compiling. */
	     else if msf then string (mode_bits) = msf_mode;
	     else string (mode_bits) = branch_status.mode;
	     mode_string = "";
	     if entry_type = EXTENDED_type then do;
		call fs_util_$get_user_access_modes (dn, en, "", -1, modes, exmodes, code);
		if code ^= 0 then
		     if code = error_table_$unsupported_operation &amp; ^explicit_opt.mode then ;
						/* ignore if this type has no extended mode */
		     else call complain (code, ME, "Unable to get extended mode.");
		else do;
		     do k = 1 to length (rtrim (si.modes));
			if substr (modes, k, 1) then mode_string = mode_string || substr (si.modes, k, 1);
		     end;
		end;
	     end;
	     else if dm_file_sw | msf | entry_type = star_SEGMENT then do;
		if mode_bits (2) then mode_string = "r";
		if mode_bits (3) then mode_string = mode_string || "e";
		if mode_bits (4) then mode_string = mode_string || "w";
	     end;
	     else do;				/* directory */
		if mode_bits (2) then mode_string = "s";
		if mode_bits (4) then mode_string = mode_string || "m";
		if mode_bits (5) then mode_string = mode_string || "a";
	     end;
	     if code = 0 then do;
		if mode_string = "" then mode_string = "null";
		if active_function then do;
		     return_string = mode_string;
		     return;
		end;
		if one_item then call ioa_ ("^a", mode_string);
		else call ioa_ ("mode:^15x^a", mode_string);
	     end;
	end;

	if opt.access_class then do;			/* -access_class */
	     call PRINT_PATHNAME ();
	     call hcs_$get_access_class (dn, en, access_class, code);
	     if code = 0 then do;
		call convert_authorization_$to_string_short (access_class, class, code);
		if code ^= 0 then call complain (code, ME, "Unable to convert access class.");
		else if active_function then do;
		     if class = "" then class = "system_low";
		     return_string = rtrim (class);
		     return;
		end;
		else if class ^= "" then do;		/* format access class in lines of 50 chars */
		     class_len = index (class, " ") - 1;
		     if class_len = -1 then class_len = 336;
		     k = 1;
		     if ^one_item then call ioa_$nnl ("access class:^7x");
		     do while ((class_len - k + 1) &gt; 50);
			temp_string = substr (class, k, 50);
			kk = length (temp_string) + 1 - index (reverse (temp_string), ",");
			call ioa_$nnl ("^a", substr (class, k, kk));
			if ^one_item then call ioa_$nnl ("^/^20x");
			k = k + kk;
		     end;
		     call ioa_ ("^a", substr (class, k));
		end;
		else if explicit_opt.access_class then
		     if one_item then call ioa_ ("system_low");
		     else call ioa_ ("access class:^7xsystem_low");
	     end;
	     else if active_function | explicit_opt.access_class then do;
		call complain (code, ME, "Unable to get access class.");
		return;
	     end;
	end;

	if opt.ring_brackets then do;			/* -ring_brackets */
	     call PRINT_PATHNAME ();
	     if entry_type = EXTENDED_type then do;
		if si.num_ring_brackets = 0 then
		     if explicit_opt.ring_brackets then
			call complain (0, ME, "The ^a object type does not support ring brackets.",
			     si.type_name);
		     else ;
		else do;
		     call fs_util_$get_ring_brackets (dn, en, ring_brackets, code);
		     if code ^= 0 then
			if code = error_table_$unsupported_operation &amp; ^explicit_opt.ring_brackets then ;
						/* ignore if this type has no ring brackets */
			else call complain (code, ME, "Unable to get ring brackets.");
		     else if active_function then call ioa_$rsnnl ("^v(^d ^)", return_string, k,
			     si.num_ring_brackets, ring_brackets);
		     else call ioa_ ("^[ring brackets:^6x^]^v(^d, ^)^d", ^one_item,
			     si.num_ring_brackets - 1, ring_brackets);
		end;
	     end;
	     else if active_function then do;
		if dm_file_sw then
		     call ioa_$rsnnl ("^d ^d", return_string, k, auto_dm_file_status.ring_brackets);
		else if msf then call ioa_$rsnnl ("^d ^d ^d", return_string, k, msf_rbs);
		else if entry_type ^= star_DIRECTORY then
		     call ioa_$rsnnl ("^d ^d ^d", return_string, k, fixed (branch_status.ring_brackets, 5));
		else call ioa_$rsnnl ("^d ^d", return_string, k, fixed (branch_status.ring_brackets (0), 5),
			fixed (branch_status.ring_brackets (1), 5));
		return;
	     end;
	     else if dm_file_sw then
		if one_item then call ioa_ ("^d, ^d", auto_dm_file_status.ring_brackets);
		else call ioa_ ("extended ring brackets:^2x^d, ^d", auto_dm_file_status.ring_brackets);
	     else if msf then
		if one_item then call ioa_ ("^d, ^d, ^d", msf_rbs);
		else call ioa_ ("ring brackets:^6x^d, ^d, ^d", msf_rbs);
	     else if entry_type ^= star_DIRECTORY then
		if one_item then call ioa_ ("^d, ^d, ^d", fixed (branch_status.ring_brackets, 5));
		else call ioa_ ("ring brackets:^6x^d, ^d, ^d", fixed (branch_status.ring_brackets, 5));
	     else if one_item then call ioa_ ("^d, ^d", fixed (branch_status.ring_brackets (0), 5),
		     fixed (branch_status.ring_brackets (1), 5));
	     else call ioa_ ("ring brackets:^6x^d, ^d", fixed (branch_status.ring_brackets (0), 5),
		     fixed (branch_status.ring_brackets (1), 5));
	end;

	if opt.usage_count then do;			/* -usage_count */
	     call PRINT_PATHNAME ();
	     if entry_type = star_DIRECTORY then
		if explicit_opt.usage_count &amp; ^star_sw then
		     call complain (0, ME, "Cannot determine the usage count of a directory.");
		else ;
	     else do;
		usage_count = 0;
		on linkage_error begin;
		     usage_count = -1;
		     go to flurp;
		end;
		call mhcs_$get_seg_usage (dn, en, usage_count, code);
flurp:
		revert linkage_error;
		if usage_count &lt; 0 then code = error_table_$incorrect_access;
		if active_function then do;
		     if code = 0 then call ioa_$rsnnl ("^d", return_string, k, usage_count);
		     else call active_fnc_err_ (code, ME);
		     return;
		end;
		if code = 0 then
		     if one_item then call ioa_ ("^d", usage_count);
		     else call ioa_ ("usage count:^8x^d", usage_count);
		else if explicit_opt.usage_count then
		     call complain (code, ME, "Unable to get usage count.");
	     end;
	end;

	if entry_type = EXTENDED_type | dm_file_sw then do;
	     call PRINT_PATHNAME ();
	     switch_list_ptr = null ();
	     on cleanup begin;
		if switch_list_ptr ^= null ()
		then free switch_list;
	     end;

	     call fs_util_$list_switches_for_type (fs_util_type, SWITCH_LIST_VERSION_1, area_ptr,
		switch_list_ptr, code);
	     if code = error_table_$unsupported_operation &amp;
		^(explicit_opt.safety_switch | explicit_opt.ivds | explicit_opt.copy_switch | explicit_opt.audit_switch | explicit_opt.cvds |
		explicit_opt.synchronized_switch | explicit_opt.damaged_switch | explicit_opt.concurrency_switch |
		explicit_opt.rollback_switch | explicit_opt.protected_switch) then
		goto SKIP_SWITCHES;			/* WARNING, this ain't too modular */
	     if code ^= 0 then do;
		call complain (code, ME, "Listing switches.");
		return;
	     end;
	     if all then do k = 1 to switch_list.switch_count;
		max_switch_length = max (max_switch_length,
		     length (rtrim (switch_list.names (switch_list.name_index (k)))));
	     end;
	end;
	max_switch_length = max_switch_length + 8;	/* " switch: " */

	if opt.safety_switch then do;			/* -safety_switch */
	     call PRINT_PATHNAME ();
	     if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("safety", explicit_opt.safety_switch);
	     else do;
		if root_sw then safety_switch = "0"b;
		else call hcs_$get_safety_sw (dn, en, safety_switch, code);
		call PRINT_SWITCH ("safety", explicit_opt.safety_switch, safety_switch, "0"b);
	     end;
	end;

	if opt.ivds then do;			/* -ivds */
	     call PRINT_PATHNAME ();
	     if entry_type = star_DIRECTORY &amp; ^root_sw then
		if explicit_opt.ivds then call ENTRY_WRONG_TYPE ("a directory");
		else ;				/* not valid for dirs */
	     else do;
		if entry_type = EXTENDED_type | dm_file_sw then
		     call STATUS_SWITCH ("ivds", explicit_opt.ivds);
		else do;
		     if root_sw then ivds = 1;
		     else call hcs_$get_volume_dump_switches (dn, en, ivds, cvds, code);
		     call PRINT_SWITCH ("ivds", explicit_opt.ivds, (ivds = -1), "1"b);
		end;
	     end;
	end;

	if opt.cvds then do;			/* -cvds */
	     call PRINT_PATHNAME ();
	     if entry_type = star_DIRECTORY &amp; ^root_sw then
		if explicit_opt.cvds then call ENTRY_WRONG_TYPE ("a directory");
		else ;				/* not valid for dirs */
	     else do;
		if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("cvds", explicit_opt.cvds);
		else do;
		     if root_sw then cvds = 1;
		     else call hcs_$get_volume_dump_switches (dn, en, ivds, cvds, code);
		     call PRINT_SWITCH ("cvds", explicit_opt.cvds, (cvds = -1), "1"b);
		end;
	     end;
	end;

	if opt.audit_switch then do;			/* -audit_switch */
	     call PRINT_PATHNAME ();
	     if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("audit", explicit_opt.audit_switch);
	     else do;
		bks.version = status_for_backup_version_2;
		call hcs_$status_for_backup (dn, en, addr (bks), code);
		call PRINT_SWITCH ("audit", explicit_opt.audit_switch, (bks.audit_flag), "0"b);
	     end;
	end;

	if opt.copy_switch then do;			/* -copy_switch */
	     call PRINT_PATHNAME ();
	     if entry_type = EXTENDED_type | dm_file_sw then call STATUS_SWITCH ("copy", explicit_opt.copy_switch);
	     else do;
		code = 0;
		call PRINT_SWITCH ("copy", explicit_opt.copy_switch, (branch_status.copy_switch), "0"b);
	     end;
	end;

	if opt.damaged_switch then do;		/* -damaged_switch */
	     call PRINT_PATHNAME ();
	     if entry_type = EXTENDED_type | dm_file_sw then
		call STATUS_SWITCH ("damaged", explicit_opt.damaged_switch);
	     else do;
		code = 0;
		call PRINT_SWITCH ("damaged", explicit_opt.damaged_switch, (branch_status.damaged_switch), "0"b);
	     end;
	end;

	if opt.synchronized_switch then do;		/* -synchronized_switch */
	     call PRINT_PATHNAME ();
	     if entry_type = EXTENDED_type | dm_file_sw then
		call STATUS_SWITCH ("synchronized", explicit_opt.synchronized_switch);
	     else do;
		code = 0;
		if fixed (branch_status.bit_count) = 0 &amp; branch_status.type = directory_type then do;
		     if ^all then
			call complain (0, ME, "Directories do not support the synch switch.  ^a.", pathname_ (dn, en));
		end;
		else call PRINT_SWITCH ("synchronized", explicit_opt.synchronized_switch,
			(branch_status.synchronized_switch), "0"b);
	     end;
	end;

	call PRINT_PATHNAME ();
	if entry_type = EXTENDED_type then do;
	     if all then do;
		do k = 1 to switch_list.switch_count;
		     if switch_list.name_index (k) &gt; 0 then
			call STATUS_SWITCH_QUICK ((switch_list.names (switch_list.name_index (k))), "0"b);
		end;
		do k = 1 to switch_count;
		     do kk = 1 to switch_list.switch_name_count;
			if switch_names (k) = switch_list.names (kk) then go to FOUND;
		     end;
		     call complain (0, ME, "The ^a switch is not supported by ^a.", switch_names (k),
			si.plural_name);
FOUND:
		end;
	     end;

	     else if switch_mask ^= "0"b then do kk = 1 to switch_count;
		call STATUS_SWITCH (switch_names (kk), "1"b);
	     end;
	end;
	else if switch_mask ^= "0"b then do k = 1 to switch_count;
	     if substr (switch_mask, k, 1) then
		call complain (0, ME, "Standard objects do not support the ^a switch.", switch_names (k));
	end;

SKIP_SWITCHES:
	if opt.entry_bound then do;
	     call PRINT_PATHNAME ();
	     if entry_type ^= star_SEGMENT then
		if explicit_opt.entry_bound then
		     call complain (0, ME, "The entry is not a gate.  ^a", pathname_ (dn, en));
		else ;
	     else do;
		bks.version = status_for_backup_version_2;
		call hcs_$status_for_backup (dn, en, addr (bks), code);
		if code ^= 0 then call complain (code, ME, "Unable to obtain entrybound.");
		else if ^bks.entrypt then
NOT_GATE:
		     if explicit_opt.entry_bound then call complain (0, ME, "The entry is not a gate.");
		     else ;
		else if active_function then call ioa_$rsnnl ("^d", return_string, k, fixed (bks.entrypt_bound));
		else if one_item then call ioa_ ("^d", fixed (bks.entrypt_bound));
		else call ioa_ ("entry bound:^8x^d", fixed (bks.entrypt_bound));
	     end;
	end;

	if opt.highest_ci then do;
	     call PRINT_PATHNAME ();
	     if active_function then call ioa_$rsnnl ("^d", return_string, k, auto_dm_file_status.highest_ci);
	     else if one_item then call ioa_ ("^d", auto_dm_file_status.highest_ci);
	     else call ioa_ ("highest control interval:  ^d", auto_dm_file_status.highest_ci);
	end;

	if opt.concurrency_switch then do;
	     call PRINT_PATHNAME ();
	     call PRINT_SWITCH ("concurrency", explicit_opt.concurrency_switch,
		^auto_dm_file_status.no_concurrency_sw, "1"b);
	end;

	if opt.rollback_switch then do;
	     call PRINT_PATHNAME ();
	     call PRINT_SWITCH ("rollback", explicit_opt.rollback_switch,
		^auto_dm_file_status.no_rollback_sw, "1"b);
	end;

	if opt.protected_switch then do;
	     call PRINT_PATHNAME ();
	     call PRINT_SWITCH ("protected", explicit_opt.protected_switch,
		(auto_dm_file_status.protected_sw), "1"b);
	end;

	if not_mounted ^= 0 &amp; all &amp; ^active_function then
	     call complain (not_mounted, ME,
		"Unable to determine: date used, date modified, date volume dumped, records used, max length or usage count.");

	if j = star_entry_count &amp; ^active_function &amp; ^one_item then call ioa_ ("");
	if (entry_type = EXTENDED_type) &amp; (switch_list_ptr ^= null ()) then free switch_list;

ENTRY_RETURN:
	return;
%page;
CONVERT_DATE: proc (date_time);

/* This internal procedure converts a bit(36) clock time into an ASCII date string.
   If status was called as an active function, the string is returned. */

dcl  date_time bit (36);
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  cv_fstime_ entry (bit (36) aligned) returns (fixed bin (71));

	if date_time = "0"b then date_string = "ZERO";
	else date_string = date_time_$format ("date_time", cv_fstime_ ((date_time)), "", "");
	if active_function then do;
	     return_string = """" || rtrim (date_string) || """";
	     go to ENTRY_RETURN;			/* "status" active function must call normal cleanup handler before it finishes. */
	end;

     end CONVERT_DATE;
%page;
ENTRY_ERROR: proc (P_code, P_dn, P_en);

dcl  P_code fixed bin (35);
dcl  (P_dn, P_en) char (*);

	if active_function then do;
	     if msf_ptr ^= null then
		call msf_manager_$close (msf_ptr);
	     call CLEAN_UP;
	end;
	call complain (P_code, ME, "^a", pathname_ (P_dn, P_en));
	go to ENTRY_RETURN;

     end ENTRY_ERROR;
%page;
ENTRY_WRONG_TYPE: proc (P_string);

dcl  P_string char (*);

	if ^star_sw then
	     call complain (0, ME, "^a is ^[the root^;^a^]. Control arguments given do not apply.",
		pathname_ (dn, en), root_sw, P_string);
	go to ENTRY_RETURN;

     end ENTRY_WRONG_TYPE;
%page;
PRINT_PATHNAME: proc;

/* This internal procedure merely prints out the pathname if it hasn't been
   printed yet. */

	if printed_pathname | active_function then return;

	if star_sw | (path_count &gt; 1) then
	     if one_item then call ioa_ ("^5x^a", pathname_ (dn, en));
	     else call ioa_ ("^/^10x^a", pathname_ (dn, en));
	else ;					/* don't print header for only 1 path on command line */

	printed_pathname = "1"b;
	return;

     end PRINT_PATHNAME;
%page;
STATUS_SWITCH: proc (switch, explicit);

dcl  switch char (*);
dcl  temp_switch char (32);
dcl  explicit bit (1) unaligned;
dcl  default bit (1) aligned;
dcl  value bit (1) aligned;
dcl  x fixed bin;

	if switch = "cvds" then temp_switch = "complete_volume_dump";
	else if switch = "ivds" then temp_switch = "incremental_volume_dump";
	else temp_switch = switch;

	do k = 1 to switch_list.switch_count;
	     do x = 0 to switch_list.name_count (k) - 1;
		if switch_list.name_index (k) &gt; 0 then
		     if switch = switch_list.names (switch_list.name_index (k) + x) then go to JOIN;
	     end;
	end;

	if explicit then
	     call complain (0, ME, "The ^a switch is not supported by ^a.", switch, si.plural_name);

	return;

STATUS_SWITCH_QUICK: entry (switch, explicit);

	temp_switch = switch;
JOIN:
	if switch_list.name_index (k) = 0 then return;	/* already printed */
	switch_list.name_index (k) = 0;		/* so we don't come back */
	default = switch_list.default_value (k);

	call fs_util_$get_switch (dn, en, temp_switch, value, code);
	goto PRINT;

PRINT_SWITCH: entry (switch, explicit, switch_value, default_value);

dcl  switch_value bit (1) aligned;
dcl  default_value bit (1) aligned;

	value = switch_value;
	default = default_value;
	code = 0;
PRINT:
	if code ^= 0 then call complain (code, ME, "Unable to get ^a switch.", switch);

	if active_function then do;
	     if value then return_string = "true";
	     else return_string = "false";
	     return;
	end;
	else if all | (value ^= default) then
	     if one_item then call ioa_ ("^[on^;off^]", value);
	     else call ioa_ ("^a switch:^vt^[on^;off^] (default^[ = ^[off^;on^]^])", switch, max_switch_length, value,
		     value ^= default, value);
	else if explicit then
	     if one_item then call ioa_ ("^[on^;off^]", value);
	     else call ioa_ ("^a switch:^vt^[on^;off^]", switch, max_switch_length, value);

	return;

     end STATUS_SWITCH;

     end ENTRY_STATUS;
%page;
BUILD_ENTRY_TYPE_LIST: proc (P_entry_type_list, P_fs_entry_type_ptr, P_slet_enabled_sw);

dcl  P_entry_type_list char (*);
dcl  P_fs_entry_type_ptr ptr;
dcl  P_slet_enabled_sw bit (1) aligned;
dcl  1 entry_type_info aligned like suffix_info;
dcl  types char (types_len) based (types_ptr);
dcl  types_len fixed bin (24);
dcl  types_ptr ptr;
dcl  this_type char (32);

/* Copy the entry type list parameter into locally managed storage */

	types_ptr = null;
	on cleanup begin;
	     if types_ptr ^= null then free types in (area);
	end;

	types_len = length (P_entry_type_list);
	allocate types set (types_ptr) in (area);
	types = P_entry_type_list;

/* Count the number of entry types and allocate the entry type array */

	do fs_entry_type_count = 1
	     repeat (fs_entry_type_count + 1)
	     while (index (types, ",") ^= 0);
	     types = after (types, ",");
	end;

	allocate fs_entry_type in (area) set (P_fs_entry_type_ptr);

	entry_type_info.version = SUFFIX_INFO_VERSION_1;
	P_fs_entry_type_ptr -&gt; fs_entry_type.suffix (*) = "";

/* For each potential entry type, validate it and add it to the structure */

	types = P_entry_type_list;
	entry_type_index = 1;

	do while (types ^= "");

	     this_type = before (types, ",");
	     if substr (this_type, 1, 1) ^= "-" then do;
		if this_type = "link" then this_type = FS_OBJECT_TYPE_LINK;
		else if this_type = "segment" then this_type = FS_OBJECT_TYPE_SEGMENT;
		else if this_type = "directory" then this_type = FS_OBJECT_TYPE_DIRECTORY;
		else if this_type = "multisegment_file" then this_type = FS_OBJECT_TYPE_MSF;
		else if this_type = "data_management_file" then this_type = FS_OBJECT_TYPE_DM_FILE;

		P_fs_entry_type_ptr -&gt; fs_entry_type.suffix (entry_type_index) = this_type;

		if this_type = FS_OBJECT_TYPE_LINK then entry_type_index = entry_type_index + 1;
						/* fs_util_ does not handle links */
		else do;
		     call fs_util_$suffix_info_for_type (this_type, addr (entry_type_info), code);
		     if code = 0 then entry_type_index = entry_type_index + 1;
		end;
	     end;

	     types = after (types, ",");
	end;

/* Free the types variable and set P_slet_enabled_sw */

	free types_ptr -&gt; types in (area);

	P_fs_entry_type_ptr -&gt; fs_entry_type.count = entry_type_index - 1;
	if P_fs_entry_type_ptr -&gt; fs_entry_type.count &gt; 0 then P_slet_enabled_sw = "1"b;
	else do;
	     call complain (0, ME,
		"^[None of the specified entry types is valid^;The specified entry type is not valid^]: ^a",
		P_fs_entry_type_ptr -&gt; fs_entry_type.count &gt; 1, P_entry_type_list);
	     go to STATUS_EXIT;
	end;

	return;

     end BUILD_ENTRY_TYPE_LIST;
%page;
ENTRY_TYPE_SELECTED: proc (P_fs_type, P_fs_entry_type_ptr) returns (bit (1) aligned);

dcl  P_fs_type char (*);
dcl  P_fs_entry_type_ptr ptr;
dcl  entry_type_index fixed bin;

	do entry_type_index = 1 to P_fs_entry_type_ptr -&gt; fs_entry_type.count;
	     if P_fs_type = P_fs_entry_type_ptr -&gt; fs_entry_type.suffix (entry_type_index) then return ("1"b);
	end;

	return ("0"b);

     end ENTRY_TYPE_SELECTED;
%page;
CLEAN_UP: proc;

	if star_list_names_ptr ^= null then free star_list_names in (area);
	if star_list_branch_ptr ^= null then free star_dir_list_branch in (area);
	if fs_entry_type_ptr ^= null then free fs_entry_type in (area);
	if path_array_ptr ^= null &amp; path_array_ptr ^= addr (path_array_space) then free path_array in (area);

     end CLEAN_UP;
%page;
dcl  1 access_options int static,			/* for -access */

       (2 primary_name init ("0"b),
       2 names init ("0"b),
       2 type init ("0"b),
       2 link_path init ("0"b),
       2 unique_id init ("0"b),
       2 dtu init ("0"b),
       2 dtcm init ("0"b),
       2 dtem init ("0"b),
       2 dtd init ("0"b),
       2 dtvd init ("0"b),
       2 author init ("0"b),
       2 bc_author init ("0"b),
       2 logical_volume init ("0"b),
       2 bit_count init ("0"b),
       2 records_used init ("0"b),
       2 current_length init ("0"b),
       2 max_length init ("0"b),
       2 mode init ("1"b),
       2 access_class init ("1"b),
       2 ring_brackets init ("1"b),
       2 safety_switch init ("1"b),
       2 copy_switch init ("0"b),
       2 audit_switch init ("0"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("0"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("0"b),
       2 concurrency_switch init ("0"b),
       2 rollback_switch init ("0"b),
       2 protected_switch init ("0"b)
       ) bit (1) unaligned;
%page;
dcl  1 date_options int static,			/* for -date */
       (2 primary_name init ("0"b),
       2 names init ("0"b),
       2 type init ("0"b),
       2 link_path init ("0"b),
       2 unique_id init ("0"b),
       2 dtu init ("1"b),
       2 dtcm init ("1"b),
       2 dtem init ("1"b),
       2 dtd init ("1"b),
       2 dtvd init ("1"b),
       2 author init ("0"b),
       2 bc_author init ("0"b),
       2 logical_volume init ("0"b),
       2 bit_count init ("0"b),
       2 records_used init ("0"b),
       2 current_length init ("0"b),
       2 max_length init ("0"b),
       2 mode init ("0"b),
       2 access_class init ("0"b),
       2 ring_brackets init ("0"b),
       2 safety_switch init ("0"b),
       2 copy_switch init ("0"b),
       2 audit_switch init ("0"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("0"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("0"b),
       2 concurrency_switch init ("0"b),
       2 rollback_switch init ("0"b),
       2 protected_switch init ("0"b)
       ) bit (1) unaligned;
%page;
dcl  1 length_options int static,			/* for -length */
       (2 primary_name init ("0"b),
       2 names init ("0"b),
       2 type init ("0"b),
       2 link_path init ("0"b),
       2 unique_id init ("0"b),
       2 dtu init ("0"b),
       2 dtcm init ("0"b),
       2 dtem init ("0"b),
       2 dtd init ("0"b),
       2 dtvd init ("0"b),
       2 author init ("0"b),
       2 bc_author init ("0"b),
       2 logical_volume init ("0"b),
       2 bit_count init ("1"b),
       2 records_used init ("1"b),
       2 current_length init ("1"b),
       2 max_length init ("1"b),
       2 mode init ("0"b),
       2 access_class init ("0"b),
       2 ring_brackets init ("0"b),
       2 safety_switch init ("0"b),
       2 copy_switch init ("0"b),
       2 audit_switch init ("0"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("0"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("0"b),
       2 concurrency_switch init ("0"b),
       2 rollback_switch init ("0"b),
       2 protected_sw init ("0"b)
       ) bit (1) unaligned;
%page;
dcl  1 active_function_length_options int static,		/* for -length */
       (2 primary_name init ("0"b),
       2 names init ("0"b),
       2 type init ("0"b),
       2 link_path init ("0"b),
       2 unique_id init ("0"b),
       2 dtu init ("0"b),
       2 dtcm init ("0"b),
       2 dtem init ("0"b),
       2 dtd init ("0"b),
       2 dtvd init ("0"b),
       2 author init ("0"b),
       2 bc_author init ("0"b),
       2 logical_volume init ("0"b),
       2 bit_count init ("1"b),			/* for directory type only */
       2 records_used init ("0"b),
       2 current_length init ("1"b),			/* for other types such as segment or MSF or DM file */
       2 max_length init ("0"b),
       2 mode init ("0"b),
       2 access_class init ("0"b),
       2 ring_brackets init ("0"b),
       2 safety_switch init ("0"b),
       2 copy_switch init ("0"b),
       2 audit_switch init ("0"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("0"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("0"b),
       2 concurrency_switch init ("0"b),
       2 rollback_switch init ("0"b),
       2 protected_sw init ("0"b)
       ) bit (1) unaligned;
%page;
dcl  1 default_options int static,			/* no control arguments specified */
       (2 primary_name init ("0"b),
       2 names init ("1"b),
       2 type init ("1"b),
       2 link_path init ("1"b),
       2 unique_id init ("0"b),
       2 dtu init ("1"b),
       2 dtcm init ("1"b),
       2 dtem init ("1"b),
       2 dtd init ("0"b),
       2 dtvd init ("0"b),
       2 author init ("0"b),
       2 bc_author init ("0"b),
       2 logical_volume init ("0"b),
       2 bit_count init ("1"b),
       2 records_used init ("1"b),
       2 current_length init ("0"b),
       2 max_length init ("0"b),
       2 mode init ("1"b),
       2 access_class init ("0"b),
       2 ring_brackets init ("0"b),
       2 safety_switch init ("0"b),
       2 copy_switch init ("0"b),
       2 audit_switch init ("0"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("1"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("1"b),
       2 concurrency_switch init ("1"b),
       2 rollback_switch init ("1"b),
       2 protected_switch init ("1"b)
       ) bit (1) unaligned;
%page;
dcl  1 no_s_options int static,			/* attributes available without s access */
       (2 primary_name init ("0"b),
       2 names init ("0"b),
       2 type init ("1"b),
       2 link_path init ("1"b),
       2 unique_id init ("1"b),
       2 dtu init ("1"b),
       2 dtcm init ("1"b),
       2 dtem init ("1"b),
       2 dtd init ("1"b),
       2 dtvd init ("1"b),
       2 author init ("1"b),
       2 bc_author init ("1"b),
       2 logical_volume init ("1"b),
       2 bit_count init ("1"b),
       2 records_used init ("1"b),
       2 current_length init ("1"b),
       2 max_length init ("1"b),
       2 mode init ("1"b),
       2 access_class init ("1"b),
       2 ring_brackets init ("1"b),
       2 safety_switch init ("1"b),
       2 copy_switch init ("1"b),
       2 audit_switch init ("1"b),
       2 ivds init ("1"b),
       2 cvds init ("1"b),
       2 usage_count init ("1"b),
       2 damaged_switch init ("1"b),
       2 synchronized_switch init ("1"b),
       2 entry_bound init ("1"b),
       2 highest_ci init ("1"b),
       2 concurrency_switch init ("1"b),
       2 rollback_switch init ("1"b),
       2 protected_switch init ("1"b)
       ) bit (1) unaligned;
%page;
dcl  1 off_line_options int static,			/* attributes available without VTOC */
       (2 primary_name init ("1"b),
       2 names init ("1"b),
       2 type init ("1"b),
       2 link_path init ("1"b),
       2 unique_id init ("1"b),
       2 dtu init ("0"b),
       2 dtcm init ("0"b),
       2 dtem init ("1"b),
       2 dtd init ("1"b),
       2 dtvd init ("0"b),
       2 author init ("1"b),
       2 bc_author init ("1"b),
       2 logical_volume init ("1"b),
       2 bit_count init ("1"b),
       2 records_used init ("0"b),
       2 current_length init ("0"b),
       2 max_length init ("1"b),
       2 mode init ("1"b),
       2 access_class init ("1"b),
       2 ring_brackets init ("1"b),
       2 safety_switch init ("1"b),
       2 copy_switch init ("1"b),
       2 audit_switch init ("1"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("0"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("1"b),
       2 highest_ci init ("0"b),
       2 concurrency_switch init ("0"b),
       2 rollback_switch init ("0"b),
       2 protected_switch init ("0"b)
       ) bit (1) unaligned;
%page;
dcl  1 link_options int static,			/* attributes valid for links */
       (2 primary_name init ("1"b),
       2 names init ("1"b),
       2 type init ("1"b),
       2 link_path init ("1"b),
       2 unique_id init ("0"b),
       2 dtu init ("0"b),
       2 dtcm init ("0"b),
       2 dtem init ("1"b),
       2 dtd init ("1"b),
       2 dtvd init ("1"b),
       2 author init ("1"b),
       2 bc_author init ("0"b),
       2 logical_volume init ("0"b),
       2 bit_count init ("0"b),
       2 records_used init ("0"b),
       2 current_length init ("0"b),
       2 max_length init ("0"b),
       2 mode init ("0"b),
       2 access_class init ("0"b),
       2 ring_brackets init ("0"b),
       2 safety_switch init ("0"b),
       2 copy_switch init ("0"b),
       2 audit_switch init ("0"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("0"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("0"b),
       2 concurrency_switch init ("0"b),
       2 rollback_switch init ("0"b),
       2 protected_switch init ("0"b)
       ) bit (1) unaligned;
%page;
dcl  1 nonlink_options int static,			/* attributes valid for non-links */
       (2 primary_name init ("1"b),
       2 names init ("1"b),
       2 type init ("1"b),
       2 link_path init ("0"b),
       2 unique_id init ("1"b),
       2 dtu init ("1"b),
       2 dtcm init ("1"b),
       2 dtem init ("1"b),
       2 dtd init ("1"b),
       2 dtvd init ("1"b),
       2 author init ("1"b),
       2 bc_author init ("1"b),
       2 logical_volume init ("1"b),
       2 bit_count init ("1"b),
       2 records_used init ("1"b),
       2 current_length init ("1"b),
       2 max_length init ("1"b),
       2 mode init ("1"b),
       2 access_class init ("1"b),
       2 ring_brackets init ("1"b),
       2 safety_switch init ("1"b),
       2 copy_switch init ("1"b),
       2 audit_switch init ("1"b),
       2 ivds init ("1"b),
       2 cvds init ("1"b),
       2 usage_count init ("1"b),
       2 damaged_switch init ("1"b),
       2 synchronized_switch init ("1"b),
       2 entry_bound init ("1"b),
       2 highest_ci init ("1"b),
       2 concurrency_switch init ("1"b),
       2 rollback_switch init ("1"b),
       2 protected_switch init ("1"b)
       ) bit (1) unaligned;
%page;
dcl  1 dm_file_options int static,			/* attributes valid for DM files */
       (2 primary_name init ("1"b),
       2 names init ("1"b),
       2 type init ("1"b),
       2 link_path init ("0"b),
       2 unique_id init ("1"b),
       2 dtu init ("1"b),
       2 dtcm init ("1"b),
       2 dtem init ("1"b),
       2 dtd init ("1"b),
       2 dtvd init ("1"b),
       2 author init ("1"b),
       2 bc_author init ("0"b),
       2 logical_volume init ("1"b),
       2 bit_count init ("0"b),
       2 records_used init ("1"b),
       2 current_length init ("1"b),
       2 max_length init ("1"b),
       2 mode init ("1"b),
       2 access_class init ("1"b),
       2 ring_brackets init ("1"b),
       2 safety_switch init ("0"b),
       2 copy_switch init ("0"b),
       2 audit_switch init ("0"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("0"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("1"b),
       2 concurrency_switch init ("1"b),
       2 rollback_switch init ("1"b),
       2 protected_switch init ("1"b)
       ) bit (1) unaligned;
%page;
dcl  1 fm_status_options int static,			/* DM file attr's requiring file_manager_$status */
       (2 primary_name init ("0"b),
       2 names init ("0"b),
       2 type init ("0"b),
       2 link_path init ("0"b),
       2 unique_id init ("1"b),
       2 dtu init ("0"b),
       2 dtcm init ("0"b),
       2 dtem init ("0"b),
       2 dtd init ("0"b),
       2 dtvd init ("0"b),
       2 author init ("0"b),
       2 bc_author init ("0"b),
       2 logical_volume init ("0"b),
       2 bit_count init ("0"b),
       2 records_used init ("0"b),
       2 current_length init ("0"b),
       2 max_length init ("0"b),
       2 mode init ("1"b),
       2 access_class init ("0"b),
       2 ring_brackets init ("1"b),
       2 safety_switch init ("0"b),
       2 copy_switch init ("0"b),
       2 audit_switch init ("0"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("0"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("1"b),
       2 concurrency_switch init ("1"b),
       2 rollback_switch init ("1"b),
       2 protected_switch init ("1"b)
       ) bit (1) unaligned;
%page;
dcl  1 root_options int static,			/* attributes available for the root */
       (2 primary_name init ("1"b),
       2 names init ("1"b),
       2 type init ("1"b),
       2 link_path init ("0"b),
       2 unique_id init ("1"b),
       2 dtu init ("1"b),
       2 dtcm init ("0"b),
       2 dtem init ("0"b),
       2 dtd init ("0"b),
       2 dtvd init ("0"b),
       2 author init ("1"b),
       2 bc_author init ("1"b),
       2 logical_volume init ("1"b),
       2 bit_count init ("1"b),
       2 records_used init ("0"b),
       2 current_length init ("0"b),
       2 max_length init ("0"b),
       2 mode init ("1"b),
       2 access_class init ("0"b),
       2 ring_brackets init ("1"b),
       2 safety_switch init ("1"b),
       2 copy_switch init ("0"b),
       2 audit_switch init ("0"b),
       2 ivds init ("0"b),
       2 cvds init ("0"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("1"b),
       2 synchronized_switch init ("0"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("0"b),
       2 concurrency_switch init ("0"b),
       2 rollback_switch init ("0"b),
       2 protected_switch init ("0"b)
       ) bit (1) unaligned;
%page;
dcl  1 typed_options int static,			/* attributes that must come from fs_util_ */
       (2 primary_name init ("0"b),
       2 names init ("0"b),
       2 type init ("1"b),
       2 link_path init ("0"b),
       2 unique_id init ("0"b),
       2 dtu init ("0"b),
       2 dtcm init ("0"b),
       2 dtem init ("0"b),
       2 dtd init ("0"b),
       2 dtvd init ("0"b),
       2 author init ("0"b),
       2 bc_author init ("0"b),
       2 logical_volume init ("0"b),
       2 bit_count init ("0"b),
       2 records_used init ("0"b),
       2 current_length init ("0"b),
       2 max_length init ("1"b),
       2 mode init ("1"b),
       2 access_class init ("0"b),
       2 ring_brackets init ("1"b),
       2 safety_switch init ("1"b),
       2 copy_switch init ("1"b),
       2 audit_switch init ("1"b),
       2 ivds init ("1"b),
       2 cvds init ("1"b),
       2 usage_count init ("0"b),
       2 damaged_switch init ("1"b),
       2 synchronized_switch init ("1"b),
       2 entry_bound init ("0"b),
       2 highest_ci init ("1"b),
       2 concurrency_switch init ("1"b),
       2 no_rollback_sw init ("1"b),
       2 protected_switch init ("1"b)
       ) bit (1) unaligned;
%page;
%include branch_status;
%page;
%include copy_flags;
%page;
%include dm_file_status;
%page;
%include star_structures;
%page;
%include status_for_backup;
%page;
%include suffix_info;


     end status;




		    truncate.pl1                    03/07/85  1017.7r w 03/06/85  1230.1       77706



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


truncate:  tc:   proc;

/*   This command is used to truncate a specified segment to a specified word offset.
	the segment to be truncated is referred to either by a pathname or an octal segment
	number. The second argument is the length to which the segment is to be truncated.
	If no offset is supplied, zero will be assumed.

	Written by Robert S. Coren Sept 1972
	Modified Nov 1983 by Charles Spitzer. make work on consistent MSFs.

*/


/*	entry declarations   */
dcl	cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl	cv_oct_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35));
dcl	com_err_ entry options(variable);
dcl	expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
dcl	hcs_$get_safety_sw_seg entry (ptr, bit (1), fixed bin (35));
dcl	hcs_$truncate_file entry (char(*), char(*), fixed bin(19), fixed bin(35));
dcl	hcs_$truncate_seg entry (ptr, fixed bin(19), fixed bin(35));


dcl	hcs_$set_bc entry (char(*), char(*), fixed bin(24), fixed bin(35));
dcl	hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35));


/*	external refs  */

dcl      (error_table_$noarg,
	error_table_$dirseg,
	error_table_$noentry,
	error_table_$inconsistent_msf) fixed bin(35) ext static;

/*	static   */

dcl	myname char (32) int static options (constant) init ("truncate");

/*	fixed binary    */

dcl	alen fixed bin(21); /* length of currently examined argument */
dcl	code fixed bin(35); /* status code */
dcl	bitcnt fixed bin(24);/* new bit count */
dcl	nwords fixed bin(19);/* new length in words */
dcl	i fixed bin;	/* argument counter */
dcl	segno fixed bin;

/*	pointers  */

dcl
	aptr ptr;		/* pointer to latest argument */
dcl	segptr ptr;	/* pointer to segment if number coded */

dcl	(baseptr,char,divide,ltrim,null) builtin;

/*	character strings  */

dcl	dir char(168);
dcl	ent char(32);
dcl	arg char(alen) based(aptr);
dcl	argsave char(168) init(" ");

/*	labels    */
dcl	callpt label local;

/********************	code begins here	***********************/

	i = 1;
	call cu_$arg_ptr(i,aptr,alen,code);
	if code = error_table_$noarg|alen = 0 then go to nogood;

	if arg = "-name" | arg = "-nm" then do;		/* Name option */

	     i = i + 1;				/* Next arg is name of segment */
	     call cu_$arg_ptr(i,aptr,alen,code);
	     if code = error_table_$noarg | alen = 0 then go to nogood;
	     end;

	else do;					/* find out if it's a number */
	     segno = cv_oct_check_(arg,code);
	     if code = 0 then do;		/* it is */
		segptr = baseptr(segno);
		callpt = seg;
		go to getoff;
		end;
	     end;

				/* if it's a name, expand it */

	call expand_pathname_(arg,dir,ent,code);
	if code ^= 0 then do;
               argsave = arg;
               go to nogood;
               end;
	callpt = file;

getoff:
	argsave = arg;
	i = i + 1;		/* Get offset argument (if any) */
	call cu_$arg_ptr(i,aptr,alen,code);
	if code=0 &amp; alen&gt;0 then do;
	     nwords = cv_oct_check_(arg,code);
	     if code^=0 then go to badarg;
	     bitcnt = nwords*36;
	     end;
	else do;
	     nwords,bitcnt = 0;	/* default is 0 */
	     end;


	go to callpt;


/**********************	actual truncation now	*******************/

file:					/* pathname given */
	call hcs_$truncate_file(dir,ent,nwords,code);
	if code = 0 then do;
	     call hcs_$set_bc(dir,ent,bitcnt,code);
	     if code ^= 0 then goto nogood;
	     end;
	else if code = error_table_$dirseg then call truncate_msf;
	     else goto nogood;
	return;

seg:					/* segment number given */
	call hcs_$truncate_seg(segptr,nwords,code);
	if code = 0 then do;
	     call hcs_$set_bc_seg(segptr,bitcnt,code);
	     if code = 0 then return;
	     end;

			/**** ERROR BRANCHES  ****/

nogood:
	call com_err_(code,myname,"^a",argsave);
	return;



badarg:			/* Non-numeric offset */
	call com_err_(0,myname,"Invalid offset: ^a",arg);
	return;

%page;
truncate_msf:
     proc;

dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));
dcl delete_$ptr entry (ptr, bit(36) aligned, char(*), fixed bin(35));
dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35));
dcl pathname_ entry (char(*), char(*)) returns(char(168));

dcl cleanup condition;

dcl ec fixed bin (35);				/* error code */
dcl word_count fixed bin (19);
dcl word_count_sum fixed bin (35);
dcl path char (168);
dcl component fixed bin;
dcl (max_component, min_component) fixed bin (24);
dcl component_count fixed bin;
dcl deleting bit (1) aligned;
dcl safety_sw bit (1);
dcl error_component fixed bin;

	path = pathname_ (dir, ent);

/* get the number of components. */

	call hcs_$star_ (path, "**", 3, null, component_count, (null), (null), ec);
	if ec ^= 0 then return;

	begin;

dcl segp ptr;
dcl msf_bc fixed bin (24);

dcl 1 segs (component_count),				/* components of the msf */
      2 name char (32),				/* component name */
      2 segp ptr,					/* ptr to base of component */
      2 bc fixed bin (24);				/* bit count of component */

	     segp, segs.segp (*) = null;

	     on cleanup call msf_cleanup;

	     ec, max_component = 0;
	     do component = 1 by 1 while (ec = 0 &amp; component &lt;= component_count);
		segs.name (component) = ltrim (char (max_component));
		call initiate_file_ (path, segs.name (component), "001"b, segs.segp (component), segs.bc (component), ec);
		if ec = 0
		then max_component = max_component + 1;
		else error_component = max_component;
		end;

	     if ec ^= 0
	     then if ec ^= error_table_$noentry then goto msf_close;

	     if max_component ^= component_count then do;
		ec = error_table_$inconsistent_msf;	/* not enough segments in MSF to match what star_ said */
		error_component = 0;
		goto msf_close;
		end;

	     word_count_sum, word_count = 0;
	     do component = 1 to max_component;
		word_count = divide (segs.bc (component) + 35, 36, 24, 0);
		if word_count_sum + word_count &gt;= nwords
		then do;				/* end the MSF on this component */
		     msf_bc, min_component = component; /* MSF bit count is highest numbered component */

/* going backwards means we have a valid MSF if we get an abort for any reason */

		     deleting = "1"b;		/* delete components */
		     do component = max_component to min_component+1 by -1;
			error_component = component;
			call hcs_$get_safety_sw_seg (segs.segp (component), safety_sw, ec);
			if ec ^= 0 then goto msf_close;

			if ^safety_sw &amp; deleting
			then do;
			     call delete_$ptr (segs.segp (component), "010101"b, "truncate", ec);
			     segs.segp (component) = null;
			     end;
			else do;
			     if deleting
			     then do;
				 msf_bc = component;/* how many components to set the bit count of the dir */
				 deleting = "0"b;	/* don't delete any more previous to this one */
				 end;
			     call terminate_file_ (segs.segp (component),
				0, TERM_FILE_TRUNC_BC_TERM, ec);
			     end;

			if ec ^= 0 then goto msf_close;
			end;

		     error_component = min_component;
		     call terminate_file_ (segs.segp (min_component), (nwords-word_count_sum)*36,
			TERM_FILE_TRUNC_BC_TERM, ec);
		     if ec ^= 0 then goto msf_close;

		     error_component = 0;
		     call hcs_$set_bc (dir, ent, msf_bc, ec);
		     goto msf_close;
		     end;
		else word_count_sum = word_count_sum + word_count;
		end;

/* We reached the end of the MSF before nwords. This is not allowed. Issue
   an error message and return. */

	     call com_err_ (0, myname, "Truncation length specified is larger than current length of ^d for ^a.",
		word_count_sum, path);
	     ec = 0;

msf_close:
	     if ec ^= 0 then call com_err_ (ec, myname, "^a^[&gt;^d^]", path, (error_component ^= 0), error_component);

	     call msf_cleanup;

msf_cleanup:					/* inside begin block */
	proc;

	do component = 1 to component_count;
	     if segs.segp (component) ^= null then call terminate_file_ (segs.segp (component), 0, "0010"b, (0));
	     end;

	if segp ^= null then call terminate_file_ (segp, 0, "0010"b, (0));

	return;

	end msf_cleanup;

	     end;					/* begin block */

	return;

     end truncate_msf;

%include terminate_file;

end truncate;






		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
</pre></body></html>