contents.pl1                    12/09/86  1518.7rew 12/09/86  1516.5      171432



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

/* format: ^inddcls,^indattr,indnoniterend,^indnoniterdo,indend,tree,^case,insnl,comcol61,dclind5,declareind5,delnl */


/****^  HISTORY COMMENTS:
  1) change(86-01-03,Spitzer), approve(86-01-03,MCR7321),
     audit(86-01-06,Blair), install(86-01-07,MR12.0-1005):
     Add -from/-to and -match/-exclude control arguments.
  2) change(86-12-01,GWMay), approve(86-12-01,MCR7575),
     audit(86-12-04,Lippard), install(86-12-09,MR12.0-1238):
     added -newline,-nl,-no_newline,-nnl and -requote_line, -rql control
     arguments.
                                                   END HISTORY COMMENTS */


contents:
     proc () options (variable);

/* active function to return contents of seg as big string. */
/* rewritten to accept archive components pathnames 1/29/82 LAB */

/* Argument processing */
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = error_table_$not_act_fnc
	then do;
	     af_sw = "0"b;
	     complain = com_err_;
	     end;
	else do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	     end;

	path = "";

	have_selection_args = "0"b;
	loop = 1;
	to_line, from_line = UNUSED;
	Schange_NL_to_SP = "1"b;
	Schange_NL_to_QUOTE = "0"b;

	from_stringp, to_stringp, seg_ptr, match_listp, exclude_listp, system_free_area_ptr = null ();
	on cleanup call cleaner;

	do while (loop <= arg_count);
	     call cu_$arg_ptr (loop, arg_ptr, arg_len, (0));
	     if /* case */ index (arg, "-") = 1
	     then if arg = "-newline" | arg = "-nl"
		then do;
		     Schange_NL_to_SP = "0"b;
		     Schange_NL_to_QUOTE = "0"b;
		     end;

		else if arg = "-no_newline" | arg = "-nnl"
		then do;
		     Schange_NL_to_SP = "1"b;
		     Schange_NL_to_QUOTE = "0"b;
		     end;

		else if arg = "-requote_line" | arg = "-rql"
		then do;
		     Schange_NL_to_SP = "0"b;
		     Schange_NL_to_QUOTE = "1"b;
		     end;

		else if arg = "-fm" | arg = "-from"
		then if from_line ^= UNUSED | from_stringp ^= null
		     then do;
inconsistent:
			call complain (error_table_$inconsistent, myname, "Only one line range is allowed. ^a", arg);
			goto return_to_caller;
			end;
		     else call get_next_arg ("-from", from_line, from_stringp, from_stringl, from_is_regexp);
		else if arg = "-to"
		then if to_line ^= UNUSED | to_stringp ^= null
		     then goto inconsistent;
		     else call get_next_arg ("-to", to_line, to_stringp, to_stringl, to_is_regexp);
		else if arg = "-match"
		then do;
		     call get_char_arg ("-match", char_arg_ptr, char_arg_len);
		     call add_to_match_exclude_list ("1"b, char_arg_ptr, char_arg_len);
		     end;
		else if arg = "-ex" | arg = "-exclude"
		then do;
		     call get_char_arg ("-exclude", char_arg_ptr, char_arg_len);
		     call add_to_match_exclude_list ("0"b, char_arg_ptr, char_arg_len);
		     end;
		else do;
		     call complain (error_table_$badopt, myname, "^a", arg);
		     goto return_to_caller;
		     end;
	     else if path = ""
	     then path = arg;
	     else do;
		call complain (0, myname, "Pathname already supplied. ^a", arg);
		goto return_to_caller;
		end;
	     loop = loop + 1;
	     end;					/* do while */

	if path = ""
	then do;
	     if af_sw
	     then call active_fnc_err_$suppress_name (0, myname, "Usage:  [contents path {-control_args}]");
	     else call com_err_$suppress_name (0, myname, "Usage:  contents path {-control_args}");
	     goto return_to_caller;
	     end;

/* convert to pathname and/or component name */

	call cu_$arg_ptr (1, arg_ptr, arg_len, 0);
	call expand_pathname_$component (path, dn, en, comp_nm, code);
	if code ^= 0
	then do;
	     call complain (code, myname, "^a", path);
	     return;
	     end;

/* initiate seg */

	call initiate_file_$component (dn, en, comp_nm, R_ACCESS, seg_ptr, bit_count, code);
	if seg_ptr = null
	then do;
	     call complain (code, myname, "^a", pathname_$component (dn, en, comp_nm));
	     return;
	     end;

	seg_len = divide ((bit_count + 8), 9, 21, 0);
	if Schange_NL_to_SP
	then seg_len = length (rtrim (seg, NL));	/* strip trailing newlines */

	if have_selection_args
	then call process_selection;
	else call return_entire_segment;

return_to_caller:
	call cleaner;
	return;
%page;
return_entire_segment:
     proc;

	seg_next_line_ptr = seg_ptr;
	seg_next_line_len = seg_len;
	seg_pos = 0;
	if Schange_NL_to_QUOTE | Schange_NL_to_SP
	then do;
	     do while (seg_pos < seg_len);
		move_len = index (seg_next_line, NL) - length (NL);

		if move_len < 0
		then /* takes care of segs with no NL at the end */
		     move_len = seg_len - seg_pos;

		if Schange_NL_to_QUOTE
		then call put_next_line (requote_string_ (substr (seg_next_line, 1, move_len)));
		else /* Schange_NL_to_SP */
		     call put_next_line (substr (seg_next_line, 1, move_len));

		seg_pos = seg_pos + move_len + length (NL);
		seg_next_line_ptr = addcharno (seg_ptr, seg_pos);
		end;
	     end;
	else call put_next_line ((seg));

	if ^af_sw
	then call iox_$put_chars (iox_$user_output, addr (NL), 1, 0);

	return;
     end return_entire_segment;
%page;
process_selection:
     proc;

dcl  found_a_match bit (1) aligned;
dcl  found_start bit (1) aligned;
dcl  line char (linel) based (linep);
dcl  linecount fixed bin (21);
dcl  linel fixed bin (21);
dcl  linep ptr;
dcl  nlpos fixed bin (21);
dcl  printed_something bit (1) aligned;
dcl  regexp_string char (regexp_stringl) based (regexp_stringp);
dcl  regexp_stringl fixed bin (21);
dcl  regexp_stringp ptr;
dcl  rest_of_segment char (rest_of_segmentl) based (rest_of_segmentp);
dcl  rest_of_segmentl fixed bin (21);
dcl  rest_of_segmentp ptr;

	linecount = 0;
	printed_something = "0"b;
	rest_of_segmentp = seg_ptr;
	rest_of_segmentl = seg_len;

	if (from_stringp = null) & (from_line = UNUSED)
	then found_start = "1"b;			/* -from not specified, start from the beginning */
	else found_start = "0"b;

	if af_sw
	then return_arg = "";

	do while (rest_of_segmentl > 0);
	     linep = rest_of_segmentp;
	     nlpos = index (rest_of_segment, NL);
	     if nlpos = 0
	     then do;
		linel = rest_of_segmentl;
		nlpos = rest_of_segmentl + 1;
		end;
	     else if Schange_NL_to_SP | Schange_NL_to_QUOTE
		then linel = nlpos - 1;
		else linel = nlpos;

	     linecount = linecount + 1;

	     if linel = 0
	     then goto skip_line;			/* blank line */

/* Test to see if "-to NUMBER" or "-from NUMBER" was given. */
	     if from_line ^= UNUSED
	     then if linecount < from_line
		then goto skip_line;		/* not to the starting place yet */
	     if to_line ^= UNUSED
	     then if linecount > to_line
		then goto selection_done;		/* done with the entire segment */

/* Test to see if "-from STRING" was given. STRING may be a regular expression. */
	     if from_stringp ^= null
	     then if ^found_start
		then if from_is_regexp
		     then if search (from_stringp, from_stringl, linep, linel)
			then do;
			     found_start = "1"b;
			     goto test_match_excludes;
			     end;
			else goto skip_line;
		     else goto skip_line;

/* Test to see if "-to STRING" was given. STRING may be a regular expression. */
	     if to_stringp ^= null
	     then if to_is_regexp
		then if search (to_stringp, to_stringl, linep, linel)
		     then nlpos = rest_of_segmentl;	/* process this line, then stop */
		     else ;			/* keep on truckin' */

/* Look at match and exclude strings now. Do the match strings first */

test_match_excludes:
	     if match_listp ^= null
	     then do;
		found_a_match = "0"b;
		do loop = 1 to match_list.count while (^found_a_match);
		     if match_list.regexp (loop)
		     then found_a_match =
			     search (match_list.stringp (loop), match_list.stringlen (loop), linep, linel);
		     else do;
			regexp_stringp = match_list.stringp (loop);
			regexp_stringl = match_list.stringlen (loop);
			found_a_match = (index (line, regexp_string) ^= 0);
			end;
		     end;				/* do loop */
		if ^found_a_match
		then goto skip_line;		/* no match strings were found */
		end;

	     if exclude_listp ^= null
	     then do;
		found_a_match = "0"b;
		do loop = 1 to exclude_list.count while (^found_a_match);
		     if exclude_list.regexp (loop)
		     then found_a_match =
			     search (exclude_list.stringp (loop), exclude_list.stringlen (loop), linep, linel);
		     else do;
			regexp_stringp = exclude_list.stringp (loop);
			regexp_stringl = exclude_list.stringlen (loop);
			found_a_match = (index (line, regexp_string) ^= 0);
			end;
		     end;				/* do loop */
		if found_a_match
		then goto skip_line;		/* at least 1 exclude string matched */
		end;

	     if Schange_NL_to_QUOTE
	     then call put_next_line (requote_string_ ((line)));
	     else call put_next_line (line);

	     printed_something = "1"b;

skip_line:
	     rest_of_segmentl = rest_of_segmentl - nlpos;
	     rest_of_segmentp = addcharno (rest_of_segmentp, nlpos);
	     end;					/* do while */

selection_done:
	if printed_something
	then if ^af_sw
	     then call iox_$put_chars (iox_$user_output, addr (NL), 1, (0));
	     else ;				/* do nothing */
	else if from_line ^= UNUSED & linecount > from_line
	     then call complain (0, myname, "Line ^d not found.", from_line);
	     else if from_stringp ^= null
		then call complain (0, myname, "^[/^a/^;^a^] not matched.", from_is_regexp, from_string);
		else call complain (0, myname, "No lines selected.");

	return;

     end process_selection;
%page;

put_next_line:
     proc (next_line);

dcl  next_line char (*);

/* If we get here, the line is eligible to be printed/returned */

	if af_sw
	then do;

	     if length (return_arg) + length (next_line) + 1 > return_len
	     then do;
		call complain (0, myname, "Return string of ^d characters is too long.",
		     length (return_arg) + length (next_line) + 1);
		return;
		end;

	     else do;
		if Schange_NL_to_SP | Schange_NL_to_QUOTE
		then if return_arg ^= ""
		     then return_arg = return_arg || SP;

		return_arg = return_arg || next_line;
		end;
	     end;
	else do;
	     call iox_$put_chars (iox_$user_output, addr (next_line), length (next_line), (0));

	     if Schange_NL_to_QUOTE | Schange_NL_to_SP
	     then call iox_$put_chars (iox_$user_output, addr (SPACE), 1, (0));
	     end;

	return;
     end put_next_line;
%page;
check_for_regexp:
     proc (l, p, regexp);

dcl  l fixed bin (21) parameter;
dcl  p ptr parameter;
dcl  regexp bit (1) parameter;
dcl  string char (l) based (p);

	if l > 2
	then if (substr (string, 1, 1) = "/") & (substr (string, l, 1) = "/")
	     then do;
		p = addcharno (p, 1);
		l = l - 2;
		regexp = "1"b;
		end;
	     else regexp = "0"b;
	else regexp = "0"b;

	return;
     end check_for_regexp;

search:
     proc (regexpp, regexpl, stringp, stringl) returns (bit (1) aligned);

dcl  error_table_$nomatch fixed bin (35) ext static;
dcl  regexp char (regexpl) based (regexpp);
dcl  regexpl fixed bin (21) parameter;
dcl  regexpp ptr parameter;
dcl  stringl fixed bin (21) parameter;
dcl  stringp ptr parameter;

	call search_file_$silent (regexpp, 1, regexpl, stringp, 1, stringl, (0), (0), code);
	if code = 0
	then return ("1"b);
	else if code = error_table_$nomatch
	     then ;				/* not found */
	     else if code ^= 0
		then do;
		     if code = 2
		     then call complain (0, myname, "Illegal regexp: /^a/", regexp);
		     else call complain (code, myname, "Searching for /^a/", regexp);
		     goto return_to_caller;
		     end;

	return ("0"b);
     end search;

