comp_dir_info.pl1               11/23/82  1145.3rew 11/22/82  1111.4      212472



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


comp_dir_info: proc;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* comp_dir_info - compare two saved directories					*/
	/*									*/
	/* Status:								*/
	/*									*/
	/* 0) Created   May, 1973 by T. H. VanVleck					*/
	/* 1) Modified  July, 1982 by Jim Lippard to only print 2 dir ring brackets		*/
	/* 2) Modified  Oct, 1982 by G. C. Dixon to modernize the code			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  al fixed bin(21),				/* length of arg */
     an fixed bin,
     ap ptr,					/* ptr to arg */
    (datstr1, datstr2) char (24),
     ec fixed bin (35),				/* error code */
     en1 char (32),
    (fdir1, fdir2) char (168),
    (fent1, fent2) char (32),
    (firstadd, firstdelete) bit (1),
    (fptr1, fptr2) ptr,
     headed bit (1),
    (i, k, m, n) fixed bin,
     loud bit (1),
    (n1, n2) fixed bin,
     nacl fixed bin,
    (name1x, name2x) fixed bin,
     nchanges fixed bin,
    (np1, np2) ptr,
    (type1, type2) fixed bin,
     uid1 bit (36) aligned,
     verbosity fixed bin,
     xp ptr,
    (xp1, xp2) ptr;

dcl (addr, binary, fixed, index, max, null, ptr, substr) builtin;

dcl  cleanup condition;

dcl  bchr char (al) unal based (ap),			/* pickup for argument */
     names (100) char (32) aligned based;		/* names from star */

dcl  com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
     date_time_ entry (fixed bin(71), char(*)),
     date_time_$fstime entry (bit(36) aligned, char(*)),
     expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)),
     hcs_$initiate entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35)),
     hcs_$terminate_noname entry (ptr, fixed bin(35)),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable),
     list_dir_info_	entry (ptr, fixed bin, char(1)),
     mdc_$find_lvname entry (bit (36), char (*) aligned, fixed bin (35));

dcl  TAB char (1) int static options(constant) init("	"),
    (error_table_$bad_arg,
     error_table_$badopt) fixed bin(35) ext static,
     segtype (0:2) char (4) aligned int static options(constant) init("link", "seg ", "dir ");

