1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 path: proc;
 12 
 13 /*        U S E F U L   A C T I V E   F U N C T I O N S .
 14 
 15 
 16    Adapted 11/19/72 by Robert S. Coren from code originally written
 17    by Max G.Smith
 18    Changed to work when called as commands, S. Herbst 08/31/78
 19    Fix [unique 0] return value 06/10/80 S. Herbst
 20    Short name dir added to directory 01/12/81 S. Herbst
 21    Taught path about archive component pathnames 07/19/81 B. Margolin
 22    Taught everything about archive component pathnames, added
 23    the component and strip_component entrypoints, fixed some incorrect
 24    external entry declarations (w/r/t alignedness of strings). 02/16/82
 25    by B. Margolin.
 26    Enhanced path (2-3 arg case) and added is_component_pathname and
 27    entry_path.  02/19/82 by B. Margolin.
 28    Modified path & cohorts so that a segment name with an embedded space
 29    will not become two separate segments.  10/15/82 Linda Pugh.
 30    Add shortest_path. 01/05/82 R. Harvey.
 31 
 32    [path  a]        The complete pathname of "a".
 33 
 34    [path  a  b]     The complete pathname of "b" in directory "a".
 35 
 36    [path  a  b  c]  The complete pathname of component "c" in segment "b"
 37    in directory "a".
 38 
 39    [directory  a]   The directory portion of the complete pathname of "a".
 40 
 41    [entry  a]       The entry portion of the complete pathname of "a".
 42 
 43    [component  a]   The archive component portion of the complete
 44    pathname of "a", or [entry  a] if "a" is not an archive component
 45    pathname.
 46 
 47    [entry_path  a]  The complete pathname of the segment that "a" is
 48    in.  The same as [path a] if "a" is not an archive component pathname.
 49 
 50    [shortest_path a b c] The shortest pathname of component "c" in segment "b"
 51    in directory "a".
 52 
 53    [strip  a  b]    The complete pathname of "a" with the suffix ".b"
 54    removed if it was present.
 55 
 56    [strip  a]       The complete pathname of "a" with the suffix
 57    removed if there was more than one component.
 58 
 59    [strip_entry  a  b]  Same as [entry [strip a b]].
 60 
 61    [strip_entry  a] Same as [entry [strip a]].
 62 
 63    [strip_component  a]  Same as [strip_entry [component a]].
 64 
 65    [strip_component  a  b]  Same as [strip_entry [component a] b].
 66 
 67    [suffix  a]      Null if [component a] has only one component;
 68    otherwise, the last component.
 69 
 70    [is_component_pathname a] Returns "true" if a is an archive
 71    component pathname.
 72 
 73    [unique]                   A 15-character unique idenifier. */
 74 
 75 /* Declarations. */
 76 
 77 dcl  return_ptr ptr;
 78 dcl  return_string char (return_len) based (return_ptr) varying;
 79 dcl  return_len fixed bin;
 80 
 81 dcl  arg_ptr (3) ptr;
 82 dcl  arg_len (3) fixed bin;
 83 dcl  arg1 char (arg_len (1)) based (arg_ptr (1));
 84 dcl  arg2 char (arg_len (2)) based (arg_ptr (2));
 85 dcl  arg3 char (arg_len (3)) based (arg_ptr (3));
 86 
 87 dcl (dn, pn) char (202);
 88 dcl  char202 character (202) varying;
 89 dcl (en, cn, who) char (32);
 90 dcl  b36 bit (36);
 91 dcl  af_sw bit (1);
 92 dcl  fb35 fixed bin (35);
 93 dcl (i, j, colon_idx, arg_count) fixed;
 94 dcl  code fixed bin (35);
 95 
 96 dcl  error_table_$bad_conversion fixed binary (35) external;
 97 dcl  error_table_$not_act_fnc fixed bin (35) ext;
 98 
 99 dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