cleaner:
     proc;

	if seg_ptr ^= null
	then call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, 0);
	if match_listp ^= null
	then free match_list in (system_free_area);
	if exclude_listp ^= null
	then free exclude_list in (system_free_area);

	return;
     end cleaner;
%page;
get_next_arg:
     proc (previous_control_arg, number, p, l, regexp);

dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  ent bit (1) aligned;
dcl  l fixed bin (21) parameter;
dcl  number fixed bin (21) parameter;
dcl  p ptr parameter;
dcl  previous_control_arg char (*) parameter;
dcl  regexp bit (1) parameter;

	ent = "1"b;
	goto next_arg_common;

get_char_arg:
     entry (previous_control_arg, p, l);

	ent = "0"b;
	goto next_arg_common;

next_arg_common:
	if loop = arg_count
	then do;
	     call complain (error_table_$noarg, myname, "Following ^a.", previous_control_arg);
	     goto return_to_caller;
	     end;

	loop = loop + 1;
	call cu_$arg_ptr (loop, argp, argl, (0));
	if index (arg, "-") = 1
	then do;
	     call complain (0, myname, "Missing argument following ^a.", previous_control_arg);
	     goto return_to_caller;
	     end;

	if ent
	then do;
	     number = cv_dec_check_ (arg, code);
	     if code = 0
	     then do;
		p = null;
		l = argl;
		end;
	     else do;
		p = argp;
		l = argl;
		call check_for_regexp (l, p, regexp);
		if regexp
		then number = UNUSED;
		else do;
		     call complain (0, myname, "Non-numeric argument ""^a"" following ^a.", arg, previous_control_arg)
			;
		     goto return_to_caller;
		     end;
		end;
	     end;
	else do;
	     number = UNUSED;
	     p = argp;
	     l = argl;
	     end;

	have_selection_args = "1"b;
	return;
     end get_next_arg;
%page;
add_to_match_exclude_list:
     proc (type, argp, argl);

dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21) parameter;
dcl  argp ptr parameter;
dcl  i fixed bin;
dcl  listp ptr;
dcl  type bit (1) aligned parameter;

	if system_free_area_ptr = null
	then system_free_area_ptr = get_system_free_area_ ();
	if type
	then do;
	     if match_listp = null
	     then do;
		match_count = arg_count - loop + 1;
		allocate match_list in (system_free_area) set (match_listp);
		match_list.count = 0;
		end;
	     listp = match_listp;
	     end;
	else do;
	     if exclude_listp = null
	     then do;
		exclude_count = arg_count - loop + 1;
		allocate exclude_list in (system_free_area) set (exclude_listp);
		exclude_list.count = 0;
		end;
	     listp = exclude_listp;
	     end;

	i, listp -> match_list.count = listp -> match_list.count + 1;
	if argl > 1
	then if (substr (arg, 1, 1) = "/") & (substr (arg, argl, 1) = "/")
	     then do;
		listp -> match_list.flags.regexp (i) = "1"b;
		listp -> match_list.stringlen (i) = argl - 2;
		listp -> match_list.stringp (i) = addcharno (argp, 1);
		end;
	     else do;
have_match_exclude_string:
		listp -> match_list.flags.regexp (i) = "0"b;
		listp -> match_list.stringlen (i) = argl;
		listp -> match_list.stringp (i) = argp;
		end;
	else goto have_match_exclude_string;

	return;
     end add_to_match_exclude_list;
%page;
%include terminate_file;
%include access_mode_values;
%page;
dcl  1 exclude_list based (exclude_listp),
       2 count fixed bin,
       2 string (exclude_count refer (exclude_list.count)),
         3 flags aligned,
	 4 regexp bit (1) unaligned,			/* ON = string is a regexp */
	 4 pad bit (35),
         3 stringlen fixed bin (21),			/* length of string */
         3 stringp ptr;				/* pointer to string. If regexp, string is without slashes */

dcl  1 match_list based (match_listp),
       2 count fixed bin,
       2 string (match_count refer (match_list.count)),
         3 flags aligned,
	 4 regexp bit (1) unaligned,			/* ON = string is a regexp */
	 4 pad bit (35),
         3 stringlen fixed bin (21),			/* length of string */
         3 stringp ptr;				/* pointer to string. If regexp, string is without slashes */

dcl  Schange_NL_to_QUOTE bit (1) aligned;
dcl  Schange_NL_to_SP bit (1) aligned;
dcl  (addcharno, addr, divide, index, length, null, rtrim, substr) builtin;
dcl  active_fnc_err_ entry options (variable);
dcl  active_fnc_err_$suppress_name entry options (variable);
dcl  af_sw bit (1);
dcl  arg char (arg_len) based (arg_ptr);
dcl  arg_count fixed bin;
dcl  arg_len fixed bin (21);
dcl  arg_ptr ptr;
dcl  bit_count fixed bin (24);
dcl  char_arg_len fixed bin (21);
dcl  char_arg_ptr ptr;
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl  com_err_ entry () options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  comp_nm char (32);
dcl  complain entry variable options (variable);
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  dn char (168);
dcl  en char (32);
dcl  error_table_$badopt fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$not_act_fnc fixed bin (35) ext;
dcl  exclude_count fixed bin (21);
dcl  exclude_listp ptr;
dcl  expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  from_is_regexp bit (1);
dcl  from_line fixed bin (21);
dcl  from_string char (from_stringl) based (from_stringp);
dcl  from_stringl fixed bin (21);
dcl  from_stringp ptr;
dcl  get_system_free_area_ entry () returns (ptr);
dcl  have_selection_args bit (1) aligned;
dcl  initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$user_output ptr external;
dcl  loop fixed bin;
dcl  match_count fixed bin (21);
dcl  match_listp ptr;
dcl  move_len fixed bin (21);
dcl  myname char (32) int static options (constant) init ("contents");
dcl  NL char (1) static options (constant) init ("
");
dcl  path char (168);
dcl  pathname_$component entry (char (*), char (*), char (*)) returns (char (194));
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  return_arg char (return_len) varying based (return_ptr);
dcl  return_len fixed bin (21);
dcl  return_ptr ptr;
dcl  search_file_$silent
	entry (ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21),
	fixed bin (35));
dcl  seg char (seg_len) based (seg_ptr) aligned;
dcl  seg_len fixed bin (21);
dcl  seg_next_line char (seg_next_line_len) based (seg_next_line_ptr) aligned;
dcl  seg_next_line_len fixed bin (21);
dcl  seg_next_line_ptr ptr;
dcl  seg_pos fixed bin (21);
dcl  seg_ptr ptr;
dcl  SP char (1) static options (constant) init (" ");
dcl  SPACE char (1) int static options (constant) init (" ");
dcl  system_free_area area based (system_free_area_ptr);
dcl  system_free_area_ptr ptr;
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  to_is_regexp bit (1);
dcl  to_line fixed bin (21);
dcl  to_stringl fixed bin (21);
dcl  to_stringp ptr;
dcl  UNUSED fixed bin int static options (constant) init (-1);

     end contents;




		    entries.pl1                     12/01/86  1259.5rew 12/01/86  1257.5      370386



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




/****^  HISTORY COMMENTS:
  1) change(78-04-06,Palter), approve(), audit(), install():
     Written.
  2) change(79-02-02,MJordan), approve(), audit(), install():
     Extensively modified.
  3) change(81-01-12,Herbst), approve(81-01-12,MCR5511), audit(), install():
     Changed to format output based on line length.
  4) change(83-02-26,Pattin), approve(), audit(), install():
     Added extended object support to entries and files.
  5) change(84-01-12,Lippard), approve(84-03-06,MCR6781), audit(), install():
     Fixed output formatting, corrected to not return the same name twice,
     and made command invocation print an error when no matches are found.
  6) change(84-09-11,Lippard), approve(84-09-18,MCR7010), audit(), install():
     Changed to properly return matching link and change -type to
     -select_entry_type (-slet).
  7) change(85-02-12,Lippard), approve(), audit(), install():
     Changed to call Cleanup procedure when no entries are found.
  8) change(86-01-23,KFleming), approve(86-01-23,MCR7333),
     audit(86-08-05,Lippard), install(86-08-06,MR12.0-1116):
     Combined exists and entries into one module, since they have so much code
     in common. Also added the object_segments/nonobject_segments keywords and
     commands.
  9) change(86-11-10,GDixon), approve(86-11-24,MCR7579),
     audit(86-11-17,Lippard), install(86-12-01,MR12.0-1229):
     Added object_files/nonobject_files and object_msfs/nonobject_msfs
     entrypoints and keywords for exists.
                                                   END HISTORY COMMENTS */


/* format: style4,indattr */
entries: procedure () options (variable);

/* This command/active-function returns the entrynames (or pathnames) which match a given
   set of pathnames containing starnames, or if called as exists, returns true/false,
   if there were any matching names found.
*/

/* Automatic */

dcl  active_function        bit (1) aligned;
dcl  archive_bc	        fixed binary (24);
dcl  archive_ptr	        pointer;
dcl  arg_count	        fixed binary;
dcl  argument	        character (argument_lth) based (argument_ptr);
dcl  argument_lth	        fixed binary (21);
dcl  argument_ptr	        pointer;
dcl  c_ptr	        pointer;
dcl  char_168	        character (168);
dcl  chars_left	        fixed bin;
dcl  chase	        bit (1);
dcl  code		        fixed binary (35);
dcl  command_name	        character (32) varying;
dcl  component	        character (32);
dcl  dir		        character (168) unaligned;
dcl  dir_dname	        character (168) unaligned;
dcl  dir_ename	        character (32) unaligned;
dcl  ename	        character (32);
dcl  entry_index	        fixed bin;
dcl  entry_type_count       fixed bin;
dcl  entry_type_no	        fixed bin;
dcl  entry_type_ptr	        pointer;
dcl  error	        entry () options (variable) variable;
dcl  first_arg	        fixed binary;
dcl  found_something        bit (1) aligned;
dcl  found_uid	        bit (1) aligned;
dcl  fs_type	        character (32);
dcl  get_argument	        entry (fixed binary, pointer, fixed binary (21), fixed binary (35)) variable;
dcl  got_key	        bit (1) aligned;
dcl  idx		        fixed binary;
dcl  inhibit_error	        bit (1) aligned;
dcl  jdx		        fixed binary;
dcl  kdx		        fixed binary;
dcl  kname_index	        fixed binary;
dcl  line_length	        fixed bin;
dcl  link_array_ptr	        ptr;
dcl  n_link_names	        fixed bin (21);
dcl  n_uids	        fixed bin (21);
dcl  old_ename	        character (32);
dcl  return_absolute_pathnames bit (1) aligned;
dcl  return_names	        bit (1) aligned;
dcl  return_value	        character (return_value_lth) varying based (return_value_ptr);
dcl  return_value_lth       fixed binary (21);
dcl  return_value_ptr       pointer;
dcl  seg_ptr	        pointer;
dcl  select_entry_type      bit (1) aligned;
dcl  space	        character (2) varying;
dcl  starname_count	        fixed binary;
dcl  starnames	        (20) character (168);
dcl  system_area	        area based (system_area_ptr);
dcl  system_area_ptr        ptr;
dcl  table_index	        fixed binary;
dcl  1 type_info	        aligned like suffix_info;
dcl  uid_array_ptr	        ptr;
dcl  unique_id	        bit (36) aligned;

/* Based */

dcl  link_array	        (sys_info$max_seg_size / 8) char (32) aligned based (link_array_ptr);
dcl  uid_array	        (sys_info$max_seg_size) bit (36) aligned based (uid_array_ptr);
dcl  1 entry_type	        aligned based (entry_type_ptr),
       2 count	        fixed bin,
       2 suffix	        (entry_type_count refer (entry_type.count)) char (32) unaligned;

/* External Data */

