



		    add_search_rules.pl1            01/19/88  1553.4rew 01/19/88  1529.8      118629



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



/****^  HISTORY COMMENTS:
  1) change(85-09-18,Spitzer), approve(85-09-18,MCR7272),
     audit(85-12-05,Lippard), install(85-12-16,MR12.0-1001):
     Fix error msgs for delete_search_rules.
  2) change(85-12-17,GDixon), approve(85-12-17,PBF7272),
     audit(85-12-17,Martinson), install(85-12-17,MR12.0-1002):
     Change test to look for non-control-arg instead of a control arg.
  3) change(87-11-05,Lippard), approve(87-11-23,MCR7797),
     audit(88-01-13,GWMay), install(88-01-19,MR12.2-1016):
     Added -no_force, -inhibit_error, -no_inhibit_error.
                                                   END HISTORY COMMENTS */

/* format: off */
add_search_rules: asr: proc;

/* written around August 1972 by C. D. Tavares */
/* Modified April 7, 1973 by C. D. Tavares to add keyword handling and
   prepare for AML submission */
/* Modified 4/13/76 by Steve Herbst */
/* Changed for installation-modifiable keywords 8/76 THVV */
/* Short control arg names -be/-before -af/-after added 09/28/79 S. Herbst */
/* Add -force and remain silent if already in intended position 03/09/81 S. Herbst */

/* Usage is 'add_search_rules pathname (-before or -after pathname2) pathname3 etc...
   Rules are added to end of current search rules unless followed by -after or -before,
   when they will be put after or before the next (existing) search rule.
   Since the rule matching is done by directory unique ID, there is no need to
   type in the rule exactly as hardcore remembers it. Relative pathnames are acceptable. */

dcl  nargs fixed bin,
     explanation char (168) aligned,
     ioa_$rsnnl ext entry options (variable),
     ref_rule char (168) aligned,
     argno fixed bin,
     error_gotten bit (1) aligned initial (""b),
     rule_ids (21) bit (36) aligned,
     new_id bit (36),
    (force_sw, inhibit_err_sw, namedup_sw) bit (1),
     namedup_index fixed,
     after fixed bin,
    (i, j) fixed bin,
     cu_$arg_count ext entry returns (fixed bin),
     (com_err_, com_err_$suppress_name) entry options (variable),
     cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin(21), fixed bin(35)),
     ap pointer,
     al fixed bin (21),
     code fixed bin (35),
     absolute_pathname_ ext entry (char (*), char (*) aligned, fixed bin (35)),
    (addr, hbound, index, null, substr) builtin,
     new_rule char (168) aligned,
     get_pdir_ entry () returns (char (168) aligned),
     user_info_$homedir entry (char (*) aligned),
     hcs_$status_long ext entry (char (*) aligned, char (*), fixed bin, ptr, ptr, fixed bin (35)),
     hcs_$get_search_rules ext entry (pointer),
     hcs_$get_system_search_rules entry (ptr, fixed bin (35)),
    (error_table_$too_many_sr,
     error_table_$no_s_permission,
     error_table_$name_not_found,
     error_table_$badopt,
     error_table_$namedup) ext fixed bin (35),
     place fixed bin,
     arg char (al) based (ap),
     hcs_$initiate_search_rules ext entry (pointer, fixed bin(35)),
     myname char (32);

%include branch_status;
%include system_dft_sr;
%include search_rule_flags;

dcl 1 system_rules aligned like dft_sr_arg;

dcl 1 myrules aligned,
    2 number_of_rules fixed bin,
    2 rules (21) char (168);

	myname = "add_search_rules";
	nargs = cu_$arg_count ();
	if nargs = 0 then do;			/* user probably wants instructions */
usage_error:   call com_err_$suppress_name (0, myname,
		"Usage:  ^a path1 {-before path2} {-after path2} etc.", myname);
	     return;
	end;

	call setup;				/* get current search rules and initialize environment */

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

setup:	proc;					/* this initializes our data structure */

	     call hcs_$get_system_search_rules (addr (system_rules), (0));
	     call hcs_$get_search_rules (addr (myrules));

	     do i = 1 to number_of_rules;
		rule_ids (i) = ""b;			/* so we don't garbage out */
		call hcs_$status_long (myrules.rules (i), "", 1, addr (branch_status), null, code);
		if (code = 0 | code = error_table_$no_s_permission)
		then rule_ids (i) = branch_status.unique_id; /* unique id is ok */
		else do;
		     do j = 1 to hbound (search_rule_names, 1); /* it may be a keyword */
			if myrules.rules (i) = search_rule_names (j) then do;
			     substr (rule_ids (i), j, 1) = "1"b; /* give it a "unique" id */
			     go to nxrule;
			end;
		     end;
		end;