%include saved_dir_info;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
ER:	   call com_err_ (ec, "comp_dir_info", "
Usage:  comp_dir_info dir_info_path1 dir_info_path2 {-control_arg}
Args:   -brief, -bf
        -verbose
        -long, -lg");
	   return;
	   end;
	call expand_pathname_$add_suffix (bchr, "dir_info", fdir1, fent1, ec);
	if ec ^= 0 then do;
	   call com_err_ (ec, "comp_dir_info", "^a", bchr);
	   return;
	   end;

	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then go to ER;
	call expand_pathname_$add_suffix (bchr, "dir_info", fdir2, fent2, ec);
	if ec ^= 0 then do;
	   call com_err_ (ec, "comp_dir_info", "^a", bchr);
	   return;
	   end;

	loud = "0"b;
	verbosity = 1;
	nchanges = 0;
	firstdelete, firstadd = "1"b;
	ec = 0;
	do an = 3 by 1 while (ec = 0);
	   call cu_$arg_ptr (an, ap, al, ec);
	   if ec = 0 then do;
	      if bchr = "-long" | bchr = "-lg" then do;
	         loud = "1"b;
	         verbosity = 2;
	         end;
	      else if bchr = "-verbose" | bchr = "-vb" then do;
	         loud = "1"b;
	         verbosity = 3;
	         end;
	      else if bchr = "-brief" | bchr = "-bf" then do;
	         loud = "0"b;
	         verbosity = 0;
	         end;
	      else do;
	         if index(bchr,"-") = 1 then
		  ec = error_table_$badopt;
	         else
		  ec = error_table_$bad_arg;
	         call com_err_ (ec, "comp_dir_info", "^a", bchr);
	         return;
	         end;
	      end;
	   end;

          fptr1 = null;
	fptr2 = null;
	on cleanup call janitor();

	call hcs_$initiate (fdir1, fent1, "", 0, 0, fptr1, ec);
	if fptr1 = null then do;
	   call com_err_ (ec, "comp_dir_info", "Accessing dir_info segment
(^a^[>^]^a).", fdir1, fdir1^=">", fent1);
	   go to EXIT;
	   end;

	call hcs_$initiate (fdir2, fent2, "", 0, 0, fptr2, ec);
	if fptr2 = null then do;
	   call com_err_ (ec, "comp_dir_info", "Accessing dir_info segment
(^a^[>^]^a).", fdir2, fdir2^=">", fent2);
	   go to EXIT;
	   end;

	if verbosity > 0 then do;			/* Print titles */
	   call date_time_ (fptr1 -> fseg.timeof, datstr1);
	   call date_time_ (fptr2 -> fseg.timeof, datstr2);
	   call ioa_ ("^|Comparing ^a as of ^a^/^7xto ^a as of ^a",
	      fptr1 -> fseg.fpath, datstr1, fptr2 -> fseg.fpath, datstr2);
	   end;
	n1 = fptr1 -> fseg.nents + 1;			/* add one because dir itself is in there. */
	n2 = fptr2 -> fseg.nents + 1;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This begin block contains the main loop.  We take one entry at a time from the old	*/
	/* segment, and look for it in the new segment.  A match on unique ID is preferred, or	*/
	/* else a match of any name in the new entry for the primary name on the old entry.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

COMPARE_BLOCK:
	begin;

dcl  x1 bit (n1);					/* if i'th bit of x1 is on, entry in old was deleted */
dcl  x2 bit (n2);					/* If i'th bit of x2 is on, entry in new was matched. */
dcl (x1count, x2count) fixed bin;

	   x1 = "0"b;				/* Clear check arrays. */
	   x2 = "0"b;
	   x1count = 0;
	   x2count = n2;

	   name1x = 1;
	   xp1 = addr (fptr1 -> fseg.ffirst);

LOOP:	   if xp1 -> seg_rec.type = "01"b then do;
	      type1 = 1;
	      np1 = addr (xp1 -> seg_rec.names);
	      uid1 = xp1 -> seg_rec.uid;
	      end;
	   else if xp1 -> dir_rec.type = "10"b then do;
	      type1 = 2;
	      np1 = addr (xp1 -> dir_rec.names);
	      uid1 = xp1 -> dir_rec.uid;
	      end;
	   else do;
	      type1 = 0;
	      np1 = addr (xp1 -> link_rec.names);
	      uid1 = (36)"0"b;
	      end;
	   en1 = np1 -> names (1);

	   name2x = 1;
	   xp2 = addr (fptr2 -> fseg.ffirst);
SEARCH:	   if x2count = 0 then go to NOTTHERE;
	   if substr (x2, name2x, 1) then go to NEXT;
	   type2 = fixed (xp2 -> seg_rec.type);
	   if type2 = 1 then np2 = addr (xp2 -> seg_rec.names);
	   else if type2 = 2 then np2 = addr (xp2 -> dir_rec.names);
	   else np2 = addr (xp2 -> link_rec.names);
	   if type2 ^= 0 then
	      if uid1 = xp2 -> seg_rec.uid then go to MATCH;
	   do i = 1 to xp2 -> seg_rec.n_names;
	      if np2 -> names (i) = en1 then if type1 = type2 then go to MATCH;
	      end;
NEXT:	   if xp2 -> seg_rec.fnext then do;
	      xp2 = ptr (xp2, xp2 -> seg_rec.fnext);
	      name2x = name2x + 1;
	      go to SEARCH;
	      end;

NOTTHERE:	   nchanges = nchanges + 1;
	   substr (x1, name1x, 1) = "1"b;		/* Entry was deleted. */
	   x1count = x1count + 1;
	   go to SKIP1;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This section is entered when we have found an entry in both the old and new dir_info	*/
	/* segments, with either a UID match or a name match, and the same type		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

MATCH:	   substr (x2, name2x, 1) = "1"b;
	   x2count = x2count - 1;
	   headed = "0"b;
	   m = xp2 -> seg_rec.n_names;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This section compares the names on the old and new entries.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

NAME_BLOCK:  begin;

dcl  nfg bit (m);					/* if i'th bit of nfg is on, name was matched */
dcl  nfg_count fixed bin;

	      nfg_count = m;
	      nfg = "0"b;
	      do i = 1 to xp1 -> seg_rec.n_names;
	         n = index (np1 -> names (i), " ");
	         do k = 1 to m while (nfg_count > 0);
		  if ^substr (nfg, k, 1) then	/* Make sure name not matched already */
		  if np1 -> names (i) = np2 -> names (k) then do;
		     substr (nfg, k, 1) = "1"b;
		     nfg_count = nfg_count - 1;
		     go to BREAK;			/* Name is matched. */
		     end;
		  end;
	         if ^headed then call head;		/* Leftover old name. */
	         call ioa_ ("^-name deleted:^-^a", np1 -> names (i));
BREAK:	         end;

	      do i = 1 to m while (nfg_count > 0);	/* Check for unmatched new names */
	         if ^substr (nfg, i, 1) then do;
		  nfg_count = nfg_count - 1;
		  if ^headed then call head;
		  call ioa_ ("^-name added:^-^a", np2 -> names (i));
		  end;
	         end;
	      end NAME_BLOCK;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Now we check the rest of the entry to see what has been modified.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	   if type1 = 0 then do;			/* If link, check target */
	      if xp1 -> link_rec.target ^= xp2 -> link_rec.target then do;
	         if ^headed then call head;
	         call ioa_ ("^-link target changed from ^a  to  ^a",
		  xp1 -> link_rec.target, xp2 -> link_rec.target);
	         end;
	      if loud then do;
	         if xp1 -> link_rec.dtem ^= xp2 -> link_rec.dtem then do;
		  if ^headed then call head;
		  call ioa_ ("^-date link modified changed from ^a  to  ^a",
		     datec (xp1 -> link_rec.dtem), datec (xp2 -> link_rec.dtem));
		  end;
	         end;
	      go to SKIP1;
	      end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Segment or directory. Check for changes.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	   if xp1 -> seg_rec.rbs (0) ^= xp2 -> seg_rec.rbs (0) then go to XRB;
	   if xp1 -> seg_rec.rbs (1) ^= xp2 -> seg_rec.rbs (1) then go to XRB;
	   if xp1 -> seg_rec.rbs (2) ^= xp2 -> seg_rec.rbs (2) then do;
XRB:	      if ^headed then call head;
	      call ioa_ ("^-ring brackets changed from ^d,^d^[,^d^;^s^] to ^d,^d^[,^d^;^s^]",
	         fixed (binary (xp1 -> seg_rec.rbs (0)), 35),
	         fixed (binary (xp1 -> seg_rec.rbs (1)), 35),
	         segtype (type1) ^= "dir ",
	         fixed (binary (xp1 -> seg_rec.rbs (2)), 35),
	         fixed (binary (xp2 -> seg_rec.rbs (0)), 35),
	         fixed (binary (xp2 -> seg_rec.rbs (1)), 35),
	         segtype (type2) ^= "dir ",
	         fixed (binary (xp2 -> seg_rec.rbs (2)), 35));
	      end;
	   if xp1 -> dir_rec.damaged ^= xp2 -> dir_rec.damaged then do;
	      if ^headed then call head;
	      call ioa_ ("^-damaged changed from ^[ON^;OFF^]  to  ^[ON^;OFF^]",
	         xp1 -> dir_rec.damaged, xp2 -> dir_rec.damaged);
	      end;

	   if loud then do;
	      if xp1 -> dir_rec.ssw ^= xp2 -> dir_rec.ssw then do;
	         if ^headed then call head;
	         call ioa_ ("^-safety switch changed from ^[ON^;OFF^]  to  ^[ON^;OFF^]",
		  xp1 -> dir_rec.ssw, xp2 -> dir_rec.ssw);
	         if xp1 -> dir_rec.tpd ^= xp2 -> dir_rec.tpd then do;
		  if ^headed then call head;
		  call ioa_ ("^-tpd changed from ^[ON^;OFF^]  to  ^[ON^;OFF^]",
		     xp1 -> dir_rec.tpd, xp2 -> dir_rec.tpd);
		  end;
	         end;
	      if xp1 -> dir_rec.author ^= xp2 -> dir_rec.author then do;
	         if ^headed then call head;
	         call ioa_ ("^-author changed from ^a  to  ^a",
		  xp1 -> dir_rec.author, xp2 -> dir_rec.author);
	         end;
	      if xp1 -> dir_rec.bc_author ^= xp2 -> dir_rec.bc_author then do;
	         if ^headed then call head;
	         call ioa_ ("^-bit count author changed from ^a  to  ^a",
		  xp1 -> dir_rec.bc_author, xp2 -> dir_rec.bc_author);
	         end;
	      if type1 = 1 then do;
	         call compare_acl (addr (xp1 -> seg_rec.acls), addr (xp2 -> seg_rec.acls),
		  xp1 -> seg_rec.nacls, xp2 -> seg_rec.nacls, "ACL", 1);
	         end;
	      else do;
	         call compare_acl (addr (xp1 -> dir_rec.acls), addr (xp2 -> dir_rec.acls),
		  xp1 -> dir_rec.nacls, xp2 -> dir_rec.nacls, "ACL", 2);
	         end;
	      end;

	   else do;				/* Non-loud mode. */
	      if type1 = 2 then			/* if dir */
	         if xp1 -> dir_rec.nacls > 0 then if xp2 -> dir_rec.nacls = 0 then go to ZACL;
	      if type1 = 1 then			/* else if seg */
	      if xp1 -> seg_rec.nacls > 0 then
	      if xp2 -> seg_rec.nacls = 0 then do;
ZACL:	         if ^headed then call head;
	         call ioa_ ("^-ACL has been deleted");
	         end;
	      end;

	   if type1 = 1 then do;			/* segment? */
	      if loud then do;
	         if xp1 -> seg_rec.dtem ^= xp2 -> seg_rec.dtem then do;
		  if ^headed then call head;
		  call ioa_ ("^-date branch modified changed from ^a  to  ^a",
		     datec (xp1 -> seg_rec.dtem), datec (xp2 -> seg_rec.dtem));
		  end;
	         if verbosity = 3 then do;
		  if (xp1 -> seg_rec.lvid ^= "0"b) & (xp1 -> seg_rec.lvid ^= xp2 -> seg_rec.lvid) then do;
		     if ^headed then call head;
		     call ioa_ ("^-volume changed from ^a  to  ^a",
		        volnc (xp1 -> seg_rec.lvid), volnc (xp2 -> seg_rec.lvid));
		     end;
		  if xp1 -> seg_rec.dtm ^= xp2 -> seg_rec.dtm then do;
		     if ^headed then call head;
		     call ioa_ ("^-date modified changed from ^a  to  ^a",
		        datec (xp1 -> seg_rec.dtm), datec (xp2 -> seg_rec.dtm));
		     end;
		  if xp1 -> seg_rec.bitcnt ^= xp2 -> seg_rec.bitcnt then do;
		     if ^headed then call head;
		     call ioa_ ("^-bit count changed from ^d  to  ^d",
		        fixed (binary (xp1 -> seg_rec.bitcnt), 35), fixed (binary (xp2 -> seg_rec.bitcnt), 35));
		     end;
		  end;
	         if xp1 -> seg_rec.records ^= xp2 -> seg_rec.records then do;
		  if ^headed then call head;
		  call ioa_ ("^-records used changed from ^d  to  ^d",
		     fixed (binary (xp1 -> seg_rec.records), 35), fixed (binary (xp2 -> seg_rec.records), 35));
		  end;
	         if xp1 -> dir_rec.max_lth ^= xp2 -> dir_rec.max_lth then do;
		  if ^headed then call head;
		  call ioa_ ("^-max length changed from ^d  to  ^d",
		     xp1 -> dir_rec.max_lth, xp2 -> dir_rec.max_lth);
		  end;
	         end;
	      else do;
	         if xp1 -> seg_rec.records then
	         if xp2 -> seg_rec.records = "0"b then do;
		  if ^headed then call head;
		  call ioa_ ("^-segment has been truncated");
		  end;
	         end;
	      end;

	   else do;				/* directory */
	      if (xp1 -> dir_rec.slvid ^= "0"b) & (xp1 -> dir_rec.slvid ^= xp2 -> dir_rec.slvid) then do;
	         if ^headed then call head;
	         call ioa_ ("^-sons volume changed from ^a  to  ^a",
		  volnc (xp1 -> dir_rec.slvid), volnc (xp2 -> dir_rec.slvid));
	         end;
	      if xp1 -> dir_rec.mdir ^= xp2 -> dir_rec.mdir then do;
	         if ^headed then call head;
	         call ioa_ ("^-mdir changed from ^[ON^;OFF^]  to  ^[ON^;OFF^]",
		  xp1 -> dir_rec.mdir, xp2 -> dir_rec.mdir);
	         end;
	      if xp1 -> dir_rec.quota ^= xp2 -> dir_rec.quota then do;
	         if ^headed then call head;
	         call ioa_ ("^-quota changed from ^d  to  ^d",
		  xp1 -> dir_rec.quota, xp2 -> dir_rec.quota);
	         end;
	      if xp1 -> seg_rec.bitcnt ^= xp2 -> seg_rec.bitcnt then do;
	         if ^headed then call head;
	         call ioa_ ("^-msf indicator changed from ^d  to  ^d",
		  fixed (binary (xp1 -> seg_rec.bitcnt), 35), fixed (binary (xp2 -> seg_rec.bitcnt), 35));
	         end;
	      if verbosity = 3 then do;
	         if xp1 -> seg_rec.dtem ^= xp2 -> seg_rec.dtem then do;
		  if ^headed then call head;
		  call ioa_ ("^-date branch modified changed from ^a  to  ^a",
		     datec (xp1 -> seg_rec.dtem), datec (xp2 -> seg_rec.dtem));
		  end;
	         if xp1 -> seg_rec.dtm ^= xp2 -> seg_rec.dtm then do;
		  if ^headed then call head;
		  call ioa_ ("^-date modified changed from ^a  to  ^a",
		     datec (xp1 -> seg_rec.dtm), datec (xp2 -> seg_rec.dtm));
		  end;
	         end;
	      if loud then do;
	         call compare_acl (addr (xp1 -> dir_rec.isacls), addr (xp2 -> dir_rec.isacls),
		  xp1 -> dir_rec.nisacls, xp2 -> dir_rec.nisacls, "initial seg acl", 1);
	         call compare_acl (addr (xp1 -> dir_rec.idacls), addr (xp2 -> dir_rec.idacls),
		  xp1 -> dir_rec.nidacls, xp2 -> dir_rec.nidacls, "initial dir acl", 2);
	         end;
	      end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Go on to the next record in the old dir_info segment.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

SKIP1:	   if xp1 -> seg_rec.fnext then do;
	      xp1 = ptr (xp1, xp1 -> seg_rec.fnext);
	      name1x = name1x + 1;
	      go to LOOP;
	      end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* End of scan over old dir_info segment, which began at label "LOOP"			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Scan old dir_info segment for any segments which were deleted.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	   i = 1;
	   xp1 = addr (fptr1 -> fseg.ffirst);
LOOP2A:	   if substr (x1, i, 1) then do;
	      x1count = x1count - 1;
	      type1 = fixed (xp1 -> seg_rec.type);
	      if type1 = 1 then np1 = addr (xp1 -> seg_rec.names);
	      else if type1 = 2 then np1 = addr (xp1 -> dir_rec.names);
	      else np1 = addr (xp1 -> link_rec.names);
	      if firstdelete then do;
	         call ioa_ ("^/^/");
	         firstdelete = "0"b;
	         end;
	      call ioa_ ("^/deleted:^-^a ^a", segtype (type1), np1 -> names (1));
	      call list_dir_info_ (xp1, verbosity, TAB);
	      end;
	   if x1count > 0 then
	   if xp1 -> seg_rec.fnext then do;
	      i = i + 1;
	      xp1 = ptr (xp1, xp1 -> seg_rec.fnext);
	      go to LOOP2A;
	      end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Hunt for any entries in the new segment which have been added.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	   i = 1;
	   xp2 = addr (fptr2 -> fseg.ffirst);
LOOP2:	   if ^substr (x2, i, 1) then do;
	      x2count = x2count - 1;
	      type2 = fixed (xp2 -> seg_rec.type);
	      if type2 = 1 then np2 = addr (xp2 -> seg_rec.names);
	      else if type2 = 2 then np2 = addr (xp2 -> dir_rec.names);
	      else np2 = addr (xp2 -> link_rec.names);
	      nchanges = nchanges + 1;
	      if firstadd then do;
	         call ioa_ ("^/^/");
	         firstadd = "0"b;
	         end;
	      call ioa_ ("^/added:^-^a ^a", segtype (type2), np2 -> names (1));
	      call list_dir_info_ (xp2, verbosity, TAB);
	      end;
	   if x2count > 0 then
	   if xp2 -> seg_rec.fnext then do;
	      i = i + 1;
	      xp2 = ptr (xp2, xp2 -> seg_rec.fnext);
	      go to LOOP2;
	      end;
	   end COMPARE_BLOCK;

	if nchanges = 0 then call ioa_ ("Identical");
	call ioa_ ("");

EXIT:	call janitor();
	return;

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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*		I  N  T  E  R  N  A  L        P  R  O  C  E  D  U  R  E  S		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


cmode:	proc (x, t) returns (char (5) aligned);

dcl  x bit (36) aligned;
dcl  t fixed bin;

dcl  ans char (5) aligned;
dcl (i, k) fixed bin;
dcl  xmode (2, 5) char (1) int static options(constant) init("r", "e", "w", "a", "", "s", "m", "a", "", "");

	k = 1;
	ans = "";
	do i = 1 to 5;
	   if substr (x, i, 1) then do;
	      substr (ans, k, 1) = xmode (t, i);
	      k = k + 1;
	      end;
	   end;

	if ans = "" then ans = "null";
	return (ans);

	end cmode;

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


compare_acl:
	proc (p1, p2, n1, n2, prefix, acltype);

dcl (p1, p2) ptr,
    (n1, n2) fixed bin,
     prefix char (*),
     acltype fixed bin;

dcl  aclbit bit (n2),
    (i, j) fixed bin,
     tcount fixed bin;

	aclbit = "0"b;
	tcount = n2;

	nacl = max(n1,n2);
	do i = 1 to n1;
	   do j = 1 to n2;
	      if p1 -> aclval.access_name (i) = p2 -> aclval.access_name (j) then do;
	         substr (aclbit, j, 1) = "1"b;
	         tcount = tcount - 1;
	         if p1 -> aclval.modes (i) = p2 -> aclval.modes (j) then go to ACLOK;
	         if ^headed then call head;
	         call ioa_ ("^-^a for ^a changed from ^a  to  ^a",
		  prefix, p2 -> aclval.access_name (j),
		  cmode (p1 -> aclval.modes (i), acltype), cmode (p2 -> aclval.modes (j), acltype));
	         go to ACLOK;
	         end;
	      end;
	   if ^headed then call head;
	   call ioa_ ("^-^a deleted: ^a ^a",
	      prefix, cmode (p1 -> aclval.modes (i), acltype), p1 -> aclval.access_name (i));
ACLOK:	   end;

	do i = 1 to n2 while (tcount > 0);
	   if ^substr (aclbit, i, 1) then do;
	      tcount = tcount - 1;
	      if ^headed then call head;
	      call ioa_ ("^-^a added: ^a ^a",
	         prefix, cmode (p2 -> aclval.modes (i), acltype), p2 -> aclval.access_name (i));
	      end;
	   end;

	end compare_acl;

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


datec:	proc (x) returns (char (24));

dcl  x bit (36);

dcl  datstr char (24);

	call date_time_$fstime ((x), datstr);
	return (datstr);

	end datec;

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


head:	proc;

	headed = "1"b;
	call ioa_ ("^/modified:^-^a ^a", segtype (type1), en1);
	nchanges = nchanges + 1;

	end head;

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


janitor:  proc();

	if fptr1 ^= null then
	   call hcs_$terminate_noname (fptr1, ec);
	if fptr2 ^= null then
	   call hcs_$terminate_noname (fptr2, ec);

	end janitor;

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


volnc:	proc (x) returns (char (32) aligned);

dcl  x bit (36);

dcl  lvname char (32) aligned, code fixed bin (35);

	call mdc_$find_lvname (x, lvname, code);
	if code ^= 0 then call ioa_$rsnnl ("^w", lvname, code, x);
	return (lvname);

	end volnc;

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


       end comp_dir_info;




		    list_dir_info.pl1               11/19/82  1510.3rew 11/19/82  0921.9       37008



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


list_dir_info:
	proc;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* list_dir_info - list directory info saved by save_dir_info			*/
	/*									*/
	/* Status									*/
	/* 0) Created   May, 1973 by T. H. VanVleck					*/
	/* 1) Modified  July, 1982 by Jim Lippard to only use 2 dir ring brackets		*/
	/* 2) Modified  Oct, 1982 by G. C. Dixon to modernize the code.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  al fixed bin(21),				/* length of arg */
     an fixed bin,
     ap ptr,					/* ptr to argument */
     bchr char (al) unal based (ap),			/* pickup for argument */
     bitc fixed bin (24),
     datstr char (24),
     ec fixed bin (35),				/* error code */
     fdir char (168),
     fent char (32),
     verbosity fixed bin,
     xp ptr;

dcl (addr, index, null, ptr) builtin;

dcl  cleanup condition;

dcl  com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
     date_time_ entry (fixed bin(71), char(*)),
     expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)),
     hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)),
     hcs_$terminate_noname entry (ptr, fixed bin(35)),
     ioa_ entry options (variable),
     list_dir_info_	entry (ptr, fixed bin, char(1));