dcl  iox_$user_output       ptr ext;
dcl  active_fnc_err_        entry options (variable);
dcl  archive_$get_component entry (ptr, fixed bin (24), char (*), ptr, fixed bin (24), fixed bin (35));
dcl  archive_$next_component entry (ptr, fixed bin (24), ptr, fixed bin (24), char (*), fixed bin (35));
dcl  com_err_	        entry options (variable);
dcl  check_star_name_$entry entry (char (*), fixed bin (35));
dcl  cu_$af_arg_ptr	        entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$af_return_arg      entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$arg_count	        entry (fixed binary);
dcl  cu_$arg_ptr	        entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  error_table_$archive_fmt_err fixed bin (35) ext static;
dcl  error_table_$archive_pathname fixed bin (35) ext static;
dcl  error_table_$bad_arg   fixed bin (35) ext static;
dcl  error_table_$badopt    fixed binary (35) external;
dcl  error_table_$no_s_permission fixed binary (35) external;
dcl  error_table_$noarg     fixed binary (35) external;
dcl  error_table_$no_dir    fixed bin (35) ext static;
dcl  error_table_$noentry   fixed bin (35) ext static;
dcl  error_table_$nomatch   fixed binary (35) external;
dcl  error_table_$not_act_fnc fixed binary (35) external;
dcl  error_table_$not_archive fixed bin (35) ext static;
dcl  error_table_$too_many_args fixed bin (35) ext static;
dcl  expand_pathname_       entry (character (*), character (*), character (*), fixed binary (35));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  fs_util_$get_type      entry (char (*), char (*), char (*), fixed bin (35));
dcl  fs_util_$suffix_info_for_type entry (char (*), ptr, fixed bin (35));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  get_system_free_area_  entry () returns (pointer);
dcl  get_temp_segment_      entry (char (*), ptr, fixed bin (35));
dcl  hcs_$get_uid_file      entry (char (*), char (*), bit (36) aligned, 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_minf       entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  initiate_file_	        entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_		        entry () options (variable);
dcl  ioa_$nnl	        entry () options (variable);
dcl  match_star_name_       entry (char (*), char (*), fixed bin (35));
dcl  object_lib_$initiate   entry (char(*), char(*), char(*), bit(1), ptr, fixed bin(24), bit(1), fixed bin(35));
dcl  pathname_	        entry (char(*), char(*)) returns(char(168));
dcl  release_temp_segment_  entry (char (*), ptr, fixed bin (35));
dcl  requote_string_        entry (character (*)) returns (character (*));
dcl  sys_info$max_seg_size  fixed bin (35) ext static;
dcl  terminate_file_        entry (ptr, fixed bin (24), bit (*), fixed bin (35));

/* Conditions */

dcl  cleanup	        condition;

/* Builtins */

dcl  (addr, after, before, binary, divide, hbound, index, length, max, null, rtrim, substr) builtin;

/*
   The following are manifest constants used in this procedure. The following descriptions should help in reading this
   code:

   I_D_		D_E_S_C_R_I_P_T_I_O_N_

   MSF		the missing storage system entry type
   XXXX_EI	the "entry index" for the XXXX type
   COMMAND_NAME	the command name used in error messages
   SELECT_SW	the star_select_sw that is appropriate
*/


dcl  MSF		        fixed bin static internal options (constant) init (3);

dcl  SEGMENTS_EI	        static internal options (constant) init (1);
dcl  DIRECTORIES_EI	        static internal options (constant) init (2);
dcl  MSFS_EI	        static internal options (constant) init (3);
dcl  LINKS_EI	        static internal options (constant) init (4);
dcl  ENTRIES_EI	        static internal options (constant) init (5);
dcl  BRANCHES_EI	        static internal options (constant) init (6);
dcl  FILES_EI	        static internal options (constant) init (7);
dcl  ZERO_SEGMENTS_EI       static internal options (constant) init (8);
dcl  MASTER_DIRECTORIES_EI  static internal options (constant) init (9);
dcl  NULL_LINKS_EI	        static internal options (constant) init (10);
dcl  NONSEGMENTS_EI	        static internal options (constant) init (11);
dcl  NONDIRECTORIES_EI      static internal options (constant) init (12);
dcl  NONMSFS_EI	        static internal options (constant) init (13);
dcl  NONFILES_EI	        static internal options (constant) init (14);
dcl  NONZERO_SEGMENTS_EI    static internal options (constant) init (15);
dcl  NONMASTER_DIRECTORIES_EI static internal options (constant) init (16);
dcl  NONNULL_LINKS_EI       static internal options (constant) init (17);
dcl  NONZERO_FILES_EI       static internal options (constant) init (18);
dcl  NONZERO_MSFS_EI        static internal options (constant) init (19);
dcl  NONBRANCHES_EI	        static internal options (constant) init (20);
dcl  NONLINKS_EI	        static internal options (constant) init (21);
dcl  OBJECT_FILES_EI        static internal options (constant) init (22);
dcl  NONOBJECT_FILES_EI     static internal options (constant) init (23);
dcl  OBJECT_MSFS_EI	        static internal options (constant) init (24);
dcl  NONOBJECT_MSFS_EI      static internal options (constant) init (25);
dcl  OBJECT_SEGMENTS_EI     static internal options (constant) init (26);
dcl  NONOBJECT_SEGMENTS_EI  static internal options (constant) init (27);
/*
dcl  COMPONENTS_EI	        static internal options (constant) init (28);
			"exists components" has no corresponding
			entrypoint in the entries family of commands */
dcl  EXISTS_EI	        static internal options (constant) init (29);

dcl  COMMAND_NAME	        (29) char (24) static internal options (constant) init (
		        "segments",
		        "directories",
		        "msfs",
		        "links",
		        "entries",
		        "branches",
		        "files",
		        "zero_segments",
		        "master_directories",
		        "null_links",
		        "nonsegments",
		        "nondirectories",
		        "nonmsfs",
		        "nonfiles",
		        "nonzero_segments",
		        "nonmaster_directories",
		        "nonnull_links",
		        "nonzero_files",
		        "nonzero_msfs",
		        "nonbranches",
		        "nonlinks",
		        "object_files",
		        "nonobject_files",
		        "object_msfs",
		        "nonobject_msfs",
		        "object_segments",
		        "nonobject_segments",
		        *,		/* Place holder for 
					   exists component */
		        "exists");

dcl  SELECT_SW	        (29) fixed bin static internal options (constant) init (
		        2, 2, 2, 1, 3, 2, 2, 2, 2, 5,
		        3, 3, 3, 3, 3, 2, 5, 2, 2, 1,
		        2, 2, 2, 2, 2, 2, 2, 2, *);
					/* Note: the above SELECT_SW
					   value for EXISTS_EI is
					   not used. */
dcl  TRUE		        bit (1) internal static options (constant) initial ("1"b);
dcl  FALSE	        bit (1) internal static options (constant) initial ("0"b);
dcl  KEY_NAME	        (47) char (24) int static options (constant) init (
        "branch",		       "nonbranch",
        "component",
        "directory", "dir",	       "nondirectory", "nondir",
        "entry",
        "file",		       "nonfile",
        "link",		       "nonlink",
        "master_directory", "mdir",  "nonmaster_directory", "nmdir",
        "msf",		       "nonmsf",
        "null_link", "nlink",	       "non_null_link", "nonnull_link", "nnlink",
        "object_file", "obfile",     "nonobject_file", "nobfile",
        "object_msf", "obmsf",       "nonobject_msf", "nobmsf",
        "object_segment", "obseg",   "nonobject_segment", "nobseg",
        "segment", "seg",	       "nonsegment", "nonseg",
			       "nonzero_file", "nzfile",
			       "nonzero_msf", "nzmsf",
        "zero_segment", "zseg",      "nonzero_segment", "nzseg");
dcl  INDEX_TAB	        (47) fixed bin static internal options (constant) init (
     6,  /* branch */		20,  /* nonbranch */
    28,  /* component */
 2,  2,  /* directory */            12, 12,  /* nondirectory */
     5,  /* entry */
     7,  /* file */			14,  /* nonfile */
     4,  /* link */			21,  /* nonlink */
 9,  9,  /* master_directory */     16, 16,  /* nonmaster_directory */
     3,  /* msf */			13,  /* nonmsf */
10, 10,  /* null_link */        17, 17, 17,  /* non_null_link */
22, 22,  /* object_file */	      23, 23,  /* nonobject_file */
24, 24,  /* object_msf */	      25, 25,  /* nonobject_msf */
26, 26,  /* object_segment */	      27, 27,  /* nonobject_segment */
 1,  1,  /* segment */	      11, 11,  /* nonsegment */
			      18, 18,  /* nonzero_file */
			      19, 19,  /* nonzero_msf */
 8,  8,  /* zero_segment */	      15, 15); /* nonzero_segment */
dcl  CHASE_OK	        (29) bit (1) unaligned internal static options (constant) initial (
	        "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b,
	        "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b,
	        "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b);
dcl  ROOT		        (29) bit (1) unaligned internal static options (constant) initial (
	        "0"b, "1"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b, "0"b,
	        "1"b, "0"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b,
	        "1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "0"b);

/*

   The following are all of the entries to this command/active function. At each entry the entry_index is set using
   the constants declared above and control is passed to the common code below.

*/


/* entries: proc() options (variable); */

	entry_index = ENTRIES_EI;
	goto COMMON;

files:
     entry () options (variable);

	entry_index = FILES_EI;
	go to COMMON;

segments:
segs:
     entry () options (variable);

	entry_index = SEGMENTS_EI;
	go to COMMON;

directories:
dirs:
     entry () options (variable);

	entry_index = DIRECTORIES_EI;
	go to COMMON;

links:
     entry () options (variable);

	entry_index = LINKS_EI;
	go to COMMON;

branches:
     entry () options (variable);

	entry_index = BRANCHES_EI;
	go to COMMON;

nonsegments:
nonsegs:
     entry () options (variable);

	entry_index = NONSEGMENTS_EI;
	go to COMMON;

nondirectories:
nondirs:
     entry () options (variable);

	entry_index = NONDIRECTORIES_EI;
	go to COMMON;

msfs:
     entry options (variable);

	entry_index = MSFS_EI;
	goto COMMON;

zero_segments:
zsegs:
     entry options (variable);

	entry_index = ZERO_SEGMENTS_EI;
	goto COMMON;

master_directories:
mdirs:
     entry () options (variable);

	entry_index = MASTER_DIRECTORIES_EI;
	goto COMMON;

null_links:
nlinks:
     entry () options (variable);

	entry_index = NULL_LINKS_EI;
	goto COMMON;

nonmsfs:
     entry () options (variable);

	entry_index = NONMSFS_EI;
	goto COMMON;

nonfiles:
     entry () options (variable);

	entry_index = NONFILES_EI;
	goto COMMON;

nonzero_segments:
nzsegs:
     entry () options (variable);

	entry_index = NONZERO_SEGMENTS_EI;
	goto COMMON;

nonmaster_directories:
nmdirs:
     entry () options (variable);

	entry_index = NONMASTER_DIRECTORIES_EI;
	goto COMMON;

nonnull_links:
nnlinks:
     entry () options (variable);

	entry_index = NONNULL_LINKS_EI;
	goto COMMON;

nonzero_files:
nzfiles:
     entry () options (variable);

	entry_index = NONZERO_FILES_EI;
	goto COMMON;

nonzero_msfs:
nzmsfs:
     entry () options (variable);

	entry_index = NONZERO_MSFS_EI;
	goto COMMON;

object_files:
obfiles:
     entry () options (variable);

	entry_index = OBJECT_FILES_EI;
	goto COMMON;

nonobject_files:
nobfiles:
     entry () options (variable);

	entry_index = NONOBJECT_FILES_EI;
	goto COMMON;

object_msfs:
obmsfs:
     entry () options (variable);

	entry_index = OBJECT_MSFS_EI;
	goto COMMON;

nonobject_msfs:
nobmsfs:
     entry () options (variable);

	entry_index = NONOBJECT_MSFS_EI;
	goto COMMON;

object_segments:
obsegs:
     entry () options (variable);

	entry_index = OBJECT_SEGMENTS_EI;
	goto COMMON;

nonobject_segments:
nobsegs:
     entry () options (variable);

	entry_index = NONOBJECT_SEGMENTS_EI;
	goto COMMON;

nonbranches:
     entry () options (variable);

	entry_index = NONBRANCHES_EI;
	goto COMMON;

nonlinks:
     entry () options (variable);

	entry_index = NONLINKS_EI;
	goto COMMON;

exists:
     entry () options (variable);

	entry_index = EXISTS_EI;
	goto COMMON;

/*
   The following is code common to all entries.
*/
COMMON:
	system_area_ptr = get_system_free_area_ ();

	star_list_branch_ptr,
	     star_list_names_ptr = null ();

	space = "";				/* no space before first pathname */

	entry_type_ptr, seg_ptr, archive_ptr, link_array_ptr, uid_array_ptr = null ();

	on condition (cleanup)
	     call Cleanup ();

	command_name = COMMAND_NAME (entry_index);	/* get the proper command name */
	found_something = FALSE;

	call cu_$af_return_arg (arg_count, return_value_ptr, return_value_lth, code);

	if code = error_table_$not_act_fnc
	then do;					/* not an active function */
	     active_function = FALSE;
	     call cu_$arg_count (arg_count);		/* get proper argument count */
	     get_argument = cu_$arg_ptr;
	     error = com_err_;
	end;

	else do;					/* active function */
	     active_function = TRUE;
	     get_argument = cu_$af_arg_ptr;
	     error = active_fnc_err_;
	end;

	if entry_index = EXISTS_EI then do;
	     return_names = FALSE;
	     first_arg = 2;
	     if arg_count < 1 then do;
USAGE:		call error (error_table_$noarg, command_name, "Usage: ^[[^]^a key star_name(s) {-control_arg(s)} ^[]^]", active_function, command_name, active_function);
		return;
	     end;
	     call get_argument (1, argument_ptr, argument_lth, code);
	     if code ^= 0 then goto ARGERR;

	     if argument = "argument" then do;
		found_something = (arg_count > 1);
		goto DONE;
	     end;
	     else if arg_count < 2 then goto USAGE;

	     got_key = FALSE;
	     do kname_index = 1 to hbound (KEY_NAME, 1) while (^got_key);
		got_key = (argument = KEY_NAME (kname_index));
	     end;
	     if ^got_key then do;
		call error (0, command_name, "Invalid key ^a.", argument);
		return;
	     end;

	     kname_index = kname_index - 1;
	     table_index = INDEX_TAB (kname_index);
	end;
	else do;
	     kname_index = 1;
	     return_names = TRUE;
	     first_arg = 1;
	     table_index = entry_index;
	end;

	star_select_sw = SELECT_SW (table_index);	/* select switch for this entry */

/*
   Scan the command arguments to make sure we have at least one starname and that only valid control arguments are
   specified by the user.
*/
	starname_count = 0;
	inhibit_error, chase, select_entry_type, return_absolute_pathnames = FALSE;

	do idx = first_arg to arg_count;
	     call get_argument (idx, argument_ptr, argument_lth, code);
	     if code ^= 0 then do;
ARGERR:		call error (code, command_name);
		return;
	     end;
	     if substr (argument, 1, 1) = "-" then do;
		if ((argument = "-absolute_pathname") | (argument = "-absp")) & return_names then return_absolute_pathnames = TRUE;
		else if (argument = "-chase") & CHASE_OK (table_index)
		then chase = TRUE;
		else if (argument = "-no_chase") & CHASE_OK (table_index)
		then chase = FALSE;
		else if (argument = "-inhibit_error" | argument = "-ihe")
		then inhibit_error = TRUE;
		else if (argument = "-no_inhibit_error" | argument = "-nihe")
		then inhibit_error = FALSE;
		else if (table_index = ENTRIES_EI | table_index = FILES_EI | table_index = EXISTS_EI) & ((argument = "-select_entry_type") | (argument = "-slet")) then do;
		     if idx = arg_count then do;
			call error (error_table_$noarg, command_name, "^a requires an entry type list.", argument);
			return;
		     end;
		     idx = idx + 1;
		     call get_argument (idx, argument_ptr, argument_lth, code);
		     if code ^= 0 then goto ARGERR;
		     call process_entry_type_list (argument, entry_type_ptr, select_entry_type);
		     if ^select_entry_type then do;
			call error (error_table_$bad_arg, command_name, "Invalid entry type selected. ^a", argument);
			return;
		     end;
		end;
		else do;				/* unknown control */
		     call error (error_table_$badopt, command_name, "^a", argument);
		     return;
		end;
	     end;
	     else do;
		if starname_count = 20 then do;
		     call error (error_table_$too_many_args, command_name, "Only 20 starnames may be specified.");
		     goto ABORT;
		end;
		starname_count = starname_count + 1;
		starnames (starname_count) = argument;
	     end;
	end;

	if starname_count = 0 then do;
	     call error (error_table_$noarg, command_name,
		"^/    Usage:  ^[[^;^]^a starnames {-control_arg^[s^]}^[]^;^]",
		active_function, command_name, (CHASE_OK (table_index)), active_function);
	     goto ABORT;
	end;

	if star_select_sw = star_BRANCHES_ONLY & chase
	then star_select_sw = star_ALL_ENTRIES;

/*
   Now that we are all set, process the starnames in order.
*/

	if return_names then do;
	     if ^active_function then line_length, chars_left = get_line_length_$switch (iox_$user_output, (0));

	     call get_temp_segment_ ((command_name), link_array_ptr, code);

	     if code ^= 0 then do;
		call error (code, command_name, "While getting temp segment.");
		go to ABORT;
	     end;

	     n_link_names = 0;

	     call get_temp_segment_ ((command_name), uid_array_ptr, code);

	     if code ^= 0 then do;
		call error (code, command_name, "While getting temp segment.");
		go to ABORT;
	     end;

	     n_uids = 0;
	end;

	do idx = 1 to starname_count;

	     found_something = found_something | Process_Pathname (starnames (idx));
	     if found_something & ^return_names then goto DONE;
	end;

DONE:	if ^return_names then do;
	     if found_something then do;
		if active_function then return_value = "true";
		else call ioa_ ("true");
	     end;
	     else do;
		if active_function then return_value = "false";
		else call ioa_ ("false");
	     end;
	end;
	else do;
	     if ^found_something then do;
		if active_function then return_value = "";
		else call error ((0), command_name, "No entries found.");
	     end;
	     else if ^active_function then call ioa_ ("");
	end;

ABORT:
	call Cleanup ();
	return;

/* This procedure processes one starname which has been specified in the command line. */
Process_Pathname:
     procedure (pathname) returns (bit (1));

dcl  pathname	        character (*) parameter;
dcl  result	        bit (1) aligned;
dcl  idx                    fixed binary;

	result = FALSE;

	call expand_pathname_$component (pathname, dir, ename, component, code);
	if code ^= 0 then goto PATH_ERR;

	if component = "" & KEY_NAME (kname_index) = "component" then do;
	     code = error_table_$not_archive;
	     goto PATH_ERR;
	end;

	if component ^= "" & KEY_NAME (kname_index) ^= "component" then do;
	     code = error_table_$archive_pathname;
	     goto PATH_ERR;
	end;

	if (dir = ">") & (ename = "") then do;
	     if table_index = ENTRIES_EI then do;	/* entry */
		if select_entry_type then
		     if entry_type_selected (entry_type_ptr, FS_OBJECT_TYPE_DIRECTORY) then call Return_Entry (ename, FALSE);
		     else return (FALSE);
		else call Return_Entry (ename, FALSE);
	     end;
	     else if ROOT (table_index) then call Return_Entry (ename, FALSE);
	     else return (FALSE);
	end;
	else do;
	     call check_star_name_$entry (ename, code);
	     if ^((code = 0) | (code = 1) | (code = 2)) then goto PATH_ERR;
	     if table_index ^= ENTRIES_EI then do;
		call Get_Star_Names ();
		if code ^= 0 & code ^= error_table_$no_s_permission then do;
		     if code = error_table_$noentry | code = error_table_$no_dir | code = error_table_$nomatch then return (FALSE);
		     else goto PATH_ERR;
		end;
		do idx = star_branch_count + star_link_count to 1 by -1 while (return_names | ^result);
		     if Process_A_Name (table_index, addr (star_dir_list_branch (idx)))
		     then call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), ((star_dir_list_branch (idx).type) = Link));
		end;
	     end;
	     else do;
		result = Process_A_Name (table_index, null ());
	     end;
	end;

	call free_star_structures ();

	return (result);

PATH_ERR:
	if (length (space) ^= 0) & ^active_function then call ioa_ ("");
	if ^inhibit_error then do;
	     call error (code, command_name, "^a", pathname);
	     goto ABORT;
	end;
	else return (FALSE);

Return_Entry: procedure (ename, is_link);

dcl  ename	        char (*) parameter;
dcl  is_link	        bit (1) parameter;
dcl  temp_string	        character (256) varying;

	     if return_names then do;
		if is_link then do;
		     call expand_pathname_ (dir, dir_dname, dir_ename, (0));
		     call hcs_$get_uid_file (dir_dname, dir_ename, unique_id, (0));
		     found_uid = FALSE;
		     do jdx = 1 to n_uids while (^found_uid);
			if unique_id = uid_array (jdx) then do;
			     found_uid = TRUE;
			     do kdx = 1 to n_link_names;
				if link_array (kdx) = ename then return;
			     end;
			     n_link_names = n_link_names + 1;
			     if n_link_names > hbound (link_array, 1) then do;
				call error (0, command_name, "Too many links for internal array.");
				goto ABORT;
			     end;
			     link_array (n_link_names) = ename;
			end;
		     end;
		     if ^found_uid then do;
			n_uids = n_uids + 1;
			if n_uids > hbound (uid_array, 1) then do;
			     call error (0, command_name, "Too many entries for internal array.");
			     goto ABORT;
			end;
			uid_array (n_uids) = unique_id;
			n_link_names = n_link_names + 1;
			if n_link_names > hbound (link_array, 1) then do;
			     call error (0, command_name, "Too many links for internal array.");
			     goto ABORT;
			end;
			link_array (n_link_names) = ename;
		     end;
		end;
		else do;
		     call hcs_$get_uid_file (dir, ename, unique_id, (0));
		     do jdx = 1 to n_uids;
			if unique_id = uid_array (jdx) then return;
		     end;
		     n_uids = n_uids + 1;
		     if n_uids > hbound (uid_array, 1) then do;
			call error (0, command_name, "Too many entries for internal array.");
			goto ABORT;
		     end;
		     uid_array (n_uids) = unique_id;
		end;
		if return_absolute_pathnames then if dir = ">" then temp_string = ">";
		     else temp_string = rtrim (dir) || ">";
		else temp_string = "";

		temp_string = temp_string || rtrim (ename);

		if active_function then do;
		     return_value = return_value || space;
		     return_value = return_value || requote_string_ ((temp_string));
		end;
		else if chars_left > length (temp_string) + length (space) then do;
		     call ioa_$nnl (space || "^a", temp_string);
		     chars_left = chars_left - length (temp_string) - length (space);
		end;
		else do;
		     call ioa_$nnl ("^/^a", temp_string);
		     chars_left = max (0, line_length - length (temp_string));
		end;

		if active_function then space = " ";
		else space = "  ";

	     end;

	     result = TRUE;

	end Return_Entry;

Process_A_Name: procedure (table_index, entry_ptr) returns (bit (1));

dcl  table_index	        fixed binary parameter;
dcl  entry_ptr	        pointer parameter;
dcl  1 entry	        aligned like star_dir_list_branch based (entry_ptr);
dcl  type		        fixed bin (2);
dcl  bit_count	        fixed bin (24);
dcl  null_link	        bit (1);
dcl  idx		        fixed binary;

	     if table_index ^= ENTRIES_EI then do;
		type = entry.type;
		bit_count = entry.bit_count;
		if type = Link then do;
		     if ^chase then do;
			call hcs_$status_minf (dir, star_list_names (entry.nindex), 1, (0), (0), code); /* Check target by chasing link */
			null_link = ^(code = 0);
		     end;
		     else call hcs_$status_minf (dir, star_list_names (entry.nindex), 1, type, bit_count, code);
		end;
		if type = Directory & bit_count > 0 then type = MSF;
	     end;

	     go to PROCESS (table_index);

PROCESS (1):					/* segment */
	     return ((type = Segment));

PROCESS (2):					/* directory */
	     return ((type = Directory & bit_count = 0));

PROCESS (3):					/* MSF */
	     return ((type = MSF));

PROCESS (4):					/* link */
PROCESS (20):
	     return ((type = Link));

PROCESS (5):					/* entry = segment, MSF, directory, or link */
	     star_select_sw = star_ALL_ENTRIES;
	     if select_entry_type then do;
		do entry_type_no = 1 to entry_type.count;
		     old_ename = ename;
		     if substr (entry_type.suffix (entry_type_no), 1, 1) = "-" then ; /* standard non-suffixed entry */
		     else call expand_pathname_$add_suffix (old_ename, entry_type.suffix (entry_type_no), char_168, ename, code);
		     call Get_Star_Names;
		     do idx = star_branch_count + star_link_count to 1 by -1;
			if star_dir_list_branch (idx).type = Link then do;
			     if ^chase then if entry_type_selected (entry_type_ptr, FS_OBJECT_TYPE_LINK)
				then call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), TRUE);
				else ;
			     else do;
				call fs_util_$get_type (dir, star_list_names (star_dir_list_branch (idx).nindex), fs_type, code);
				if fs_type = entry_type.suffix (entry_type_no)
				then call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), FALSE);
			     end;
			end;
			else do;
			     call fs_util_$get_type (dir, star_list_names (star_dir_list_branch (idx).nindex), fs_type, code);
			     if fs_type = entry_type.suffix (entry_type_no)
			     then call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), FALSE);
			end;
		     end;
		     if star_list_names_ptr ^= null () then do;
			free star_list_names_ptr -> star_list_names;
			free star_list_branch_ptr -> star_dir_list_branch;
		     end;
		     ename = old_ename;
		end;
	     end;
	     else do;
		call Get_Star_Names;
		if ^return_names
		then if star_branch_count + star_link_count > 0 then return (TRUE);
		     else ;
		else do idx = star_branch_count + star_link_count to 1 by -1;
		     call Return_Entry (star_list_names (star_dir_list_branch (idx).nindex), (star_dir_list_branch (idx).type = Link));
		end;
	     end;
	     return (result);