nxrule:	     end;


	end setup;

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

	force_sw, inhibit_err_sw = "0"b;
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, ap, al, code);
	     if arg = "-force" | arg = "-fc" then force_sw = "1"b;  /* it's global */
	     else if arg = "-no_force" | arg = "-nfc" then force_sw = "0"b;
	     else if arg = "-inhibit_error" | arg = "-ihe" then inhibit_err_sw = "1"b;
	     else if arg = "-no_inhibit_error" | arg = "-nihe" then inhibit_err_sw = "0"b;
	end;

	argno = 0;

another:						/* to process next arg */
	argno = argno + 1;
	call get_and_validate (new_rule, all_done, new_id, error); /* setup next arg */

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

get_and_validate: proc (which_rule, no_arg_label, which_id, error_label);
						/* gets unique ID of next arg and processes errors, etc */

dcl  which_rule char (*) aligned,
     which_id bit (36),
     error_label label,
     no_arg_label label;

start_gav:					/* for false starts */
	     call cu_$arg_ptr (argno, ap, al, code);	/* get next arg */
	     if code ^= 0 then go to no_arg_label;	/* no arg */

	     if index (arg, "-") = 1 then
		if arg = "-before" | arg = "-be" | arg = "-after" | arg = "-af" then
		     if error_gotten then do;
			argno = argno+2;
			error_gotten = "0"b;
			go to start_gav;
		     end;
		     else go to usage_error;
		else if arg = "-force" | arg = "-fc" | arg = "-no_force" | arg = "-nfc"
		     | arg = "-inhibit_error" | arg = "-ihe" | arg = "-no_inhibit_error" | arg = "-nihe" then do;
		     argno = argno + 1;
		     go to start_gav;
		end;
		else go to bad_option;

	     if arg = "process_dir" then which_rule = get_pdir_ ();
	     else if arg = "home_dir" then call user_info_$homedir (which_rule);
	     else do;
		call absolute_pathname_ (arg, which_rule, code);
		if code ^= 0 then do;		/* hmmm */
		     explanation = arg;
		     go to error_label;
		end;
	     end;

	     call hcs_$status_long (which_rule, "", 1, addr (branch_status), null, code); /* get unique id of dir */

	     if code ^= 0 & code ^= error_table_$no_s_permission then do;

		which_id = ""b;			/* check for keywords */
		do i = 1 to 3;
		     if search_rule_names (i) = arg then do; /* matches */
			substr (which_id, i, 1) = "1"b; /* generate our "unique" id for matching */
			which_rule = search_rule_names (i); /* this is the string we want */
			return;
		     end;
		end;
		do i = 1 to system_rules.ntags;
		     if system_rules.tags (i).name = arg then do;
			which_rule = arg;		/* can introduce dupe by this path. always could */
			return;
		     end;
		end;

		explanation = which_rule;		/* pathname not found */
		go to error_label;
	     end;

	     which_id = branch_status.unique_id;	/* we have valid dir, return its id */

	     return;

	end get_and_validate;

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

	if number_of_rules = hbound (rule_ids, 1) then do;  /* can't add another */
	     code = error_table_$too_many_sr;
	     go to error_fin;
	end;

	error_gotten = ""b;				/* none yet */
	namedup_sw = ""b;

	do i = 1 to number_of_rules;			/* hardcore accepts duplications, but we won't */
	     if (rule_ids (i) = new_id & new_id ^= ""b) | myrules.rules (i) = new_rule then do; /* rule already there */
		if force_sw then do;		/* delete the old occurrence */
		     number_of_rules = number_of_rules - 1;
		     do i = i to number_of_rules;
			myrules.rules (i) = myrules.rules (i + 1);
			rule_ids (i) = rule_ids (i + 1);
		     end;
		end;
		else do;				/* complain later if not intended for same place */
		     namedup_sw = "1"b;
		     namedup_index = i;
		end;
	     end;
	end;