dcl (error_table_$bad_arg,
     error_table_$badopt) fixed bin(35) ext static,
     prefix char (1) int static options(constant) init("");

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
ER:	   call com_err_ (ec, "list_dir_info", "
Usage:  list_dir_info dir_info_path {-control_arg}
Args:   -long, -lg
        -brief, -bf");
	   return;
	   end;

	call expand_pathname_$add_suffix (bchr, "dir_info", fdir, fent, ec);
	if ec ^= 0 then do;
	   call com_err_ (ec, "list_dir_info", "^a", bchr);
	   return;
	   end;

	verbosity = 1;
	ec = 0;
	do an = 2 by 1 while (ec = 0);
	   call cu_$arg_ptr (an, ap, al, ec);
	   if ec = 0 then do;
	      if bchr = "-long" then verbosity = 2;
	      else if bchr = "-lg" then verbosity = 2;
	      else if bchr = "-brief" then verbosity = 0;
	      else if bchr = "-bf" then verbosity = 0;
	      else do;
	         if index(bchr,"-") = 1 then
		  ec = error_table_$badopt;
	         else
		  ec = error_table_$bad_arg;
	         call com_err_ (ec, "list_dir_info", "^a", bchr);
	         return;
	         end;
	      end;
	   end;

	fptr = null;
	on cleanup call janitor();

	call hcs_$initiate_count (fdir, fent, "", bitc, 0, fptr, ec);
	if fptr = null then do;
	   call com_err_ (ec, "list_dir_info", "Access dir_info segment
(^a^[>^]^a).", fdir, fdir^=">", fent);
	   return;
	   end;

	call date_time_ (fseg.timeof, datstr);
	call ioa_ ("^/Listing of ^a as of ^a", fseg.fpath, datstr);
	xp = addr (fseg.ffirst);

NXTFILE:	call list_dir_info_ (xp, verbosity, prefix);
	call ioa_ ("");
	if seg_rec.fnext then do;
	   xp = ptr (xp, seg_rec.fnext);
	   go to NXTFILE;
	   end;

	call janitor();
	return;

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


janitor:	proc;

	if fptr ^= null then
	   call hcs_$terminate_noname (fptr, ec);

	end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include saved_dir_info;

     end list_dir_info;




		    list_dir_info_.pl1              11/19/82  1510.3rew 11/19/82  0949.3       67698



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


list_dir_info_: proc (ap, am, apfx);

/* LIST_DIR_INFO_ - list directory info record

   THVV */
/* Modified 07/10/82 by Jim Lippard to only print 2 dir ring brackets */

dcl  ap ptr,					/* ptr to dir_info record */
     am fixed bin,					/* mode: 0 = brief, 1 = reg, 2 = long */
     apfx char (1);

dcl  nacl fixed bin,
     vmode fixed bin,
     pfx char (1) init (""),
     lvname char (32),
     xp ptr,
     code fixed bin (35),
    (i, j) fixed bin;

dcl  ioa_ entry options (variable),
     mdc_$find_lvname entry (bit (36), char (*), fixed bin (35)),
     date_time_$fstime entry (bit (36), char (*) aligned);


dcl (substr, binary, fixed) builtin;

%include saved_dir_info;

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

	xp = ap;
	vmode = am;
	pfx = apfx;
	j = binary (seg_rec.brstat.type);		/* Get record type */
	if j = 1 then do;
	     call ioa_ ("^anames:^-^a", pfx, seg_rec.names (1).name);
	     do i = 2 to binary (seg_rec.brstat.nnames);
		call ioa_ ("^a^-^a", pfx, seg_rec.names (i).name);
	     end;
	     call ioa_ ("^atype:^-^-segment", pfx);
	     call ioa_ ("^adate used:^-^a", pfx, datec (seg_rec.brstat.dtu));
	     call ioa_ ("^adate modified:^-^a", pfx, datec (seg_rec.brstat.dtm));
	     call ioa_ ("^adamaged switch:^-^[ON^;OFF^]", pfx, seg_rec.brstat.damaged);
	     if vmode < 1 then return;
	     call ioa_ ("^abranch modified:^-^a", pfx, datec (seg_rec.brstat.dtem));
	     call mdc_$find_lvname (seg_rec.lvid, lvname, code);
	     if code ^= 0 then call ioa_ ("^avolume:^-^-^w", pfx, seg_rec.lvid);
	     else call ioa_ ("^avolume:^-^-^a", pfx, lvname);
	     call ioa_ ("^arecords used:^-^d", pfx, fixed (binary (seg_rec.brstat.records), 35));
	     call ioa_ ("^abit count:^-^d", pfx, fixed (binary (seg_rec.brstat.bitcnt), 35));
	     call ioa_ ("^abit count author:^-^a", pfx, seg_rec.bc_author);
	     call ioa_ ("^amax length:^-^d", pfx, seg_rec.max_lth);
	     call ioa_ ("^asafety switch:^-^[ON^;OFF^]", pfx, seg_rec.ssw);
	     if vmode < 2 then return;
	     if seg_rec.nacls > 0 then do;
		call ioa_ ("^aACL:^-^-^5a ^a", pfx,
		     cmode (seg_rec.acls (1).modes, 1), seg_rec.acls (1).access_name);
		do i = 2 to seg_rec.nacls;
		     call ioa_ ("^a^-^-^5a ^a", pfx,
			cmode (seg_rec.acls (i).modes, 1), seg_rec.acls (i).access_name);
		end;
	     end;
	     call ioa_ ("^adate dumped:^-^a", pfx, datec (seg_rec.brstat.dtd));
	     call ioa_ ("^acurrent length:^-^d", pfx, fixed (binary (seg_rec.brstat.curlen), 35));
	     call ioa_ ("^acopy switch:^-^[ON^;OFF^]", pfx, seg_rec.brstat.copysw);
	     call ioa_ ("^atpd switch:^-^[ON^;OFF^]", pfx, seg_rec.brstat.tpd);
	     call ioa_ ("^aring brackets:^-^d,^d,^d", pfx, fixed (binary (seg_rec.brstat.rbs (0)), 35),
		fixed (binary (seg_rec.brstat.rbs (1)), 35), fixed (binary (seg_rec.brstat.rbs (2)), 35));
	     call ioa_ ("^aunique ID:^-^w", pfx, seg_rec.brstat.uid);
	     call ioa_ ("^aauthor:^-^-^a", pfx, seg_rec.author);
	end;
	else if j = 2 then do;
	     call ioa_ ("^anames:^-^a", pfx, dir_rec.names (1).name);
	     do i = 2 to binary (dir_rec.brstat.nnames);
		call ioa_ ("^a^-^a", pfx, dir_rec.names (i).name);
	     end;
	     call ioa_ ("^atype:^-^-directory", pfx);
	     call ioa_ ("^adate used:^-^a", pfx, datec (dir_rec.brstat.dtu));
	     call ioa_ ("^adate modified:^-^a", pfx, datec (dir_rec.brstat.dtm));
	     call mdc_$find_lvname (dir_rec.slvid, lvname, code);
	     if code ^= 0 then call ioa_ ("^asons volume:^-^w", pfx, dir_rec.slvid);
	     else call ioa_ ("^asons volume:^-^a", pfx, lvname);
	     call ioa_ ("^amaster dir:^-^[YES^;NO^]", pfx, dir_rec.brstat.mdir);
	     call ioa_ ("^adamaged switch:^-^[ON^;OFF^]", pfx, seg_rec.brstat.damaged);
	     if vmode < 1 then return;
	     call ioa_ ("^abranch modified:^-^a", pfx, datec (dir_rec.brstat.dtem));
	     call ioa_ ("^abit count:^-^d", pfx, fixed (binary (dir_rec.brstat.bitcnt), 35));
	     call ioa_ ("^arecords used:^-^d", pfx, fixed (binary (dir_rec.brstat.records), 35));
	     call ioa_ ("^aquota:^-^-^d", pfx, dir_rec.quota);
	     call ioa_ ("^adate dumped:^-^a", pfx, datec (dir_rec.brstat.dtd));
	     call ioa_ ("^acurrent length:^-^d", pfx, fixed (binary (dir_rec.brstat.curlen), 35));
               call ioa_ ("^aring brackets:^-^d,^d", pfx, fixed (binary (dir_rec.brstat.rbs (0)), 35),
                    fixed (binary (dir_rec.brstat.rbs (1)), 35));
	     call ioa_ ("^aunique ID:^-^w", pfx, dir_rec.brstat.uid);
	     call ioa_ ("^aauthor:^-^-^a", pfx, dir_rec.author);
	     call ioa_ ("^abit count author:^-^a", pfx, dir_rec.bc_author);
	     call ioa_ ("^amax length:^-^d", pfx, dir_rec.max_lth);
	     call ioa_ ("^asafety switch:^-^[ON^;OFF^]", pfx, dir_rec.ssw);
	     if vmode < 2 then return;
	     if dir_rec.nacls > 0 then do;
		call ioa_ ("^aACL:^-^-^5a ^a", pfx,
		     cmode (dir_rec.acls (1).modes, 2), dir_rec.acls (1).access_name);
		do i = 2 to dir_rec.nacls;
		     call ioa_ ("^a^-^-^5a ^a", pfx,
			cmode (dir_rec.acls (i).modes, 2), dir_rec.acls (i).access_name);
		end;
	     end;
	     if dir_rec.nisacls > 0 then do;
		call ioa_ ("^ainitial seg acl:^-^5a ^a", pfx,
		     cmode (dir_rec.isacls (1).modes, 1), dir_rec.isacls (1).access_name);
		do i = 2 to dir_rec.nisacls;
		     call ioa_ ("^a^-^-^5a ^a", pfx,
			cmode (dir_rec.isacls (i).modes, 1), dir_rec.isacls (i).access_name);
		end;
	     end;
	     if dir_rec.nidacls > 0 then do;
		call ioa_ ("^ainitial dir acl:^-^5a ^a", pfx,
		     cmode (dir_rec.idacls (1).modes, 2), dir_rec.idacls (1).access_name);
		do i = 2 to dir_rec.nidacls;
		     call ioa_ ("^a^-^-^5a ^a", pfx,
			cmode (dir_rec.idacls (i).modes, 2), dir_rec.idacls (i).access_name);
		end;
	     end;
	end;
	else if j = 0 then do;
	     call ioa_ ("^anames:^-^a", pfx, link_rec.names (1).name);
	     do i = 2 to binary (link_rec.brstat.nnames);
		call ioa_ ("^a^-^a", pfx, link_rec.names (i).name);
	     end;
	     call ioa_ ("^atype:^-^-link", pfx);
	     call ioa_ ("^alinks to:^-^-^a", pfx, link_rec.target);
	     if vmode < 1 then return;
	     call ioa_ ("^adate link modified:^-^a", pfx, datec (link_rec.brstat.dtem));
	     if vmode < 2 then return;
	     call ioa_ ("^alink dumped:^-^a", pfx, datec (link_rec.brstat.dtd));
	end;
	else do;
	     call ioa_ ("^aerror at ^p", pfx, xp);
	end;

	return;

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

datec:	proc (x) returns (char (24) aligned);

dcl  x bit (36);

dcl  datstr char (24) aligned;

	     call date_time_$fstime (x, datstr);
	     return (datstr);

	end datec;

cmode:	proc (x, t) returns (char (5) aligned);

dcl  x bit (36) aligned;
dcl  t fixed bin;

dcl  ans char (5) aligned;

dcl (i, k) fixed bin;
dcl  xmode (2, 5) int static char (1) init ("r", "e", "w", "a", "", "s", "m", "a", "", "");

	     k = 1;
	     ans = "";
	     do i = 1 to 5;
		if substr (x, i, 1) then do;
		     substr (ans, k, 1) = xmode (t, i);
		     k = k + 1;
		end;
	     end;

	     if ans = "" then ans = "null";
	     return (ans);

	end cmode;

     end list_dir_info_;




		    rebuild_dir.pl1                 03/15/89  0839.2r w 03/15/89  0800.8      127503



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


rebuild_dir:
	proc;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* rebuild_dir - rebuild a partially clobbered directory from a dir_info segment.	*/
	/* Comments on missing segments: remakes directories or links.			*/
	/*									*/
	/* Status:								*/
	/*									*/
	/* 0) Created  May, 1973 by T. H. VanVleck					*/
	/* 1) Modified Sept, 1982 by Jim Lippard to to not fault on "rebuild_dir >".		*/
	/* 2) Modified Oct, 1982 by G. C. Dixon - modernize code.				*/
	/* 3) Modified Dec, 1984 by Keith Loepere - dir_quota.
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  ap ptr,					/* ptr to arg */
     al fixed bin (21),				/* length of arg */
     an fixed bin,
     bchr char (al) unal based (ap),			/* pickup for argument */
     bitc fixed bin (24),
     datstr char (24),
     dn char (168),
     dnen char (168),
     ec fixed bin (35),				/* error code */
     en char (32),
     fdir char (168),
     fent char (32),
    (i, j) fixed bin,
     loud bit (1),
     my_userid char (32),
     privmode bit (1),
     rings (3) fixed bin,
     xp ptr,
     verbosity fixed bin init (1);

dcl (addr, binary, fixed, index, null, ptr, unspec) builtin;

dcl (cleanup, linkage_error) condition;

dcl 1 brsbuf aligned,				/* auto storage for main dir branch */
    2 type bit (2) unal,
    2 nnames bit (16) unal,
    2 nrp bit (18) unal,
    2 dtm bit (36) unal,
    2 dtu bit (36) unal,
    2 mode bit (5) unal,
    2 padding bit (13) unal,
    2 records bit (18) unal,
    2 dtd bit (36) unal,
    2 dtem bit (36) unal,
    2 acct bit (36) unal,
    2 curlen bit (12) unal,
    2 bitcnt bit (24) unal,
    2 did bit (4) unal,
    2 mdid bit (4) unal,
    2 copysw bit (1) unal,
    2 pad2 bit (9) unal,
    2 rbs (0:2) bit (6) unal,
    2 uid bit (36) unal;

dcl 1 dir_acl (50) aligned,
    2 access_name char (32),
    2 modes bit (36),
    2 statuscode fixed bin (35);

dcl 1 segment_acl (100) aligned,
    2 access_name char (32),
    2 modes bit (36),
    2 mbz bit (36),
    2 statuscode fixed bin (35);

dcl  com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
     cu_$level_get entry (fixed bin),
     date_time_ entry (fixed bin (71), char (*)),
     expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)),
     expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)),
     get_group_id_$tag_star entry() returns(char(32)),
     hcs_$append_link entry (char(*), char(*), char(*), fixed bin(35)),
     hcs_$chname_file entry (char(*), char(*), char(*), char(*), fixed bin(35)),
     hcs_$create_branch_ entry (char(*), char(*), ptr, fixed bin(35)),
     hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)),
     hcs_$quota_move entry (char(*), char(*), fixed bin(18), fixed bin(35)),
     hcs_$replace_acl entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(35)),
     hcs_$replace_dir_acl entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(35)),
     hcs_$replace_dir_inacl entry (char(*), char(*), ptr, fixed bin, bit(1) aligned, fixed bin(3),
	fixed bin(35)),
     hcs_$replace_inacl entry (char(*), char(*), ptr, fixed bin, bit(1), fixed bin(3), fixed bin(35)),
     hcs_$set_max_length entry (char(*), char(*), fixed bin(19), fixed bin(35)),
     hcs_$set_safety_sw entry (char(*), char(*), bit(1), fixed bin(35)),
     hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)),
     hcs_$terminate_noname entry (ptr, fixed bin(35)),
     hphcs_$quota_set entry (char(*), fixed bin (18), fixed bin (35)),
     hphcs_$set_sons_lvid entry (char (*), char (*), bit (36), fixed bin (35)),
     ioa_ entry options (variable),
     list_dir_info_ entry (ptr, fixed bin, char(1)),
     pathname_ entry (char(*), char(*)) returns(char(168));