PROCESS (6):					/* branch = segment, MSF, or directory */
PROCESS (21):
	     return ((type ^= Link));

PROCESS (7):					/* file = MSF or segment */
	     return ((type = Segment) | (type = MSF));

PROCESS (8):					/* zero-length segment */
	     return ((type = Segment) & (bit_count = 0));

PROCESS (9):					/* master directory */
	     return ((entry.master_dir));

PROCESS (10):					/* null link */
	     return ((type = Link) & null_link);

PROCESS (11):					/* nonsegment */
	     return ((type ^= Segment));

PROCESS (12):					/* nondirectory */
	     return (^((type = Directory) & (bit_count = 0)));

PROCESS (13):					/* nonMSF */
	     return (^(type = MSF));

PROCESS (14):					/* nonfile */
	     return (^((type = Segment) | (type = MSF)));

PROCESS (15):					/* nonzero segment */
	     return ((type = Segment) & (bit_count ^= 0));

PROCESS (16):					/* nonmaster directory */
	     return ((type = Directory) & ^entry.master_dir);

PROCESS (17):					/* nonnull link */
	     return ((type = Link) & ^(null_link));

PROCESS (18):					/* nonzero file */
	     if (type = Segment) then
	          return (bit_count ^= 0);
	     else if (type = MSF) then
	          return (Msf_Nonzero (dir, star_list_names (entry.nindex), bit_count));
	     else return (FALSE);

