1 /* ******************************************************
 2    *                                                    *
 3    *                                                    *
 4    * Copyright (c) 1972 by Massachusetts Institute of   *
 5    * Technology and Honeywell Information Systems, Inc. *
 6    *                                                    *
 7    *                                                    *
 8    ****************************************************** */
 9 
10 set_search_dirs: ssd:
11      procedure options (variable);
12 
13 /* Created 770322 by PG from old version that was combined with set_search_rules.  This command is obsolete. */
14 
15 /* automatic */
16 
17 dcl  dname char (168),                                      /* directory path name */
18      ename char (32),                                       /* entry name */
19      arg char (len) based (p),                              /* an argument string */
20      p ptr;
21 
22 dcl (i, junk,
23      type,                                                  /* type of segment */
24      nargs) fixed bin,                                      /* number of arguments */
25      code fixed bin (35),
26      len fixed bin (21);
27 
28 dcl 1 search_rules,                                         /* the search rule structure */
29     2 num fixed bin,                                        /* the number of search rules */
30     2 names (21) char (168) aligned;                        /* the search rules */
31 
32 /* builtins */
33 
34 dcl (addr, rtrim) builtin;
35 
36 /* entries */
37 
38 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
39      cu_$arg_count entry (fixed bin),
40      expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
41      hcs_$initiate_search_rules entry (ptr, fixed bin (35)),
42      hcs_$status_minf entry (char (*), char (*), fixed bin, fixed bin, fixed bin, fixed bin (35)),
43      com_err_ entry options (variable);
44 
45 /* external static */
46 
47 dcl  error_table_$notadir fixed bin (35) external static;
48 
49 /* internal static options (constant) */
50 
51 dcl  caller char (15) internal static options (constant) initial ("set_search_dirs");
52 ^L
53 /* program */
54 
55           call cu_$arg_count (nargs);                       /* how many arguments are there */
56           if nargs = 0
57           then do;
58                     search_rules.num = 1;                   /* only one necessary */
59                     search_rules.names (1) = "default";     /* and this is it */
60                end;
61           else do;
62                     search_rules.num = nargs + 1;                     /* make room for ssd key word */
63                     search_rules.names (1) = "set_search_directories";
64 
65                     do i = 1 to nargs;                                /* start with second name */
66                          call cu_$arg_ptr (i, p, len, code);          /* get an argument */
67                          call expand_pathname_ (arg, dname, ename, code);       /* if not a key word then a sub-directory */
68                          if code ^= 0 then go to print_error;         /* something went wrong */
69 
70                          if dname = ">"
71                          then search_rules.names (i+1) = ">" || ename; /* for the root */
72                          else search_rules.names (i+1) = rtrim (dname) || ">" || ename;
73 
74                          call hcs_$status_minf (dname, ename, 1, type, junk, code); /* is it a directory */
75                          if code ^= 0 then go to print_error;         /* what's wrong now */
76 
77                          if type ^= 2 then do;                        /* is it a directory */
78                               code = error_table_$notadir;
79                               go to print_error;                      /* print the error and return */
80                          end;
81                     end;                                              /* end of argument loop */
82                end;
83 
84           call hcs_$initiate_search_rules (addr (search_rules), code);
85           if code ^= 0
86           then do;
87                     call com_err_ (code, caller, "");
88                     return;
89                end;
90 
91           return;
92 
93 print_error:
94           call com_err_ (code, caller, "^a", arg);          /* print the error and the arg */
95           return;
96 
97      end;