next_arg:
	argno = argno + 1;				/* see if there is a position option */
	call cu_$arg_ptr (argno, ap, al, code);
	if code ^= 0 then do;			/* no more args */
one_string:					/* add this one to end */
	     if namedup_sw then
		if namedup_index = number_of_rules then go to all_done;  /* already in right place */
		else do;
namedup_error:	   if ^inhibit_err_sw then do;
		      code = error_table_$namedup;
		      call ioa_$rsnnl ("^a already elsewhere in search path.", explanation, 0, new_rule);
		      go to error;
		      end;
		   end;

	     place = number_of_rules + 1;
	     argno = argno - 1;			/* so we will finish when we try */
	     go to simple_add;
	end;

	if index (arg, "-") ^= 1 then go to one_string;	/* not an option, add last arg to end */
	else if arg = "-force" | arg = "-fc" then go to next_arg;
	else if arg = "-no_force" | arg = "-nfc" then go to next_arg;
	else if arg = "-inhibit_error" | arg = "-ihe" then go to next_arg;
	else if arg = "-no_inhibit_error" | arg = "-nihe" then go to next_arg;
	else if arg = "-before" | arg = "-be" then after = 0;
	else if arg = "-after" | arg = "-af" then after = 1;
	else do;					/* and yell if neither */
bad_option:    call com_err_ (error_table_$badopt, myname, "^a", arg);
	     return;
	end;

	explanation = "";
	argno = argno + 1;				/* if we are here, we have had a position option */
	call get_and_validate (ref_rule, error, branch_status.unique_id, error); /* get what we are supposed to add after or before */

	do i = 1 to number_of_rules;			/* search for it */
	     if rule_ids (i) = branch_status.unique_id & branch_status.unique_id ^= ""b then go to found_ref; /* unique id's match */
	     if myrules.rules (i) = ref_rule then go to found_ref; /* pathnames match */
	end;

	code = error_table_$name_not_found;		/* not there, can't add before or after it */
	call ioa_$rsnnl ("^a is not in search path.", explanation, 0, ref_rule);
	go to error;

found_ref:
	if namedup_sw then
	     if after = 0 /* -before */ then
		if namedup_index = i - 1 then go to another;  /* already there; remain silent */
		else go to namedup_error;
	     else if namedup_index = i + 1 then go to another;  /* remain silent */
		else go to namedup_error;

	place = i + after;				/* ordinal number for new rule */

	do i = number_of_rules to place by -1;		/* move all the others up one */
	     myrules.rules (i+1) = myrules.rules (i);
	     rule_ids (i+1) = rule_ids (i);		/* so we don't lose track of correspondence */
	end;

simple_add:
	myrules.rules (place) = new_rule;		/* put it in */
	rule_ids (place) = new_id;
	number_of_rules = number_of_rules + 1;

	go to another;				/* and do it again! */

error:	call com_err_ (code, myname, explanation);	/* make user feel bad */
	error_gotten = "1"b;			/* to skip any following "-after" or "-before" */
	go to another;				/* do it again */

error_fin: call com_err_ (code, myname, "While processing ^a", new_rule); /* bad error, give up */
all_done:
	call hcs_$initiate_search_rules (addr (myrules), code); /* hand them to hardcore */
	if code ^= 0 then call com_err_ (code, myname);	/* hardcore ungrateful */

	return;

delete_search_rules: dsr: entry;

	myname = "delete_search_rules";
	nargs = cu_$arg_count ();
	if nargs = 0 then do;			/* user wants explanation, probably */
	     call com_err_$suppress_name (0, myname,
		"Usage:  ^a paths", myname);
	     return;
	end;

	call setup;				/* get present rules */

	do argno = 1 to nargs;			/* thru all args */

	     call get_and_validate (ref_rule, del_error, branch_status.unique_id, del_error); /* set up for id match */

	     do i = 1 to number_of_rules;		/* find it */
		if rule_ids (i) = branch_status.unique_id & branch_status.unique_id ^= ""b then go to del_rule; /* id's match */
		if myrules.rules (i) = ref_rule then go to del_rule; /* pathnames match */
	     end;

	     code = error_table_$name_not_found;	/* isn't in search rules */
	     call ioa_$rsnnl ("^a not in search path.", explanation, 0, ref_rule);
del_error:     call com_err_ (code, myname, explanation);	/* yell at user again */
	     go to endloop;