PROCESS (19):					/* nonzero MSF */
	     if (type = MSF) then
	          return (Msf_Nonzero (dir, star_list_names (entry.nindex), bit_count));
	     else return (FALSE);

PROCESS (22):					/* object file */
	     if (type = Segment | type = MSF) then
	          return (Check_Object_Segment (dir, star_list_names (entry.nindex)));
	     else return (FALSE);

PROCESS (23):					/* nonobject file */
	     if (type = Segment | type = MSF) then
	          return (^Check_Object_Segment (dir, star_list_names (entry.nindex)));
	     else return (FALSE);

PROCESS (24):					/* object msf */
	     if type = MSF then
	          return (Check_Object_Segment (dir, star_list_names (entry.nindex)));
	     else return (FALSE);

PROCESS (25):					/* nonobject msf */
	     if type = MSF then
	          return (^Check_Object_Segment (dir, star_list_names (entry.nindex)));
	     else return (FALSE);

PROCESS (26):					/* object segment */
	     if type = Segment then
	          return (Check_Object_Segment (dir, star_list_names (entry.nindex)));
	     else return (FALSE);

PROCESS (27):					/* nonobject segment */
	     if type = Segment then
	          return (^Check_Object_Segment (dir, star_list_names (entry.nindex)));
	     else return (FALSE);

PROCESS (28):					/* exists component */
	     call initiate_file_ (dir, star_list_names (entry.nindex), R_ACCESS, archive_ptr, archive_bc, code);
	     if archive_ptr = null () then goto PATH_ERR;

	     call check_star_name_$entry (component, code);
	     if code = 1 | code = 2 then return (process_component_starname (archive_ptr, archive_bc, component));
	     else do;
		call archive_$get_component (archive_ptr, archive_bc, component, (null ()), (0), code);
		if code = 0 then return (TRUE);
		else if (code = error_table_$not_archive) | (code = error_table_$archive_fmt_err) then goto PATH_ERR;
		else return (FALSE);
	     end;

	end Process_A_Name;

/* This procedure will call hcs_$star_dir_list_ on ename. */
Get_Star_Names: procedure;

	     star_branch_count, star_link_count = 0;
	     call hcs_$star_dir_list_ (dir, ename, star_select_sw, system_area_ptr, star_branch_count, star_link_count, star_list_branch_ptr, star_list_names_ptr, code);

	end Get_Star_Names;

Check_Object_Segment: procedure (dir, ename) returns (bit (1));

dcl  (dir, ename)	        character (*) parameter;
	     
	     seg_ptr = null ();
	     call object_lib_$initiate (dir, ename, "", "1"b, seg_ptr, (0), (""b), code);
	     call terminate_file_ (seg_ptr, (0), TERM_FILE_TERM, (0));
	     return (code = 0);

	end Check_Object_Segment;


Msf_Nonzero: procedure (dir, ename, msf_indicator) returns (bit(1));

dcl  (dir, ename)	        character (*) parameter;
dcl   msf_indicator	        fixed bin(24) parameter;	/* MSF comp count */
dcl   code	        fixed bin(35);
dcl   comp	        fixed bin;
dcl   comp_bit_count        fixed bin(24);
dcl   msf_bit_count	        fixed bin(35);
dcl   msf_dir	        char(168);
	     
	     msf_dir = pathname_ (dir, ename);
	     msf_bit_count = 0;
	     do comp = 0 to msf_indicator - 1;
	          call hcs_$status_minf (msf_dir, ltrim(char(comp)),
		     1, (0), comp_bit_count, code);
		if code = 0 then
		     msf_bit_count = msf_bit_count + comp_bit_count;
		end;
	     return (msf_bit_count > 0);

	end Msf_Nonzero;

/* The process_component_starname function determines if any components in the specified archive
   match the component starname given.  If so, TRUE is returned. */
process_component_starname: proc (archive_ptr, archive_bc, c_starname) returns (bit (1));

dcl  archive_bc	        fixed bin (24),
     archive_ptr	        ptr,
     c_name	        char (32),
     c_starname	        char (32);

	     c_ptr = null ();
	     do while ("1"b);
		call archive_$next_component (archive_ptr, archive_bc, c_ptr, (0), c_name, code);
		if code ^= 0 then return (FALSE);
		if c_ptr = null () then return ("0"b);	/* no components remaining in the archive	*/
		call match_star_name_ (c_name, c_starname, code);
		if code = 0 then return ("1"b);
	     end;

	end process_component_starname;

     end Process_Pathname;

/* This entry releases the temp segment and frees the star structures. */
Cleanup: procedure ();

	if link_array_ptr ^= null ()
	then call release_temp_segment_ ((command_name), link_array_ptr, (0));
	if uid_array_ptr ^= null ()
	then call release_temp_segment_ ((command_name), uid_array_ptr, (0));
	call free_star_structures ();
	if seg_ptr ^= null () then call terminate_file_ (seg_ptr, (0), TERM_FILE_TERM, (0));
	if archive_ptr ^= null () then call terminate_file_ (seg_ptr, (0), TERM_FILE_TERM, (0));
	if entry_type_ptr ^= null () then free entry_type in (system_area);

     end Cleanup;

/* This procedure is called to clean up allocated storage. */
free_star_structures:
     procedure ();

	if star_list_names_ptr ^= null ()
	then free star_list_names;

	if star_list_branch_ptr ^= null ()
	then free star_dir_list_branch;

	star_list_branch_ptr,
	     star_list_names_ptr = null ();

     end free_star_structures;

/* The process_entry_type_list procedure parses a comma delimited list of both
   standard and extended entry types into an array of type names. */
process_entry_type_list: procedure (entry_type_list, entry_type_struct_ptr, limit_entry_selections);

dcl  entry_type_list        char (*) parameter;
dcl  entry_type_struct_ptr  pointer parameter;
dcl  limit_entry_selections
		        bit (1) aligned parameter;
dcl  types_len	        fixed bin (24);
dcl  types_ptr	        pointer;
dcl  types	        char (types_len) based (types_ptr);
dcl  entry_type_no	        fixed bin;
dcl  this_type	        char (32);


/* copy entry_type_list into "real" storage */

	types_ptr = null ();
	on cleanup begin;
	     if types_ptr ^= null () then free types in (system_area);
	end;

	types_len = length (entry_type_list);
	allocate types set (types_ptr) in (system_area);
	types = entry_type_list;

/* to start off, get a count of the number of types in the string */

	do entry_type_count = 1
	     repeat (entry_type_count + 1)
	     while (index (types, ",") > 0);
	     types = after (types, ",");
	end;

/* allocate the entry_type structure, to be used later in this command */

	allocate entry_type
	     set (entry_type_struct_ptr)
	     in (system_area);

	entry_type_struct_ptr -> entry_type.suffix (*) = "";

/* for each potential entry type, validate it and add it to the structure */

	types = entry_type_list;
	type_info.version = SUFFIX_INFO_VERSION_1;
	entry_type_no = 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;
		entry_type_struct_ptr -> entry_type.suffix (entry_type_no) = this_type;
		if this_type = FS_OBJECT_TYPE_LINK then entry_type_no = entry_type_no + 1;
						/*  fs_util_ does not support links */
		else do;
		     call fs_util_$suffix_info_for_type (this_type, addr (type_info), code);
		     if code = 0 then entry_type_no = entry_type_no + 1; /* complaining here is also */
		end;
	     end;					/* a viable alternative. */
	     types = after (types, ",");
	end;

/* free the types variable and set the limit_entry_selections flag */

	free types_ptr -> types
	     in (system_area);

	entry_type_struct_ptr -> entry_type.count = entry_type_no - 1;
	if entry_type_struct_ptr -> entry_type.count > 0 then limit_entry_selections = "1"b;
	else limit_entry_selections = "0"b;

	return;

     end process_entry_type_list;


/* The entry_type_selected function searches the entry_type structure for a given
   type.
*/

entry_type_selected: proc (entry_type_struct_ptr, fs_type) returns (bit (1) aligned);


dcl  entry_type_struct_ptr  pointer parameter;
dcl  fs_type	        char (32) parameter;
dcl  entry_type_no	        fixed bin;

	do entry_type_no = 1 to entry_type_struct_ptr -> entry_type.count;
	     if entry_type_struct_ptr -> entry_type.suffix (entry_type_no) = fs_type then return ("1"b);
	end;
	return ("0"b);

     end entry_type_selected;

%include access_mode_values;

%include copy_flags;

%include file_system_operations;

%include object_info;

%include star_structures;

%include status_structures;

%include suffix_info;

%include terminate_file;

     end entries;




		    equal_name.pl1                  09/04/90  1204.8rew 09/04/90  1202.7       47520



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




/****^  HISTORY COMMENTS:
  1) change(90-01-25,Vu), approve(90-01-25,MCR8153), audit(90-06-21,Huen),
     install(90-09-04,MR12.4-1032):
     The active function for equal_name will now return quoted string.
                                                   END HISTORY COMMENTS */


equal_name: enm: proc;
/* Command level interface to equal name generation.
   Updated to understand archive component equal names. 2/18/82 B. Margolin.
*/

dcl (Lequal,					/* length of equal name.			*/
     Lret,					/* length of af return string.		*/
     Lsource,					/* length of source name.			*/
     Nargs) fixed bin,				/* number of input arguments.			*/
    (Pequal,					/* ptr to equal name.			*/
     Pret,					/* ptr to af return string.			*/
     Psource) ptr,					/* ptr to source name.			*/
     Scommand bit (1) aligned,			/* on if invoked as a command.		*/
     Spath bit (1) aligned,				/* equal name is a pathname not entryname */
     code fixed bin (35),				/* error code.				*/
     equal_dir char (168),				/* dir part of input equal name.		*/
     equal_ent char (32),				/* ent part of input equal name.		*/
     equal_comp char (32),				/* comp part of input equal name.		*/
     error entry variable options (variable),
     get_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)) variable,
     result_name char (32),				/* resulting name.				*/
     result_comp char (32),				/* resulting component.			*/
     output_name char (168),				/* name to output				*/
     source_dir char (168),				/* dir part of input source name.		*/
     source_comp char (32),				/* comp part of input source name.		*/
     source_ent char (32);				/* ent part of input source name.		*/



dcl  equal char (Lequal) based (Pequal),
     ret char (Lret) varying based (Pret),
     source char (Lsource) based (Psource);


dcl (length, rtrim, search, substr)
     builtin;


dcl (active_fnc_err_, active_fnc_err_$suppress_name,
     com_err_, com_err_$suppress_name)
     entry options (variable),
     cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)),
    (cu_$af_arg_ptr,
     cu_$arg_ptr) entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cu_$arg_count entry returns (fixed bin),
     expand_pathname_$component entry (char(*), char(*), char(*), char(*), fixed bin(35)),
     pathname_$component_check entry (char(*), char(*), char(*), char(*), fixed bin(35)),
     get_equal_name_$component entry (char(*), char(*), char(*), char(*), char(32), char(32), fixed bin(35)),
    (ioa_, ioa_$rsnnl) entry options (variable),
     requote_string_ entry (char (*)) returns (char (*));