100 dcl (active_fnc_err_, active_fnc_err_$suppress_name,
101      com_err_, com_err_$suppress_name, ioa_) entry options (variable);
102 dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
103 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
104 dcl  expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
105 dcl  get_shortest_path_ entry (char(*)) returns(char(168));
106 dcl  pathname_$component_check entry (char(*), char(*), char(*), char(*), fixed bin(35));
107 dcl  unique_chars_ ext entry (bit (*)) returns (char (15));
108 dcl  requote_string_ entry (char(*)) returns (char(*));
109 dcl (addr, index, length, maxlength, reverse, rtrim, search, substr, unspec) builtin;
110 
111 /* End of declarations. */
112 /* ^L */
113 /* Here for [path a]. */
114 
115           call setup ("path", "", 1, 3, "0"b);
116           go to JOIN_SP;
117 
118 
119 
120 
121 /* Here for [shortest_path a]. */
122 
123 shortest_path: entry;
124 
125           call setup ("shortest_path", "", 1, 3, "0"b);
126 
127 
128 JOIN_SP:  if arg_count = 1 then go to JOIN_D;               /* Simple case */
129 
130           if arg_count = 2 then call pathname_$component_check ((pn), arg2, "", pn, code);
131           else call pathname_$component_check ((pn), arg2, arg3, pn, code);
132           if code ^= 0 then call error (code, "Creating pathname.");
133           if who = "shortest_path" then return_string = rtrim (get_shortest_path_ (pn));
134           else return_string = rtrim (pn);
135           go to FINISH;
136 
137 
138 
139 
140 
141 /* Here for [directory a]. */
142 
143 directory: dir: entry;
144 
145           call setup ("directory", en, 1, 1, "1"b);
146           pn = dn;
147 
148 JOIN_D:   if who = "shortest_path" then return_string = rtrim (get_shortest_path_ (pn));
149           else return_string = rtrim (pn);
150 
151 FINISH:   if ^af_sw then call ioa_ ("^a", return_string);
152           else if who ^= "is_component_pathname" then;
153           return_string = requote_string_ ((return_string));
154 
155 RETURN:   return;
156 
157 
158 
159 
160 
161 /* Here for [entry a]. */
162 
163 entry:    entry;
164 
165           call setup ("entry", en, 1, 1, "1"b);
166           return_string = rtrim (en);
167           go to FINISH;
168 
169 
170 
171 
172 
173 /* Here for [component a]. */
174 
175 component: entry;
176 
177           call setup ("component", en, 1, 1, "1"b);
178           if cn ^= "" then return_string = rtrim (cn);
179           else return_string = rtrim (en);
180           go to FINISH;
181 
182 
183 
184 
185 
186 /* Here for [is_component_pathname a] */
187 
188 is_component_pathname:
189 icpn:     entry;
190 
191           call setup ("is_component_pathname", en, 1, 1, "1"b);
192           if cn = "" then return_string = "false";
193           else return_string = "true";
194           go to FINISH;
195 
196 
197 
198 
199 /* Here for [entry_path a] */
200 entry_path:
201           entry;
202 
203           call setup ("entry_path", en, 1, 1, "1"b);
204           call pathname_$component_check (dn, en, "", pn, code);
205           if code ^= 0 then call error (code, "Forming pathname.");
206           return_string = rtrim (pn);
207           go to FINISH;
208 
209 
210 
211 
212 
213 
214 /* Here for [strip a] and [strip a b]. */
215 
216 strip:    entry;
217 
218           call setup ("strip", "", 1, 2, "0"b);
219           go to JOIN_R;
220 
221 
222 
223 
224 /* Here for [strip_component a] and [strip_component a b]. */
225 
226 strip_component: spc:
227           entry;
228 
229           call setup ("strip_component", en, 1, 2, "1"b);
230           if cn = "" then pn = en;
231           else pn = cn;
232           go to JOIN_R;
233 
234 
235 
236 
237 /* Here for [strip_entry a] and [strip_entry a b]. */
238 
239 strip_entry: spe: entry;
240 
241           call setup ("strip_entry", en, 1, 2, "1"b);
242           pn = en;
243 
244 JOIN_R:   if arg_count = 2 then go to TWO_ARGS;
245 
246 /* Here for [strip a] and [strip_entry a]. */
247 
248           colon_idx = index (pn, "::");
249           if colon_idx = 0                        /* not archive */
250                then j = length (pn) + 1 - search (reverse (pn), ".>");
251           else j = length (pn) + 1 -
252                index (reverse (substr (pn, colon_idx + 2)), ".");
253           if j = length (pn) + 1 | j = 1 | substr (pn, j, 1) = ">" then return_string = rtrim (pn);
254           else return_string = substr (pn, 1, j - 1);
255           go to FINISH;
256 
257 /* Here for [strip a b] and [strip_entry a b]. */
258 
259 TWO_ARGS: i = length (rtrim (pn));
260           return_string = rtrim (pn);
261           if i > arg_len (2) then
262                if substr (pn, i - arg_len (2)) = "." || arg2 then
263                     return_string = substr (pn, 1, i - arg_len (2) - 1);
264           go to FINISH;
265 
266 
267 
268 
269 
270 /* Here for [suffix a]. */
271 
272 suffix:   entry;
273 
274           call setup ("suffix", en, 1, 1, "1"b);
275           if cn ^= "" then en = cn;
276           i = 33-index (reverse (en), ".");
277           if i = 33 then return_string = "";
278           else if i >= length (rtrim (en)) then return_string = "";
279           else return_string = rtrim (substr (en, i+1));
280           go to FINISH;
281 
282 
283 
284 
285 
286 /* Here for [unique]. */
287 
288 unique:   entry;
289 
290           who = "unique";
291           call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
292           if code = error_table_$not_act_fnc then do;
293                af_sw = "0"b;
294                return_ptr = addr (char202);
295                return_len = 202;
296           end;
297           else af_sw = "1"b;
298           if arg_count ^= 0 then do;
299                if arg_count ^= 1 then do;
300                     if af_sw then call active_fnc_err_$suppress_name
301                          (0, "unique", "Usage:  [unique {octal_number}]");
302                     else call com_err_$suppress_name (0, "unique", "Usage:  unique {octal_number}");
303                     go to RETURN;
304                end;
305                call cu_$arg_ptr (1, arg_ptr (1), arg_len (1), code);
306                fb35 = cv_oct_check_ (arg1, code);
307                if code ^= 0 then do;
308                     call error (error_table_$bad_conversion, (arg1));
309                end;
310                if fb35 = 0 then do;
311                     return_string = "!BBBBBBBBBBBBBB";
312                     go to FINISH;
313                end;
314                b36 = unspec (fb35);
315           end;
316           else b36 = ""b;
317           return_string = unique_chars_ (b36);
318           go to FINISH;
319 
320 
321 
322 
323 setup:    proc (string, a_en, min_arg, max_arg, ret);
324 
325 /* Internal function to..
326    (1)  Set the name of the active function in 'who'.
327    (2)  Verify that there are the proper number of arguments
328     (as defined by min_arg and max_arg).
329    (3)  Expand the first argument into the parts of a full pathname.
330    (4) If ret is set, then put the entryname in a_en, the output
331     argument, else set pn to the the full pathname.
332 
333    (yes, I know this interface is horrible, but that's the way I
334     found it, and I didn't feel like rewriting it -- Barmar)
335  */
336 
337 
338 dcl  string char (*);
339 dcl  a_en char (*);
340 dcl  en char (32);
341 dcl  (min_arg, max_arg) fixed bin;
342 dcl  ret bit (1);   /* should we return a value? */
343 
344                who = string;
345                call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
346                if code = error_table_$not_act_fnc then do;
347                     af_sw = "0"b;
348                     return_ptr = addr (char202);
349                     return_len = maxlength (char202);
350                end;
351                else af_sw = "1"b;
352 
353                if arg_count < min_arg | arg_count > max_arg then do;
354                     if af_sw then call active_fnc_err_$suppress_name (0, string,
355                          "Usage:  [^a ^[path^;path {string}^;path {string1 {string2}}^]]",
356                          string, max_arg);
357                     else call com_err_$suppress_name (0, string,
358                          "Usage:  ^a ^[path^;path {string}^;path {string1 {string2}}^]",
359                          string, max_arg);
360                     go to RETURN;
361                end;
362 
363 /* pick up input args  */
364 
365                do i = 1 to arg_count;
366                     call cu_$arg_ptr (i, arg_ptr (i), arg_len (i), code);
367                     if code ^= 0 then
368 BAD_ARGS:                call error (code, "");
369                end;
370                call expand_pathname_$component (arg1, dn, en, cn, code);
371                if code ^= 0 then call error (code, (arg1));
372                if ^ret then do;
373                     call pathname_$component_check (dn, en, cn, pn, code);
374                     if code ^= 0 then call error (code, (arg1));
375                     end;
376                else a_en = en;
377 
378           end setup;
379 
380 
381 
382 
383 error:    proc (acode, string);
384 
385 /* Internal procedure to print error messages and exit */
386 
387 dcl  acode fixed bin (35), string char (*);
388 
389                if af_sw then call active_fnc_err_ (acode, who, string);
390                else call com_err_ (acode, who, string);
391                go to RETURN;
392 
393           end error;
394 
395      end path;