del_rule:	     do i = i to number_of_rules - 1;		/* scruntch them all down */
		myrules.rules (i) = myrules.rules (i+1);
		rule_ids (i) = rule_ids (i+1);
	     end;

	     number_of_rules = number_of_rules - 1;	/* one away */

endloop:	end;					/* until we are all done */

	go to all_done;

     end add_search_rules;




		    get_system_search_rules.pl1     11/04/82  1909.0rew 11/04/82  1613.6       14418



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


get_system_search_rules: gssr: proc;

/* get_system_search_rules - get current default search rules and keywords.

   Written by THVV 7/76 */

	xsp = addr (temp);				/* Initialization. Find input structure for hardcore */
	call hcs_$get_system_search_rules (addr (temp), ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, "get_system_search_rules", "");
	     return;
	end;

	do i = 1 to dft_sr_arg.nrules;
	     line = dft_sr_arg.rules (i).name;
	     do j = 1 to dft_sr_arg.ntags;
		if (dft_sr_arg.rules (i).flag & dft_sr_arg.tags (j).flag) ^= "0"b then do;
		     k = length (line) + 2 - verify (reverse (line), " ");
		     substr (line, k) = ", " || dft_sr_arg.tags (j).name;
		end;
	     end;
	     call ioa_ ("^a", line);
	end;

	return;					/* All done */

dcl  ec fixed bin (35);
dcl (i, j, k) fixed bin,
     line char (256);

dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  hcs_$get_system_search_rules entry (ptr, fixed bin (35));

dcl  null builtin;

dcl 1 temp aligned like dft_sr_arg;

%include system_dft_sr;

     end get_system_search_rules;




		    parse_search_rules_.pl1         11/04/82  1909.0rew 11/04/82  1613.7       69165



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


parse_search_rules_: proc (a_dirname, a_ename, a_caller, a_pointer, a_code);

/* This proceedure sets up pointers corresponding to the path names
   found in the search rule segment.  It also verifies that the
   segments so initiated is a directory. */

dcl (a_dirname, a_ename, a_caller) char (*);

dcl  a_pointer ptr;

dcl  a_code fixed bin (35);
dcl  code fixed bin (35);
dcl  bitcnt fixed bin (24);
dcl  cc fixed bin;					/* segment character count */
dcl  tcc fixed bin;					/* total character count */
dcl  bn fixed bin;					/* count to next blank */
dcl  nln fixed bin;					/* count to nex new link */
dcl  ncl fixed bin;					/* number of characters left */
dcl  size fixed bin;				/* size of search rule name */
dcl  blank_flag fixed bin;				/* =1 if no more blanks in seg */
dcl  src fixed bin;					/* search rule counter */
dcl  ii fixed bin;
dcl  i fixed bin;

dcl  type fixed bin (2);

dcl (dname, dir, path) char (168),
    (ename, entry, caller) char (32),
     subname char (12),
     string char (ncl) based,
     ch (2) char (1) based unaligned;

dcl  nl char (1) static options (constant) init ("
"),
     blank char (1) static options (constant) init (" ");

dcl 1 sr based aligned,				/* output name structure */
    2 number fixed bin,
    2 name (22) char (168);

dcl (ptr, pptr, dirp, enp,
     sp, srptr) ptr;
dcl  segp ptr init (null);

dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2),
     fixed bin (24), fixed bin (35));
dcl  hcs_$get_system_search_rules entry (ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2),
     ptr, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));

dcl (error_table_$notadir,
     error_table_$argerr) ext fixed bin (35);

%include system_dft_sr;
%include search_rule_flags;

dcl 1 system_rules like dft_sr_arg aligned;

dcl  null builtin;

	dirp = addr (dir);				/* initiate some pointers */
	enp = addr (entry);
	code, blank_flag = 0;
	dname = a_dirname;				/* copy args */
	ename = a_ename;
	caller = a_caller;
	srptr = a_pointer;
	call hcs_$status_minf (dname, ename, 1, type, bitcnt, code);
	if code ^= 0 then do;
	     call com_err_ (code, caller, " ^a>^a", dname, ename);
	     go to fin;
	end;
	if type ^= 1 then do;			/* this is not a data segment */
	     code = error_table_$argerr;
	     call com_err_ (code, caller, "^/ ^a>^a  is not a search segment ", dname, ename);
	     go to fin;
	end;
	if bitcnt = 0 then go to search_rule_err;
	call hcs_$initiate (dname, ename, "", 0, 1, segp, code);
	if segp = null then do;
	     if code ^= 0 then go to init_err;
	     else code = error_table_$argerr;