/*  */

	call cu_$af_return_arg (Nargs, Pret, Lret, code);
	if code = 0 then do;
	     Scommand = "0"b;
	     error = active_fnc_err_;
	end;
	else do;
	     Scommand = "1"b;
	     error = com_err_;
	     Nargs = cu_$arg_count ();
	end;

	if Nargs ^= 2 then do;
	     if Scommand then call com_err_$suppress_name (0, "equal_name", "Usage:  equal_name path =name");
	     else call active_fnc_err_ (0, "equal_name", "Usage:  [equal_name path =name]");
	     return;
	end;
	call cu_$arg_ptr (1, Psource, Lsource, 0);
	call cu_$arg_ptr (2, Pequal, Lequal, 0);
	call expand_pathname_$component (source, source_dir, source_ent, source_comp, code);
	if code ^= 0 then do;
	     call error (code, "equal_name", "^a", source);
	     return;
	end;
	Spath = (search (equal, "<>") ^= 0);		/* Is it a full pathname?			*/
	call expand_pathname_$component (equal, equal_dir, equal_ent, equal_comp, code);
	if code ^= 0 then do;
	     call error (code, "equal_name", "^a", equal);
	     return;
	end;
	call get_equal_name_$component (source_ent, source_comp, equal_ent, equal_comp, result_name, result_comp, code);
	if code ^= 0 then do;
	     call error (code, "equal_name", "^a^[::^a^;^s^] applied to ^a^[::^a^;^s^]",
			equal_ent, (equal_comp ^= ""), equal_comp,
			source_ent, (source_comp ^= ""), source_comp);
	     return;
	end;
	if Spath then do;				/* Gave pathname, wants pathname */
	     call pathname_$component_check (equal_dir, result_name, result_comp, output_name, code);
	     if code ^= 0 then do;
		call error (code, "equal_name", "Creating the output pathname.");
		return;
	     end;
	end;
	/* Gave just an entryname */
	else do;
	     if result_comp = "" then output_name = result_name;	/* Not an archive */
	     else output_name = substr (result_name, 1, length (rtrim (result_name)) - 8) || "::" || result_comp; /* remove ".archive" */
	end;

	if Scommand then
	     call ioa_ ("^a", output_name);
	else ret = requote_string_ (rtrim (output_name));
	return;

     end equal_name;




		    get_pathname.pl1                09/04/90  1204.8rew 09/04/90  1202.8       71604



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



	

/****^  HISTORY COMMENTS:
  1) change(90-01-25,Vu), approve(90-01-25,MCR8153), audit(90-06-21,Huen),
     install(90-09-04,MR12.4-1032):
     The active function for get_pathname will now return quoted string.
                                                   END HISTORY COMMENTS */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e:  get_pathname, gpn							*/
	/*									*/
	/*      This active function, given a reference name or an octal segment number, returns	*/
	/* the full path name of the segment identified by this reference name or segment number.	*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      [get_pathname ref_name]						*/
	/*									*/
	/*		or							*/
	/*									*/
	/*      [get_pathname octal_segment_no]						*/
	/*									*/
	/* To input a reference name which looks like an octal segment number:		*/
	/*									*/
	/*      [get_pathname -name octal_reference_name]					*/
	/*									*/
	/*		or							*/
	/*									*/
	/*      [get_pathname  -nm  octal_reference_name]					*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 1) Created:  Feb, 1970 by V. L. Voydock.					*/
	/* 2) Modified: Apr, 1973 by G. C. Dixon; accept octal segment numbers, add -name arg.	*/
	/* 3) Modified: 12/15/75 by Steve Herbst to be called as a command.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/**/

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


get_pathname: gpn:	procedure;

     dcl						/*	automatic variables			*/
	Larg			fixed bin,	/* length of an input argument.		*/
	Ldirectory		fixed bin,	/* length of directory part of path name.	*/
	Lentry			fixed bin,	/* length of entry part of path name.		*/
	Lret			fixed bin,	/* maximum length of return argument.		*/
	Nargs			fixed bin,	/* number of input arguments.			*/
	Parg			ptr,		/* ptr to input argument.			*/
	Pret			ptr,		/* ptr to return argument.			*/
	Pseg			ptr,		/* ptr to segment whose path name to be returned	*/
	code			fixed bin(35),	/* status code.				*/
	command			bit(1) aligned,	/* ON if called as a command.			*/
	directory			char(168) aligned,	/* directory part of path name.		*/
	entry			char(32) aligned,	/* entry part of path name.			*/
	path			char(168) aligned,	/* path name.				*/
	segno			fixed bin(35);	/* octal segment number.			*/

     dcl						/*	based variables			*/
	arg			char(Larg) based (Parg),
						/* an input argument.			*/
	ret			char(Lret) varying based (Pret);
						/* our return argument.			*/

     dcl						/* 	builtin functions			*/
         (addr, baseptr, index, mod, rtrim, substr)	builtin;


     dcl  gripe entry variable options(variable);		/* either active_fnc_err_ or com_err_		*/

     dcl						/*	entries				*/
	active_fnc_err_		entry options (variable),
	com_err_			entry options(variable),
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cu_$arg_count		entry (fixed bin, fixed bin(35)),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cv_oct_check_		entry (char(*), fixed bin(35)) returns (fixed bin(35)),
	hcs_$fs_get_path_name	entry (ptr, char(*) aligned, fixed bin, char(*) aligned, fixed bin(35)),
	hcs_$fs_get_seg_ptr		entry (char(*), ptr, fixed bin(35)),
	ioa_			entry options(variable),
	requote_string_		entry (char (*)) returns (char (*));

     dcl						/*	static variables			*/
         (error_table_$badopt,
	error_table_$bigarg,
	error_table_$invalidsegno,
	error_table_$not_act_fnc,
	error_table_$seg_unknown,
	error_table_$smallarg,
	error_table_$wrong_no_of_args)
				fixed bin(35) ext static,
	proc			char(12) aligned int static init ("get_pathname");
/**/

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


	call cu_$af_return_arg (Nargs, Pret, Lret, code);	/* get input arg count; get ptr/lng of return arg	*/
	if code=error_table_$not_act_fnc then do;	/* called as a command 			*/
	     command = "1"b;
	     gripe = com_err_;
	     call cu_$arg_count(Nargs,code);
	     code = 0;
	end;
	else do;
	     command = "0"b;
	     gripe = active_fnc_err_;
	end;
	if code ^= 0 then
	     go to error;

	if Nargs = 0 then				/* make sure we were passed 1 or 2 input args	*/
	     go to wnoa;
	if Nargs > 2 then
	     go to wnoa;

	if Nargs = 2 then do;			/* if 2 input args, then first must be a control	*/
	     call cu_$arg_ptr (1, Parg, Larg, code);	/* arg, either "-name" or "-nm".		*/
	     if arg ^= "-nm" then			/* otherwise, an error has occurred.		*/
		if arg ^= "-name" then
		     go to badopt;
	     call cu_$arg_ptr (2, Parg, Larg, code);	/* get second argument, and treat it as a	*/
	     go to get_ptr;				/* reference name, even tho it may look like a	*/
	     end;					/* segment number.				*/

						/* Only 1 argument, a reference name or segment	*/
	call cu_$arg_ptr (1, Parg, Larg, code);		/* number.  Access this argument.		*/
	if Larg = 0 then				/* make sure its not a null string.		*/
	     go to smallarg;
	segno = cv_oct_check_ (arg, code);		/* see if it is an octal segment number.	*/
	if code = 0 then do;			/* if so, convert segment number to a ptr, and	*/
	     Pseg = baseptr (segno);			/* assume this points to desired segment.	*/
	     go to get_path;
	     end;
	else do;					/* arg not an octal number, so assume it is a	*/
get_ptr:	     if Larg > 32 then			/* reference name, and convert it to a segment ptr*/
		go to bigarg;
	     call hcs_$fs_get_seg_ptr (arg, Pseg, code);
	     if code ^= 0 then
		go to seg_unknown;
	     end;

get_path:	call hcs_$fs_get_path_name (Pseg, directory, Ldirectory, entry, code);
	if code ^= 0 then				/* Convert segment ptr to a path name.  If a	*/
	     go to invalidsegno;			/* reference name was supplied as the argument,	*/
	Lentry = mod (index (entry, " ")+32, 33);	/* then this conversion must work.  Therefore, 	*/
						/* any errors indicate that a segno was supplied	*/
						/* and that there is no segment with that number.	*/
	path = substr(directory,1,Ldirectory) || ">" || substr(entry,1,Lentry);

	if command then call ioa_("^a",path);
	else ret = requote_string_ (rtrim (path));
	return;					/* return the path name as the value of the	*/
						/* active function.				*/

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


wnoa:	code = error_table_$wrong_no_of_args;		/* report errors to user.			*/
error:	Parg = addr (entry);
	Larg = 0;
printerr:	call gripe (code, (proc),
	     "  ^a^/^a:^-[^a ref_name]^/or:^3-[^a octal_segment_no]^/or:^3-[^a -name octal_ref_name]",
	     arg, "Calling sequence is", (proc), (proc), (proc));
	     return;

badopt:	code = error_table_$badopt;
	go to printerr;

smallarg:	code = error_table_$smallarg;
	go to argerr;

bigarg:	code = error_table_$bigarg;
argerr:	call gripe (code, (proc), "  ""^a""  cannot be a reference name.", arg);
	return;

seg_unknown:
	call gripe (error_table_$seg_unknown, (proc), "  ^a  is not a known reference name.", arg);
	return;

invalidsegno:
	call gripe (error_table_$invalidsegno, (proc), "  ^o", segno);
	return;

	end get_pathname;




		    path.pl1                        03/24/83  1506.6rew 03/24/83  1443.7       96489



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


path: proc;

/*	U S E F U L   A C T I V E   F U N C T I O N S .


   Adapted 11/19/72 by Robert S. Coren from code originally written
   by Max G.Smith
   Changed to work when called as commands, S. Herbst 08/31/78
   Fix [unique 0] return value 06/10/80 S. Herbst
   Short name dir added to directory 01/12/81 S. Herbst
   Taught path about archive component pathnames 07/19/81 B. Margolin
   Taught everything about archive component pathnames, added
   the component and strip_component entrypoints, fixed some incorrect
   external entry declarations (w/r/t alignedness of strings). 02/16/82
   by B. Margolin.
   Enhanced path (2-3 arg case) and added is_component_pathname and
   entry_path.  02/19/82 by B. Margolin.
   Modified path & cohorts so that a segment name with an embedded space
   will not become two separate segments.  10/15/82 Linda Pugh.
   Add shortest_path. 01/05/82 R. Harvey.

   [path  a]	The complete pathname of "a".

   [path  a  b]	The complete pathname of "b" in directory "a".

   [path  a  b  c]	The complete pathname of component "c" in segment "b"
   in directory "a".

   [directory  a]	The directory portion of the complete pathname of "a".

   [entry  a]	The entry portion of the complete pathname of "a".

   [component  a]	The archive component portion of the complete
   pathname of "a", or [entry  a] if "a" is not an archive component
   pathname.

   [entry_path  a]  The complete pathname of the segment that "a" is
   in.  The same as [path a] if "a" is not an archive component pathname.

   [shortest_path a b c] The shortest pathname of component "c" in segment "b"
   in directory "a".

   [strip  a  b]	The complete pathname of "a" with the suffix ".b"
   removed if it was present.

   [strip  a]	The complete pathname of "a" with the suffix
   removed if there was more than one component.

   [strip_entry  a  b]  Same as [entry [strip a b]].

   [strip_entry  a]	Same as [entry [strip a]].

   [strip_component  a]  Same as [strip_entry [component a]].

   [strip_component  a  b]  Same as [strip_entry [component a] b].
   
   [suffix  a]	Null if [component a] has only one component;
   otherwise, the last component.

   [is_component_pathname a] Returns "true" if a is an archive
   component pathname.

   [unique]		A 15-character unique idenifier. */

/* Declarations. */

dcl  return_ptr ptr;
dcl  return_string char (return_len) based (return_ptr) varying;
dcl  return_len fixed bin;

dcl  arg_ptr (3) ptr;
dcl  arg_len (3) fixed bin;
dcl  arg1 char (arg_len (1)) based (arg_ptr (1));
dcl  arg2 char (arg_len (2)) based (arg_ptr (2));
dcl  arg3 char (arg_len (3)) based (arg_ptr (3));