dcl (error_table_$action_not_performed,
     error_table_$bad_arg,
     error_table_$badopt,
     error_table_$improper_data_format,
     error_table_$moderr,
     error_table_$noentry,
     error_table_$root,
     error_table_$segnamedup) fixed bin(35) ext static;
dcl  sys_info$default_max_length fixed bin (19) ext static;

%include saved_dir_info;

%include create_branch_info;
dcl 1 cbi like create_branch_info aligned;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
	   call com_err_ (ec, "rebuild_dir", "
Usage: rebuild_dir dir_info_path {-control_args}
Args:  -brief, -bf
       -long, -lg 
       -priv");
	   return;
	   end;
	call expand_pathname_$add_suffix (bchr, "dir_info", fdir, fent, ec);
	if ec ^= 0 then do;
	   call com_err_ (ec, "rebuild_dir", "^a", bchr);
	   return;
	   end;

	call cu_$level_get (rings (1));
	rings (2), rings (3) = rings (1);
	my_userid = get_group_id_$tag_star ();
	loud = "1"b;
	privmode = "0"b;
	ec = 0;
	do an = 2 by 1 while (ec = 0);
	   call cu_$arg_ptr (an, ap, al, ec);
	   if ec = 0 then do;
	      if bchr = "-brief" | bchr = "-bf" then do;
	         verbosity = 0;
	         loud = "0"b;
	         end;
	      else if bchr = "-long" | bchr = "-lg" then do;
	         verbosity = 2;
	         loud = "1"b;
	         end;
	      else if bchr = "-priv" then privmode = "1"b;
	      else do;
	         if index(bchr,"-") = 1 then
		  ec = error_table_$badopt;
	         else
		  ec = error_table_$bad_arg;
	         call com_err_ (ec, "rebuild_dir", "^a", bchr);
	         return;
	         end;
	      end;
	   end;

	fptr = null;
	on cleanup call janitor();

	call hcs_$initiate_count (fdir, fent, "", bitc, 0, fptr, ec);
	if fptr = null then do;
	   call com_err_ (ec, "rebuild_dir", "Accessing dir_info segment
(^a^[>^]^a).", fdir, fdir^=">", fent);
	   return;
	   end;

	if fseg.fpath = ">" then do;
	   call com_err_ (error_table_$root, "rebuild_dir", ">
The root directory cannot be rebuilt.");
	   go to EXIT;
	   end;

	call date_time_ (fseg.timeof, datstr);
	call ioa_ ("
Rebuilding:          ^a
from snapshot taken: ^a", fseg.fpath, datstr);

	xp = addr (fseg.ffirst);
	if dir_rec.type ^= "10"b then do;		/* make sure dir is first */
	   call com_err_ (error_table_$improper_data_format,  "rebuild_dir",
	      "Type of first entry is not directory in saved dir_info segment
(^a^[>^]^a).", fdir, fdir^=">", fent);
	   go to EXIT;
	   end;
	call expand_pathname_ (fseg.fpath, dn, en, ec);
	if ec ^= 0 then do;
	   call com_err_ (ec, "rebuild_dir", "^a
Error in pathname of containing directory saved in dir_info segment
(^a^[>^]^a).", fseg.fpath, fdir, fdir^=">", fent);
	   go to EXIT;
	   end;
	go to CASE(2);

NXTFILE:	j = binary (seg_rec.brstat.type);		/* Get record type */
	if 0 <= j & j <= 2 then;
	else do;
	   call com_err_ (error_table_$improper_data_format, "rebuild_dir",
	      "Error at ^p in saved dir info segment
(^a^[>^]^a).", xp, fdir, fdir^=">", fent);
	   go to EXIT;
	   end;
	go to CASE(j);

CASE(1):	en = seg_rec.names (1).name;			/* SEGMENT */
	call hcs_$status_long (dn, en, 0, addr (brsbuf), null, ec);
	if ec = 0 then
	   if brsbuf.type = "01"b then do;
	      call hcs_$set_safety_sw (dn, en, seg_rec.ssw, ec);
	      if seg_rec.nacls > 0 then do;
	         do i = 1 to seg_rec.nacls;
		  segment_acl (i).access_name = seg_rec.acls (i).access_name;
		  segment_acl (i).modes = seg_rec.acls (i).modes;
		  segment_acl (i).mbz = "0"b;
		  end;
	         call hcs_$replace_acl (dn, en, addr (segment_acl), seg_rec.nacls, "0"b, ec);
	         if ec ^= 0 then
		  call com_err_ (ec, "rebuild_dir", "Cannot replace acl on ^a", en);
	         end;
	      do i = 2 to binary (seg_rec.brstat.nnames);
	         call hcs_$chname_file (dn, en, "", (seg_rec.names (i).name), ec);
	         if ec ^= 0 then
	         if ec ^= error_table_$segnamedup then
		  call com_err_ (ec, "rebuild_dir",
		     "Cannot add name ^a to seg ^a",
		     seg_rec.names (i).name, en);
	         end;
	      if seg_rec.max_lth ^= sys_info$default_max_length
	         then call hcs_$set_max_length (dn, en, seg_rec.max_lth, ec);
	      end;
	   else
	      call com_err_ (error_table_$action_not_performed,
	         "rebuild_dir",
	         "Type mismatch: entry ^a was a segment, now a ^[link^;^;directory^;BAD-TYPE^].",
	         en, binary(brsbuf.type,2,0)+1b);
	else do;
	   call com_err_ (ec, "rebuild_dir", "missing seg ^a", en);
	   if loud then call list_dir_info_ (xp, verbosity, "	");
	   end;
	go to SKIP;

CASE(2):	en = dir_rec.names (1).name;			/* DIRECTORY */
	call hcs_$status_long (dn, en, 0, addr (brsbuf), null, ec);
	if ec = error_table_$noentry then do;
	   if loud then call ioa_ ("Adding directory ^a", en);
	   unspec (cbi) = "0"b;
	   cbi.version = create_branch_version_2;
	   cbi.switches.dir_sw = "1"b;
	   cbi.parent_ac_sw = "1"b;			/* For Now */
	   cbi.mode = "111"b;
	   cbi.userid = my_userid;
	   cbi.bitcnt = fixed (dir_rec.bitcnt, 24);
	   cbi.rings (1) = rings (1);
	   cbi.rings (2) = rings (2);
	   cbi.rings (3) = rings (3);
	   cbi.quota = 0;				/* Set below */
	   cbi.dir_quota = 0;
	   call hcs_$create_branch_ (dn, en, addr (cbi), ec);
	   if ec ^= 0 then do;
	      call com_err_ (ec, "rebuild_dir", "Cannot add directory ^a", en);
	      if dn ^= fseg.fpath then go to EXIT;
	      go to SKIP;
	      end;
	   end;
	else if ec ^= 0 then do;
	   call com_err_ (ec, "rebuild_dir", "Cannot get status for ^a>^a", dn, en);
	   go to SKIP;
	   end;
	else if brsbuf.type ^= "10"b then do;
	   call com_err_ (error_table_$action_not_performed,
	      "rebuild_dir",
	      "Type mismatch: entry ^a was a directory, now a ^[link^;segment^;^;BAD-TYPE^].",
	      en, binary(brsbuf.type,2,0)+1b);
	   go to SKIP;
	   end;
	call hcs_$set_safety_sw (dn, en, dir_rec.ssw, ec);
	do i = 2 to binary (dir_rec.brstat.nnames);
	   call hcs_$chname_file (dn, en, "", (dir_rec.names (i).name), ec);
	   if ec ^= 0 then
	   if ec ^= error_table_$segnamedup then
	      call com_err_ (ec, "rebuild_dir",
	         "Cannot add name ^a to dir ^a", dir_rec.names (i).name, en);
	   end;
	if dir_rec.slvid ^= "0"b then do;
	   if privmode then do;
	      on linkage_error begin;
	         privmode = "0"b;
	         call com_err_ (error_table_$moderr, "rebuild_dir",
		  "Cannot set sons logical volume id on ^a.
This requires access to the hphcs_ gate.", en);
	         go to SKIP_SONS_LVID;
	         end;
	      call hphcs_$set_sons_lvid (dn, en, dir_rec.slvid, ec);
SKIP_SONS_LVID:
	      revert linkage_error;
	      end;
	   end;
	ec = 0;
	if dir_rec.quota ^= 0 then do;
	   if privmode then do;
	      dnen = pathname_ (dn, en);
	      on linkage_error begin;
	         privmode = "0"b;
	         call com_err_ (error_table_$moderr, "rebuild_dir",
"Cannot set quota on ^a. This requires access to the hphcs_ gate.", en);
	         go to SKIP_SET_QUOTA;
	         end;
	      call hphcs_$quota_set (dnen, dir_rec.quota, ec);
SKIP_SET_QUOTA: revert linkage_error;
	      end;
	   else call hcs_$quota_move (dn, en, dir_rec.quota, ec);
	   if ec ^= 0 then call com_err_ (ec, "rebuild_dir", "Unable to set quota ^d on ^a", dir_rec.quota, en);
	   end;

	if dir_rec.nacls > 0 then do;			/* Problem here: might remove own access on first item */
	   do i = 1 to dir_rec.nacls;
	      dir_acl (i).access_name = dir_rec.acls (i).access_name;
	      dir_acl (i).modes = dir_rec.acls (i).modes;
	      end;
	   call hcs_$replace_dir_acl (dn, en, addr (dir_acl), dir_rec.nacls, "0"b, ec);
	   if ec ^= 0 then call com_err_ (ec, "rebuild_dir", "Cannot replace acl on ^a", en);
	   end;
	if dir_rec.nisacls > 0 then do;
	   do i = 1 to dir_rec.nisacls;
	      segment_acl (i).access_name = dir_rec.isacls (i).access_name;
	      segment_acl (i).modes = dir_rec.isacls (i).modes;
	      segment_acl (i).mbz = "0"b;
	      end;
	   call hcs_$replace_inacl (dn, en, addr (segment_acl), dir_rec.nisacls, "0"b, 4, ec);
	   if ec ^= 0 then call com_err_ (ec, "rebuild_dir", "Cannot replace seg iacl on ^a", en);
	   end;
	if dir_rec.nidacls > 0 then do;
	   do i = 1 to dir_rec.nidacls;
	      dir_acl (i).access_name = dir_rec.idacls (i).access_name;
	      dir_acl (i).modes = dir_rec.idacls (i).modes;
	      end;
	   call hcs_$replace_dir_inacl (dn, en, addr (dir_acl), dir_rec.nidacls, "0"b, 4, ec);
	   if ec ^= 0 then call com_err_ (ec, "rebuild_dir", "Cannot replace dir inacl on ^a", en);
	   end;
	go to SKIP;


CASE(0):	en = link_rec.names (1).name;			/* LINK */
	call hcs_$status_long (dn, en, 0, addr (brsbuf), null, ec);
	if ec = 0 then if brsbuf.type = "00"b then go to LINK_MERGE;
	if loud then call ioa_ ("Adding link ^a", en);
	call hcs_$append_link (dn, en, (link_rec.target), ec);
	if ec ^= 0 then do;
	   call com_err_ (ec, "rebuild_dir", "Cannot append link ^a", en);
	   go to SKIP;
	   end;
LINK_MERGE:
	do i = 2 to binary (link_rec.brstat.nnames);
	   call hcs_$chname_file (dn, en, "", (link_rec.names (i).name), ec);
	   if ec ^= 0 then
	   if ec ^= error_table_$segnamedup then
	      call com_err_ (ec, "rebuild_dir",
	         "Cannot add name ^a to link ^a", 
	         link_rec.names (i).name, en);
	   end;
	go to SKIP;

SKIP:	dn = fseg.fpath;
	if seg_rec.fnext then do;
	     xp = ptr (xp, seg_rec.fnext);
	     go to NXTFILE;
	end;

	call ioa_ ("Rebuilding complete: ^a", fseg.fpath);
EXIT:	call janitor();
	return;

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


janitor:	proc;

	if fptr ^= null then
	     call hcs_$terminate_noname (fptr, ec);

	end janitor;

     end rebuild_dir;




		    save_dir_info.pl1               10/22/86  1539.4rew 10/22/86  1536.6      128151



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




/****^  HISTORY COMMENTS:
  1) change(86-10-20,TLNguyen), approve(86-10-22,MCR7559),
     audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1196):
     Fix bug which occurs for directories off the root.
                                                   END HISTORY COMMENTS */


save_dir_info:
	proc;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name: save_dir_info							*/
	/*									*/
	/* Copy directory info into a segment for later comparison/checking			*/
	/*									*/
	/* Status:								*/
	/* 0) Created:   May, 1973 by THVV						*/
	/* 1) Modified:  Sept, 1982 by Jim Lippard - fix bugs				*/
	/*	       a) properly store only 2 dir ring brackets, instead of 3		*/
	/*	       b) delete .dir_info seg if error occurs listing the directory		*/
	/*	       c) print full pathname of directory on which error occurs		*/
	/* 2) Modified:  August 1983 by Jim Lippard to chase links			          */
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  aclp ptr,
     al fixed bin(21),				/* length of arg */
     ap ptr,					/* ptr to argument */
     areap ptr,					/* ptr to listener area, for star */
     bitc fixed bin (24),
     branch_type fixed bin (2),
     d35 fixed bin (35), d1 fixed bin (1),		/* dummies */
     db36 bit(36) aligned,
     dirname char (168),
     ec fixed bin (35),				/* error code */
     en char (32),
     ep ptr,
     fdir char (168),
     fent char (32),
    (i, j, k) fixed bin,
     LINK fixed bin (2) internal static options (constant) init (0),
     ll fixed bin,					/* number of links */
     nacl fixed bin,
     nargs fixed bin,
     np ptr,
     nptr ptr,
     p ptr,					/* ptr to entry returned by star */
     ring fixed bin (3) init (4),
     t fixed bin,					/* number of branches */
     target_dn char (168),
     target_en char (32),
     tdir char (168),
    (xp, xxp, oldxp, next_xp) ptr,
     why char (168) aligned init ("");

dcl (addr, bit, clock, fixed, null, ptr, rel) builtin;

dcl  cleanup condition;

dcl (error_table_$incorrect_access,
     error_table_$root) fixed bin(35) ext static;

dcl  arg char(al) based(ap);

dcl 1 brsbuf aligned,				/* auto storage for main dir branch */
    2 type bit (2) unal,
    2 nnames bit (16) unal,
    2 nrp bit (18) unal,
    2 dtm bit (36) unal,
    2 dtu bit (36) unal,
    2 mode bit (5) unal,
    2 padding bit (13) unal,
    2 records bit (18) unal,
    2 dtd bit (36) unal,
    2 dtem bit (36) unal,
    2 acct bit (36) unal,
    2 curlen bit (12) unal,
    2 bitcnt bit (24) unal,
    2 did bit (4) unal,
    2 mdid bit (4) unal,
    2 copysw bit (1) unal,
    2 pad2 bit (9) unal,
    2 rbs (0:2) bit (6) unal,
    2 uid bit (36) unal;

dcl 1 branches based aligned,				/* structure returned by star for branch */
    2 type bit (2) unal,				/* type of branch */
    2 nname bit (16) unal,				/* number of names */
    2 nindex bit (18) unal,				/* index in name area */
    2 dtm bit (36) unal,				/* date & time modified */
    2 dtu bit (36) unal,				/* ... used */
    2 mode bit (5) unal,				/* mode w.r.t. me */
    2 pad bit (13) unal,
    2 records bit (18) unal;				/* lth */

dcl  names (100) char (32) aligned based;		/* names from star */

dcl  entries (100) bit (144) aligned based;		/* entry structure from star */

dcl  linkpath char (j) based (np);

dcl 1 segment_acl (nacl) based (aclp) aligned,
    2 access_name char (32),
    2 modes bit (36),
    2 mbz bit (36),
    2 statuscode fixed bin (35);

dcl 1 dir_acl (nacl) based (aclp) aligned,
    2 access_name char (32),
    2 modes bit (36),
    2 statuscode fixed bin (35);

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

dcl  absolute_pathname_ entry (char(*), char(*), fixed bin(35)),
     com_err_ entry options (variable),
     cu_$arg_count entry (fixed bin, fixed bin(35)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
     delete_$ptr entry (ptr, bit(6), char(*), fixed bin(35)),
     expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)),
     expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)),
     get_system_free_area_ entry (ptr),
     get_wdir_ entry () returns (char (168));

dcl  hcs_$get_author entry (char(*), char(*), fixed bin(1), 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), fixed bin(35));
dcl  hcs_$list_acl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35));
dcl  hcs_$list_dir_acl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35));
dcl  hcs_$list_dir_inacl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(3), fixed bin(35));
dcl  hcs_$list_inacl entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(3), fixed bin(35));
dcl  hcs_$make_seg entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35));
dcl  hcs_$quota_get entry (char(*), fixed bin (18), fixed bin(35), bit(36) aligned, fixed bin, fixed bin(1),
	fixed bin, fixed bin(35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$star_list_ entry (char(*), char(*), fixed bin(3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin(35));
dcl  hcs_$status_long 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  hcs_$terminate_noname entry (ptr, fixed bin(35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin(19), fixed bin(35));

dcl  pathname_ entry (char(*), char(*)) returns(char(168));

%include saved_dir_info;

%include access_mode_values;

/* ======================================================= */

	call cu_$arg_count (nargs, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, "save_dir_info");
	     return;
	     end;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "save_dir_info", "^a", why);
	     return;
	     end;
	call absolute_pathname_ (arg, tdir, ec);
	call expand_pathname_ (arg, dirname, en, ec);
	if ec ^= 0 then go to er;
	call hcs_$status_minf (dirname, en, 0, branch_type, 0, ec);
          if ec ^= 0 & ec ^= error_table_$root then do;
	     why = pathname_ (dirname, en);
	     go to er;
	     end;
	if branch_type = LINK then do;                          /* a link to chase */
	     call hcs_$get_link_target (dirname, en, target_dn, target_en, ec);
	     if ec ^= 0 then do;
		why = pathname_ (dirname, en);
		go to er;
		end;
	     dirname = target_dn;
	     en = target_en;
	 end;

	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then do;
	     if en = "" then
		fdir = pathname_ (get_wdir_(), "root");
	     else fdir = pathname_ (get_wdir_(), en);
	     end;
	else fdir = arg;
	call expand_pathname_$add_suffix (fdir, "dir_info", fdir, fent, ec);
	if ec ^= 0 then do;
	     why = fdir;
	     go to er;
	     end;

	fptr = null;
	ep = null;
	nptr = null;
	on cleanup call janitor();
	
          why = fent;
	call hcs_$make_seg (fdir, fent, "", 1011b, fptr, ec);
	if fptr = null then go to error_exit;
	call hcs_$truncate_seg (fptr, 0, ec);
	if ec ^= 0 then go to error_exit;
	fseg.fpath = tdir;
	fseg.timeof = clock();
	xp = addr (fseg.ffirst);
	oldxp = null;

	call get_system_free_area_ (areap);		/* obtain area */

	p = addr (brsbuf);
	why = tdir;
	if en = "" then do;				/* Need special code for the root. */
	     dir_rec.type = "10"b;
	     dir_rec.bc_author, dir_rec.author = "Initializer.SysDaemon.z";
	     dir_rec.max_lth = 0;
	     dir_rec.ssw = "0"b;
	     call hcs_$quota_get (tdir, dir_rec.quota, d35, db36, j, d1, j, ec);
	     dir_rec.nacls = 0;
	     dir_rec.nisacls = 0;
	     dir_rec.nidacls = 0;
	     dir_rec.n_names = 1;
	     tp = addr (dir_rec.names);
	     tp -> names (1) = ">";
	     next_xp = addr (dir_rec.end_dir_rec);
	     dir_rec.fnext = rel (next_xp);
	     oldxp = xp;
	     xp = next_xp;
	     end;
	else do;
	     call hcs_$status_long (dirname, en, 0, p, areap, ec);
	     if ec ^= 0 then go to error_exit;
	     if brsbuf.mode & bit(S_ACCESS_BIN) then;	/* complain now if user has no s access to dir	*/
	     else do;				/* being saved.				*/
	        ec = error_table_$incorrect_access;
	        go to error_exit;
	        end;
	     k = 1;
	     nptr = ptr (areap, brsbuf.nrp);
	     call sdir;
	     if ec ^= 0 then go to error_exit;
	     free nptr -> names in (dummy_area);
	     end;

	dirname = tdir;
	call hcs_$star_list_ (dirname, "**", 3, areap, t, ll, ep, nptr, ec);
	if ec = 0 then do;
	     do i = 1 to t + ll;
		p = addr (ep -> entries (i));
		k = fixed (p -> branches.nindex, 18);
		en = nptr -> names (k);
		j = fixed (p -> branches.type);
		if j = 1 then call sseg;
		else if j = 0 then call slink;
		else if j = 2 then call sdir;
		if ec ^= 0 then 
		     call com_err_ (ec, "save_dir_info", "^a^[>^]^a", dirname, (dirname ^= ">"), en);
		fseg.nents = fseg.nents + 1;
		end;
	     free ep -> entries in (dummy_area);	/* free up area */
	     free nptr -> names in (dummy_area);	/* ... */
	     end;
	if oldxp ^= null then oldxp -> seg_rec.fnext = "0"b;
	fseg.freep = fixed (rel (next_xp), 18);
	bitc = 36 * fseg.freep;
	call hcs_$set_bc_seg (fptr, bitc, ec);
	call hcs_$terminate_noname (fptr, ec);

	return;

error_exit:
	call com_err_ (ec, "save_dir_info", why);
	call janitor();
	return;

/* ------------------------------------------------------  */

janitor:	proc;

	if ep ^= null then free ep -> entries in (dummy_area);
	if nptr ^= null then free nptr -> names in (dummy_area);
	if fptr ^= null then
	   call delete_$ptr (fptr, "000100"b, "save_dir_info", ec);

	end janitor;



sseg:	proc;

	     ec = 0;
	     xxp = addr (seg_rec.brstat);
	     call hcs_$status_long (dirname, en, 0, xxp, null, ec);
	     if ec ^= 0 then return;
	     call hcs_$get_bc_author (dirname, en, seg_rec.bc_author, ec);
	     call hcs_$get_author (dirname, en, 0, seg_rec.author, ec);
	     call hcs_$get_max_length (dirname, en, seg_rec.max_lth, ec);
	     call hcs_$get_safety_sw (dirname, en, seg_rec.ssw, ec);
	     call hcs_$list_acl (dirname, en, areap, aclp, null, nacl, ec);
	     seg_rec.nacls = nacl;
	     tp = addr (seg_rec.acls);
	     do j = 1 to nacl;
		aclval.access_name (j) = segment_acl.access_name (j);
		aclval.modes (j) = segment_acl.modes (j);
		end;
	     if nacl > 0 then free aclp -> segment_acl in (dummy_area);
	     seg_rec.n_names = fixed (p -> branches.nname, 16);
	     tp = addr (seg_rec.names);
	     do j = 1 to seg_rec.n_names;
		tp -> names (j) = nptr -> names (j+k-1);
		end;
	     next_xp = addr (seg_rec.end_seg_rec);
	     seg_rec.fnext = rel (next_xp);
	     oldxp = xp;
	     xp = next_xp;

	end sseg;

sdir:	proc;

dcl  tdir char (168);

	     ec = 0;
	     xxp = addr (dir_rec.brstat);
	     call hcs_$status_long (dirname, en, 0, xxp, null, ec);
	     if ec ^= 0 then return;
	     dir_rec.pad3 = "07"b3;
	     call hcs_$get_safety_sw (dirname, en, dir_rec.ssw, ec);
/* fixed bug for TR#20502 */
               tdir = pathname_ (dirname, en);
/* ending of bug fixes */
	     call hcs_$quota_get (tdir, dir_rec.quota, d35, db36, j, d1, j, ec);
	     if ec ^= 0 then call com_err_ (ec, "save_dir_info", "Cannot get quota of ^a", en);
	     call hcs_$get_bc_author (dirname, en, dir_rec.bc_author, ec);
	     call hcs_$get_author (dirname, en, 0, dir_rec.author, ec);
	     call hcs_$list_dir_acl (dirname, en, areap, aclp, null, nacl, ec);
	     dir_rec.nacls = nacl;
	     tp = addr (dir_rec.acls);
	     do j = 1 to nacl;
		aclval (j).access_name = dir_acl (j).access_name;
		aclval (j).modes = dir_acl (j).modes;
		end;
	     if nacl > 0 then free aclp -> dir_acl in (dummy_area);
	     call hcs_$list_inacl (dirname, en, areap, aclp, null, nacl, ring, ec);
	     if ec ^= 0 then do;
		call com_err_ (ec, "save_dir_info", "Cannot list inacl of ^a", en);
		go to gnam;
		end;
	     dir_rec.nisacls = nacl;
	     tp = addr (dir_rec.isacls);
	     do j = 1 to nacl;
		aclval (j).access_name = segment_acl.access_name (j);
		aclval (j).modes = segment_acl.modes (j);
		end;
	     if nacl > 0 then free aclp -> dir_acl in (dummy_area);
	     call hcs_$list_dir_inacl (dirname, en, areap, aclp, null, nacl, ring, ec);
	     dir_rec.nidacls = nacl;
	     tp = addr (dir_rec.idacls);
	     do j = 1 to nacl;
		aclval (j).access_name = dir_acl.access_name (j);
		aclval (j).modes = dir_acl.modes (j);
		end;
	     if nacl > 0 then free aclp -> dir_acl in (dummy_area);

gnam:	     dir_rec.n_names = fixed (p -> branches.nname, 16);
	     tp = addr (dir_rec.names);
	     do j = 1 to dir_rec.n_names;
		tp -> names (j) = nptr -> names (j+k-1);
		end;
	     next_xp = addr (dir_rec.end_dir_rec);
	     dir_rec.fnext = rel (next_xp);
	     oldxp = xp;
	     xp = next_xp;

	end sdir;

slink:	proc;

	     link_rec.n_names = fixed (p -> branches.nname, 16);
	     tp = addr (link_rec.names);
	     do j = 1 to link_rec.n_names;
		tp -> names (j) = nptr -> names (j+k-1);
		end;
	     ec = 0;
	     xxp = addr (link_rec.brstat);
	     call hcs_$status_long (dirname, en, 0, xxp, areap, ec);
	     if ec ^= 0 then return;
	     j = fixed (link_rec.brstat.pnl, 18);
	     np = ptr (areap, link_rec.brstat.pnrp);
	     link_rec.target = linkpath;
	     np = ptr (areap, link_rec.nrp);
	     free np -> names in (dummy_area);
	     next_xp = addr (link_rec.end_link_rec);
	     link_rec.fnext = rel (next_xp);
	     oldxp = xp;
	     xp = next_xp;

	end slink;

     end save_dir_info;





		    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