init_err:	     call com_err_ (code, caller, "^/search segment ^a>^a was not initiated", dname, ename);
	     go to fin;
	end;

/* initiate parse */

	tcc = divide (bitcnt, 9, 17, 0);		/* get the total character count */
	if tcc = 0 then do;
search_rule_err: code = error_table_$argerr;
	     call com_err_ (code, caller, "^/search segment ^a>^a was empty", dname, ename);
	     go to fin;
	end;

	xsp = addr (system_rules);
	call hcs_$get_system_search_rules (xsp, code);
	if code ^= 0 then do;
	     call com_err_ (code, caller, "Cannot read dft rules");
	     go to fin;
	end;

	cc = 1;					/* start with first character */
	ncl = tcc;				/* start with all characters left */
	src = 1;					/* start with search rule count = 1 */

parse:
	sp = addr (segp -> ch (cc));			/* pointer to new string */
	if blank_flag = 1 then go to new_line;		/* no more blanks in segment */
	if segp -> ch (cc) = blank then do;		/* remove leading blanks */
	     do i = cc to tcc while (segp -> ch (i) = blank); end;
	     cc = i;
	end;
	ncl = tcc - cc + 1;				/* update characters left */
	if ncl <= 0 then go to nl_err;		/* segment must end with a new line */
	sp = addr (segp -> ch (cc));			/* pointer to remaining string */
new_line:	nln = index (sp -> string, nl) - 1;		/* count to next new line */
	if nln < 0 then do;				/* must end with a new line */
nl_err:	     code = error_table_$argerr;
	     call com_err_ (code, caller, "^/^a>^a search segment must end with a new line", dname, ename);
	     go to fin;
	end;
	if nln = 0 then go to next;			/* try next line */
	if blank_flag = 1 then do;			/* no more blanks so don't fool around */
	     size = nln;
	     go to handle_string;
	end;
	bn = index (sp -> string, blank);		/* count to next blank */
	if bn = 0 then do;				/* no more blanks */
	     blank_flag = 1;
	     size = nln;
	     go to handle_string;
	end;
	if bn < nln then do;			/* find out how much to copy */
	     size = bn;				/* size of string to first blank */
	     do i = bn + 1 to nln;			/* check for imbedded blanks */
		if sp -> ch (i) ^= blank then do;
		     code = error_table_$argerr;
		     call com_err_ (code, caller, "^/search segment ^a>^a, imbedded blank in string ^a",
			dname, ename, substr (sp -> string, 1, nln));
		     go to fin;
		end;
	     end;
	     go to handle_string;			/* no imbedded blanks so copy it */
	end;
	else size = nln;

handle_string: srptr -> sr.name (src) = substr (sp -> string, 1, size); /* copy the string */

	if sp -> ch (1) ^= ">" then go to check_code;	/* absolute pathnames begin with > */
	pptr = addr (srptr -> sr.name (src));
	call expand_path_ (pptr, size, dirp, enp, code);
	if code ^= 0 then do;
	     subname = "expand_path_";
sub_err:	     call com_err_ (code, caller, "^a in search segment ^a>^a", srptr -> sr.name (src), dname, ename);
	     go to fin;
	end;

	call hcs_$status_minf (dir, entry, 1, type, bitcnt, code);
	if code ^= 0 then do;
	     subname = "status_minf";
	     go to sub_err;
	end;
	if type ^= 2 then do;
	     code = error_table_$notadir;
	     call com_err_ (code, caller, "^/improper search rule ^a, search segment ^a>^a",
		srptr -> sr.name (src), dname, ename);
	     go to fin;
	end;

next:
	cc = cc + nln + 1;				/* position to next line */
	if cc < tcc then do;			/* continue if something left */
	     ncl = tcc - cc + 1;			/* find number of characters remaining */
	     src = src + 1;				/* bump search rule count */
	     if src > 22 then do;			/* too many search rules */
		code = error_table_$argerr;
		call com_err_ (code, caller, "^/too many search rules in search segment ^a>^a",
		     dname, ename);
		go to fin;
	     end;
	     go to parse;				/* do the next one */
	end;
	srptr -> sr.number = src;			/* put away search rule count */