dcl (dn, pn) char (202);
dcl  char202 character (202) varying;
dcl (en, cn, who) char (32);
dcl  b36 bit (36);
dcl  af_sw bit (1);
dcl  fb35 fixed bin (35);
dcl (i, j, colon_idx, arg_count) fixed;
dcl  code fixed bin (35);

dcl  error_table_$bad_conversion fixed binary (35) external;
dcl  error_table_$not_act_fnc fixed bin (35) ext;

dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl (active_fnc_err_, active_fnc_err_$suppress_name,
     com_err_, com_err_$suppress_name, ioa_) entry options (variable);
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_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_shortest_path_ entry (char(*)) returns(char(168));
dcl  pathname_$component_check entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  unique_chars_ ext entry (bit (*)) returns (char (15));
dcl  requote_string_ entry (char(*)) returns (char(*));
dcl (addr, index, length, maxlength, reverse, rtrim, search, substr, unspec) builtin;

/* End of declarations. */
/*  */
/* Here for [path a]. */

	call setup ("path", "", 1, 3, "0"b);
	go to JOIN_SP;




/* Here for [shortest_path a]. */

shortest_path: entry;

	call setup ("shortest_path", "", 1, 3, "0"b);


JOIN_SP:	if arg_count = 1 then go to JOIN_D;		/* Simple case */

	if arg_count = 2 then call pathname_$component_check ((pn), arg2, "", pn, code);
	else call pathname_$component_check ((pn), arg2, arg3, pn, code);
	if code ^= 0 then call error (code, "Creating pathname.");
	if who = "shortest_path" then return_string = rtrim (get_shortest_path_ (pn));
	else return_string = rtrim (pn);
	go to FINISH;


	


/* Here for [directory a]. */

directory: dir: entry;

	call setup ("directory", en, 1, 1, "1"b);
	pn = dn;

JOIN_D:	if who = "shortest_path" then return_string = rtrim (get_shortest_path_ (pn));
	else return_string = rtrim (pn);

FINISH:	if ^af_sw then call ioa_ ("^a", return_string);
          else if who ^= "is_component_pathname" then;
          return_string = requote_string_ ((return_string));

RETURN:	return;





/* Here for [entry a]. */

entry:	entry;

	call setup ("entry", en, 1, 1, "1"b);
	return_string = rtrim (en);
	go to FINISH;





/* Here for [component a]. */

component: entry;

	call setup ("component", en, 1, 1, "1"b);
	if cn ^= "" then return_string = rtrim (cn);
	else return_string = rtrim (en);
	go to FINISH;





/* Here for [is_component_pathname a] */

is_component_pathname:
icpn:	entry;

	call setup ("is_component_pathname", en, 1, 1, "1"b);
	if cn = "" then return_string = "false";
	else return_string = "true";
	go to FINISH;

	


/* Here for [entry_path a] */
entry_path:
	entry;

	call setup ("entry_path", en, 1, 1, "1"b);
	call pathname_$component_check (dn, en, "", pn, code);
	if code ^= 0 then call error (code, "Forming pathname.");
	return_string = rtrim (pn);
	go to FINISH;
	





/* Here for [strip a] and [strip a b]. */

strip:	entry;

	call setup ("strip", "", 1, 2, "0"b);
	go to JOIN_R;




/* Here for [strip_component a] and [strip_component a b]. */

strip_component: spc:
	entry;

	call setup ("strip_component", en, 1, 2, "1"b);
	if cn = "" then pn = en;
	else pn = cn;
	go to JOIN_R;




/* Here for [strip_entry a] and [strip_entry a b]. */

strip_entry: spe: entry;

	call setup ("strip_entry", en, 1, 2, "1"b);
	pn = en;

JOIN_R:	if arg_count = 2 then go to TWO_ARGS;

/* Here for [strip a] and [strip_entry a]. */

	colon_idx = index (pn, "::");
	if colon_idx = 0			/* not archive */
	     then j = length (pn) + 1 - search (reverse (pn), ".>");
	else j = length (pn) + 1 - 
	     index (reverse (substr (pn, colon_idx + 2)), ".");
	if j = length (pn) + 1 | j = 1 | substr (pn, j, 1) = ">" then return_string = rtrim (pn);
	else return_string = substr (pn, 1, j - 1);
	go to FINISH;

/* Here for [strip a b] and [strip_entry a b]. */

TWO_ARGS:	i = length (rtrim (pn));
	return_string = rtrim (pn);
	if i > arg_len (2) then
	     if substr (pn, i - arg_len (2)) = "." || arg2 then
		return_string = substr (pn, 1, i - arg_len (2) - 1);
	go to FINISH;





/* Here for [suffix a]. */

suffix:	entry;

	call setup ("suffix", en, 1, 1, "1"b);
	if cn ^= "" then en = cn;
	i = 33-index (reverse (en), ".");
	if i = 33 then return_string = "";
	else if i >= length (rtrim (en)) then return_string = "";
	else return_string = rtrim (substr (en, i+1));
	go to FINISH;





/* Here for [unique]. */

unique:	entry;

	who = "unique";
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     return_ptr = addr (char202);
	     return_len = 202;
	end;
	else af_sw = "1"b;
	if arg_count ^= 0 then do;
	     if arg_count ^= 1 then do;
		if af_sw then call active_fnc_err_$suppress_name
		     (0, "unique", "Usage:  [unique {octal_number}]");
		else call com_err_$suppress_name (0, "unique", "Usage:  unique {octal_number}");
		go to RETURN;
	     end;
	     call cu_$arg_ptr (1, arg_ptr (1), arg_len (1), code);
	     fb35 = cv_oct_check_ (arg1, code);
	     if code ^= 0 then do;
		call error (error_table_$bad_conversion, (arg1));
	     end;
	     if fb35 = 0 then do;
		return_string = "!BBBBBBBBBBBBBB";
		go to FINISH;
	     end;
	     b36 = unspec (fb35);
	end;
	else b36 = ""b;
	return_string = unique_chars_ (b36);
	go to FINISH;




setup:	proc (string, a_en, min_arg, max_arg, ret);

/* Internal function to..
   (1)  Set the name of the active function in 'who'.
   (2)  Verify that there are the proper number of arguments
    (as defined by min_arg and max_arg).
   (3)  Expand the first argument into the parts of a full pathname.
   (4) If ret is set, then put the entryname in a_en, the output
    argument, else set pn to the the full pathname.

   (yes, I know this interface is horrible, but that's the way I
    found it, and I didn't feel like rewriting it -- Barmar)
 */


dcl  string char (*);
dcl  a_en char (*);
dcl  en char (32);
dcl  (min_arg, max_arg) fixed bin;
dcl  ret bit (1);	/* should we return a value? */

	     who = string;
	     call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	     if code = error_table_$not_act_fnc then do;
		af_sw = "0"b;
		return_ptr = addr (char202);
		return_len = maxlength (char202);
	     end;
	     else af_sw = "1"b;

	     if arg_count < min_arg | arg_count > max_arg then do;
		if af_sw then call active_fnc_err_$suppress_name (0, string,
		     "Usage:  [^a ^[path^;path {string}^;path {string1 {string2}}^]]",
		     string, max_arg);
		else call com_err_$suppress_name (0, string,
		     "Usage:  ^a ^[path^;path {string}^;path {string1 {string2}}^]",
		     string, max_arg);
		go to RETURN;
	     end;

/* pick up input args  */

	     do i = 1 to arg_count;
		call cu_$arg_ptr (i, arg_ptr (i), arg_len (i), code);
		if code ^= 0 then
BAD_ARGS:		     call error (code, "");
	     end;
	     call expand_pathname_$component (arg1, dn, en, cn, code);
	     if code ^= 0 then call error (code, (arg1));
	     if ^ret then do;
		call pathname_$component_check (dn, en, cn, pn, code);
		if code ^= 0 then call error (code, (arg1));
		end;
	     else a_en = en;

	end setup;




error:	proc (acode, string);

/* Internal procedure to print error messages and exit */

dcl  acode fixed bin (35), string char (*);

	     if af_sw then call active_fnc_err_ (acode, who, string);
	     else call com_err_ (acode, who, string);
	     go to RETURN;

	end error;

     end path;




		    process_dir.pl1                 07/05/88  1415.6rew 07/05/88  1358.6       35865



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




/****^  HISTORY COMMENTS:
  1) change(88-04-28,TLNguyen), approve(88-04-28,MCR7839),
     audit(88-05-04,Lippard), install(88-07-05,MR12.2-1054):
     Remove the working_dir entry from the source, process_dir.pl1.  This entry
     is combined with the print_wdir entry for the purpose of identical
     operation.  For more details, see MTB 775.
                                                   END HISTORY COMMENTS */


process_dir:
pd: procedure options (variable);

/* initially coded in February 1970 by V Voydock */
/* Modified 12/15/75 by Steve Herbst to be callable as a command */
/* Modified 06/09/78 by W. Olin Sibert to add dwd function */
/* Modified 06/07/80, W. Olin Sibert, to reject arguments, and for wd to treat no wdir as error. */
/* Modified 10/15/82, Linda Pugh, to requote return arg, in case directory
   name contains a space. */

dcl  dirname char (168) aligned;
dcl  return_arg char (rl) varying based (rp);
dcl  rp ptr;
dcl (argcount, lng, rl) fixed bin;
dcl  af_sw bit (1) aligned;
dcl  complain entry variable options (variable);
dcl  code fixed bin (35);
dcl  whoami char (32);

dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  get_pdir_ entry () returns (char (168));
dcl  get_default_wdir_ entry () returns (char (168));
dcl  hcs_$fs_search_get_wdir entry (ptr, fixed bin);
dcl  ioa_ entry options (variable);
dcl  requote_string_ entry (char(*)) returns (char(*));
dcl  user_info_$homedir entry (char (*) aligned);

dcl (error_table_$not_act_fnc,
     error_table_$no_wdir,
     error_table_$too_many_args) fixed bin (35) external static;

dcl (PROCESS_DIR	init ("process_dir"),
     WORKING_DIR	init ("working_dir"),
     HOME_DIR	init ("home_dir"),
     DEFAULT_WDIR	init ("default_wdir")) char (32) internal static options (constant);

dcl (addr, reverse, substr, verify) builtin;

/*  */

/* process_dir: pd: entry options (variable); */

	whoami = PROCESS_DIR;
	goto COMMON;


home_dir:
hd: entry options (variable);

	whoami = HOME_DIR;
	goto COMMON;


default_wdir:
dwd: entry options (variable);

	whoami = DEFAULT_WDIR;
	goto COMMON;


COMMON:	call cu_$af_return_arg (argcount, rp, rl, code);
	if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     complain = com_err_;
	     end;
	else do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	     return_arg = "";
	     end;

	if argcount ^= 0 then do;
	     call complain (error_table_$too_many_args, whoami, "No arguments are permitted.");
	     return;
	     end;

	dirname = "";

	if whoami = PROCESS_DIR then
	     dirname = get_pdir_ ();

	else if whoami = HOME_DIR then
	     call user_info_$homedir (dirname);

	else if whoami = DEFAULT_WDIR then
	     dirname = get_default_wdir_ ();

	else do;					/* only one left is WORKING_DIR */
	     call hcs_$fs_search_get_wdir (addr (dirname), lng);
	     if lng = 0 then do;			/* no wdir.... */
		call complain (error_table_$no_wdir, whoami);
		return;
		end;

	     else if lng < maxlength (dirname) then	/* trim off spaces */
		substr (dirname, lng + 1) = "";
	     end;

	if af_sw then 
               return_arg = requote_string_ (rtrim(dirname));

	else call ioa_ ("^a", dirname);

	return;
	end process_dir;




		    select.pl1                      11/04/82  1934.3rew 11/04/82  1618.5       36459



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


/* BSG 1/15/80
   Cleaned up for installation, 23 December 1980, M. N. Davidoff.
*/
/* format: style2 */
select:
     procedure options (variable);

/* automatic */

	dcl     afargl		 fixed bin (21);
	dcl     afargp		 ptr;
	dcl     afsw		 bit (1) aligned;
	dcl     argl		 fixed bin (21);
	dcl     argp		 ptr;
	dcl     code		 fixed bin (35);
	dcl     err		 entry options (variable) variable;
	dcl     err_suppress_name	 entry options (variable) variable;
	dcl     first		 bit (1) aligned;
	dcl     i			 fixed bin;
	dcl     nargs		 fixed bin;
	dcl     torf		 char (1500) varying;
	dcl     vargl		 fixed bin (21);
	dcl     vargp		 ptr;

/* based */

	dcl     afarg		 char (afargl) based (afargp);
	dcl     arg		 char (argl) based (argp);
	dcl     varg		 char (vargl) varying based (vargp);