fin:	if segp ^= null then call hcs_$terminate_noname (segp, (0));
	a_code = code;
	return;
check_code:
	do ii = 1 to hbound (search_rule_names, 1);
	     if search_rule_names (ii) = srptr -> sr.name (src) then go to next;
	end;
	do ii = 1 to dft_sr_arg.ntags;
	     if dft_sr_arg.tags (ii).name = srptr -> sr.name (src) then go to next;
	end;
	if srptr -> sr.name (src) = "home_dir" then go to next;
	if srptr -> sr.name (src) = "process_dir" then go to next;
	code = error_table_$argerr;
	call com_err_ (code, caller, "^/bad string ^a in search segment ^a>^a",
	     srptr -> sr.name (src), dname, ename);
	go to fin;

     end parse_search_rules_;




		    set_search_rules.pl1            11/04/82  1909.0rew 11/04/82  1613.7       34407



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


set_search_rules: ssr:
     procedure options (variable);

/* Created 770322 by PG from old version that was combined with set_search_dirs. */
/* Add -default control arg 06/10/80 S. Herbst */

/* based */

dcl arg char (arg_len) based (arg_ptr);

/* automatic */

dcl 1 search_rules,					/* the search rule structure */
    2 num fixed bin,				/* the number of search rules */
    2 names (21) char (168) aligned;			/* the search rules */

dcl (dn, path) char (168);
dcl en char (32);

dcl (default_sw, got_path_sw) bit (1);

dcl arg_ptr ptr;

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


dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$segknown fixed bin (35) ext;

dcl (active_fnc_err_, com_err_, com_err_$suppress_name) 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_ entry (char (*), char (*), char (*), fixed bin (35));
dcl hcs_$get_search_rules entry (ptr);
dcl hcs_$initiate_search_rules entry (ptr, fixed bin (35));
dcl ioa_ entry options (variable);
dcl parse_search_rules_ entry (char (*), char (*), char (*), ptr, fixed bin (35));

dcl (addr, null, substr) builtin;
/**/
	call cu_$af_return_arg (arg_count, null, 0, code);
	if code = 0 then do;
	     call active_fnc_err_ (0, "set_search_rules", "Cannot be called as an active function.");
	     return;
	end;

	default_sw, got_path_sw = "0"b;
	do i = 1 to arg_count;

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

	     if substr (arg, 1, 1) = "-" then
		if arg = "-default" | arg = "-df" then do;
		     if got_path_sw then do;		/* multiple specifications */
USAGE:			call com_err_$suppress_name (0, "set_search_rules",
			     "Usage:  set_search_rules path
or:     set_search_rules -default");
			return;
		     end;
		     default_sw, got_path_sw = "1"b;
		end;
		else do;
		     call com_err_ (error_table_$badopt, "set_search_rules", "^a", arg);
		     return;
		end;

	     else if got_path_sw then go to USAGE;
	     else do;
		path = arg;
		got_path_sw = "1"b;
	     end;
	end;

	if ^got_path_sw | default_sw then do;
	     search_rules.num = 1;
	     search_rules.names (1) = "default";
	end;
	else do;
	     call expand_pathname_ (path, dn, en, code);
	     if code ^= 0 then do;
		call com_err_ (code, "set_search_rules", "^a", path);
		return;
	     end;

	     call parse_search_rules_ (dn, en, "set_search_rules", addr (search_rules), code);
	     if code ^= 0 & code ^= error_table_$segknown then return;
	end;

	call hcs_$initiate_search_rules (addr (search_rules), code);
	if code ^= 0 then call com_err_ (code, "set_search_rules", "");

	return;


print_search_rules: psr: entry options (variable);

/* This entry point is called to print the search rules */

	call cu_$af_return_arg (arg_count, null, 0, code);
	if code = 0 then do;
	     call active_fnc_err_ (0, "print_search_rules", "Cannot be called as an active function.");
	     return;
	end;

	if arg_count > 0 then do;
	     call com_err_$suppress_name (0, "print_search_rules", "Usage:  print_search_rules");
	     return;
	end;

	call hcs_$get_search_rules (addr (search_rules));

	do i = 1 to search_rules.num;
	     call ioa_ ("^a", search_rules.names (i));
	end;

end set_search_rules;




		    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