/* builtin */

	dcl     null		 builtin;

/* internal static */

	dcl     command		 char (6) internal static options (constant) initial ("select");

/* external static */

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

/* entry */

	dcl     active_fnc_err_	 entry options (variable);
	dcl     active_fnc_err_$af_suppress_name
				 entry options (variable);
	dcl     com_err_		 entry options (variable);
	dcl     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_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cu_$evaluate_active_string
				 entry (ptr, char (*), fixed bin, char (*) varying, fixed bin (35));
	dcl     ioa_$nnl		 entry options (variable);
	dcl     requote_string_	 entry (char (*)) returns (char (*));

%include cp_active_string_types;

/* program */

	call cu_$af_return_arg (nargs, vargp, vargl, code);
	if code = 0
	then do;
		afsw = "1"b;
		err = active_fnc_err_;
		err_suppress_name = active_fnc_err_$af_suppress_name;
		varg = "";
	     end;
	else if code = error_table_$not_act_fnc
	then do;
		afsw = "0"b;
		err = com_err_;
		err_suppress_name = com_err_$suppress_name;
	     end;
	else do;
		call com_err_ (code, command);
		return;
	     end;

	if nargs = 0
	then do;
		call err_suppress_name (0, command, "Usage: ^[[^]^a test_string {args}^[]^]", afsw, command, afsw);
		return;
	     end;

	call cu_$arg_ptr (1, afargp, afargl, code);
	if code ^= 0
	then do;
		call err (code, command, "Argument 1.");
		return;
	     end;

	first = "1"b;
	do i = 2 to nargs;
	     call cu_$arg_ptr (i, argp, argl, code);
	     if code ^= 0
	     then do;
		     call print_before_error;
		     call err (code, command, "Argument ^d.", i);
		     return;
		end;

	     call cu_$evaluate_active_string (null, afarg || " " || requote_string_ (arg), NORMAL_ACTIVE_STRING, torf, code)
		;
	     if code ^= 0
	     then do;
		     call print_before_error;
		     call err (code, command, "[^a ^a]", afarg, requote_string_ (arg));
		     return;
		end;

	     if torf = "true"
	     then do;
		     if afsw
		     then do;
			     if ^first
			     then varg = varg || " ";

			     varg = varg || requote_string_ (arg);
			end;
		     else call ioa_$nnl ("^[^x^]^a", ^first, arg);

		     first = "0"b;
		end;
	     else if torf ^= "false"
	     then do;
		     call print_before_error;
		     call err (0, command, "Test result for argument ^d (^a) is neither ""true"" nor ""false"". ^a", i,
			requote_string_ (arg), requote_string_ ((torf)));
		     return;
		end;
	end;

	if ^afsw
	then call ioa_$nnl ("^/");

	return;

print_before_error:
     procedure;

	if ^afsw & ^first
	then call ioa_$nnl ("^/");
     end print_before_error;

     end select;




		    severity.pl1                    11/04/82  1934.3rew 11/04/82  1606.3       46323



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

/* SEVERITY - Command/Active Function to return the value (as a char string)
   of an external static severity value.

   Designed by Webber, Written 770729 by Green
   Modified 770914 by PG to restrict to just FORTRAN and PL/I for MR6.0 version
   Modified 4/80 by Michael R. Jordan to use get_external_variable_
   Modified 5/13/82 by L. Baldwin to fix the short name for -default to -dft.
*/

severity:
     procedure options (variable);

/* automatic */

declare  active_function bit (1) aligned,
         arg_length fixed bin (21),
         arg_num fixed bin,
         arg_ptr ptr,
         argument_routine entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable,
         code fixed bin (35),
         default_arg_length fixed bin (21),
         default_arg_ptr ptr,
         error_routine entry options (variable) variable,
         n_args fixed bin,
         return_length fixed bin (21),
         return_ptr ptr,
         severity_string picture "-----------9",		/* room for sign + 11 digits */
         severity_value fixed bin (35),
         vdesc_ptr ptr,
         var_ptr ptr,
         var_size fixed bin (19);

/* based */

declare  arg_string char (arg_length) based (arg_ptr),
         default_arg_string char (default_arg_length) based (default_arg_ptr),
         return_value char (return_length) varying based (return_ptr),
         severity_variable fixed bin (35) based (var_ptr);

/* builtins */

declare  ltrim builtin;

/* entries */

declare  active_fnc_err_ entry options (variable),
         com_err_ entry options (variable),
         cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
         cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
         cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
         get_external_variable_ entry (char (*), ptr, fixed bin (19), ptr, fixed bin (35)),
         ioa_ entry options (variable);

/* external static */

declare (error_table_$badopt,
         error_table_$noarg,
         error_table_$not_act_fnc) fixed bin (35) external static;

/* internal static */

declare  my_name char (8) internal static init ("severity") options (constant);

/* program */

	call cu_$af_return_arg (n_args, return_ptr, return_length, code);
	if code = 0
	then do;					/* called as active function */
	     error_routine = active_fnc_err_;
	     argument_routine = cu_$af_arg_ptr;
	     active_function = "1"b;
	     return_value = "";			/* in case we get started after an error */
	end;
	else if code = error_table_$not_act_fnc		/* called as command */
	then do;
	     error_routine = com_err_;
	     argument_routine = cu_$arg_ptr;
	     active_function = "0"b;
	end;
	else do;
	     call com_err_ (code, my_name, "");
	     return;
	end;
	if n_args = 0
	then do;
	     call error_routine (error_table_$noarg, my_name, "^/Usage: severity indicator_name {-default STR}");
	     return;
	end;

	default_arg_ptr = null ();
	do arg_num = 2 repeat arg_num+1 while (arg_num <= n_args);
	     call argument_routine (arg_num, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		call error_routine (code, my_name, "Unable to access argument #^d.", arg_num);
		return;
	     end;
	     if arg_string = "-default" | arg_string = "-dft"
	     then do;
		if arg_num = n_args
		then do;
		     call error_routine (error_table_$noarg, my_name, "Default string missing following ^a.", arg_string);
		     return;
		end;
		arg_num = arg_num+1;
		call argument_routine (arg_num, default_arg_ptr, default_arg_length, code);
		if code ^= 0
		then do;
		     call error_routine (code, my_name, "Unable to access default string argument.");
		     return;
		end;
	     end;
	     else do;
		call error_routine (error_table_$badopt, my_name, "^a", arg_string);
		return;
	     end;
	end;

	call argument_routine (1, arg_ptr, arg_length, code);
	if code ^= 0
	then do;
	     call error_routine (code, my_name, "Unable to access argument #1.");
	     return;
	end;

	call get_external_variable_ (arg_string || "_severity_", var_ptr, var_size, vdesc_ptr, code);
	if code ^= 0
	then do;
	     if default_arg_ptr = null ()
	     then do;
		call error_routine (code, my_name,
		     "^/Error accessing severity indicator ^a.", arg_string);
		return;
	     end;
	     if active_function
	     then return_value = default_arg_string;
	     else call ioa_ ("^a", default_arg_string);
	     return;
	end;

	if var_size ^= 1
	then do;
	     call error_routine (0b, my_name, "The severity indicator ^a is not a single word variable.", arg_string);
	     return;
	end;

	severity_value = severity_variable;
	severity_string = severity_value;		/* convert to pictured form */

	if active_function
	then return_value = ltrim (severity_string);
	else call ioa_ ("^a", ltrim (severity_string));

	return;

     end severity;




		    underline.pl1                   11/04/82  1934.3rew 11/04/82  1618.6       48870



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


underline:	procedure;			/* active function which returns its input args,	*/
						/* separated by blanks and underlined, as a 	*/
						/* quoted string.				*/

     dcl						/*	automatic variables			*/
	Larg			fixed bin,	/* length of an input arg.			*/
	Lcom			fixed bin,	/* length of command's output string.		*/
	Lret			fixed bin,	/* maximum length of our return value.		*/
	Nargs			fixed bin,	/* number of arguments we were passed.		*/
	Parg			ptr,		/* ptr to an input argument.			*/
	Parg_list			ptr,		/* ptr to caller's argument list.		*/
	Pret			ptr,		/* ptr to our return value.			*/
	code			fixed bin (35),	/* an error code value.			*/
	i			fixed bin;	/* a do-group index.			*/


     dcl						/*	based variables			*/
	arg_array (Larg)		char(1) based (Parg),
						/* an input argument.			*/
	arg_char			char(1) based (Parg),
						/* next char of our input argument.		*/
	ret			char(Lret) varying based (Pret);
						/* overlay for portions of our return value.	*/


     dcl (addr, length, substr)	builtin;


     dcl						/*	entries				*/
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cu_$arg_count		entry returns (fixed bin),
	cu_$arg_list_ptr		entry returns (ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin, fixed bin(35), ptr),
	iox_$put_chars		entry (ptr, ptr, fixed bin, fixed bin(35));


     dcl						/*	static variables			*/
	BS_UNDERSCORE		char(2) aligned int static options(constant) init ("_"),
	NL			char(1) aligned int static options(constant) init ("
"),
	QUOTE			char(1) aligned int static options(constant) init (""""),
	QUOTE_QUOTE		char(2) aligned int static options(constant) init (""""""),
	SPACE			char(1) aligned int static options(constant) init (" "),
	UNDERSCORE_BS		char(2) aligned int static options(constant) init ("_"),
	iox_$user_output		ptr ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	call cu_$af_return_arg (Nargs, Pret, Lret, code);	/* see how we were called.			*/
	if code = 0 then do;			/* as an active function.			*/
	     if Nargs = 0 then do;			/* no input args.  Return a null string.	*/
		ret = QUOTE_QUOTE;
		return;
		end;
	     ret = QUOTE;
	     do i = 1 to Nargs;			/* add args to return string one by one.		*/
		call cu_$arg_ptr (i, Parg, Larg, code);
		do while (Larg > 0);		/* double any quotes while copying arg.		*/
		     if      arg_char < SPACE then
		          ret = ret || arg_char;
		     else if arg_char = SPACE then
		          ret = ret || "_";		/* convert spaces to _s.			*/
		     else if arg_char = QUOTE then do;	/* double quotes as we go. (""_)		*/
		          ret = ret || QUOTE_QUOTE;
		          ret = ret || BS_UNDERSCORE;
		          end;
		     else if arg_char < "_" then do;
		          ret = ret || arg_char;	/* canonicalize the string as we go.		*/
		          ret = ret || BS_UNDERSCORE;
		          end;
		     else if arg_char > "_" then do;
		          ret = ret || UNDERSCORE_BS;
		          ret = ret || arg_char;
		          end;
		     else
		          ret = ret || "_";
		     if Larg > 1 then Parg = addr(arg_array(2));
		     Larg = Larg - 1;
		     end;
		ret = ret || SPACE;			/* separate args by a space in output string.	*/
		end;
	     if substr(ret,length(ret)) = SPACE then	/* remove space after last argument.		*/
		ret = substr(ret,1,length(ret)-1);
	     ret = ret || QUOTE;
	     end;
	else do;					/* command merely output's its args, separated by	*/
	     Nargs = cu_$arg_count();			/* blanks.				*/
	     Lcom = 0;				/* compute max length of output string.		*/
	     do i = 1 to Nargs;
		call cu_$arg_ptr(i, Parg, Larg, code);
		Lcom = Lcom + Larg*3 + 1;
		end;
	     if Nargs > 0 then do;
		Parg_list = cu_$arg_list_ptr();
begin;
     dcl	com			char(Lcom) varying aligned init ("");
		do i = 1 to Nargs;
		     call cu_$arg_ptr_rel (i, Parg, Larg, code, Parg_list);
		     do while (Larg > 0);		/* no doubling of quotes needed here.		*/
			if      arg_char < SPACE then
			     com = com || arg_char;
			else if arg_char = SPACE then
			     com = com || "_";	/* convert spaces to _s.			*/
			else if arg_char < "_" then do;
			     com = com || arg_char;	/* canonicalize the string as we go.		*/
			     com = com || BS_UNDERSCORE;
			     end;
			else if arg_char > "_" then do;
			     com = com || UNDERSCORE_BS;
			     com = com || arg_char;
			     end;
			else
			     com = com || "_";
			if Larg > 1 then Parg = addr(arg_array(2));
			Larg = Larg - 1;
			end;
		     com = com || " ";
		     end;
		if substr(com,length(com)) = SPACE then	/* remove space after last argument.		*/
		     com = substr(com,1,length(com)-1);
		call iox_$put_chars (iox_$user_output, addr(substr(com,1)), length(com), code);
	end;
		end;
	     call iox_$put_chars (iox_$user_output, addr(NL), 1, code);
	     end;

	end underline;






		    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