1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Bull Inc., 1987                *
  6         *                                                         *
  7         * Copyright, (C) Honeywell Information Systems Inc., 1984 *
  8         *                                                         *
  9         * Copyright (c) 1972 by Massachusetts Institute of        *
 10         * Technology and Honeywell Information Systems, Inc.      *
 11         *                                                         *
 12         *********************************************************** */
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(86-08-08,GDixon), approve(86-08-08,MCR7388),
 17      audit(86-09-02,Farley), install(86-09-08,MR12.0-1150):
 18      Remove the include of kst.incl.pl1, since reference to variables in the
 19      program was removed in an early release.
 20   2) change(86-08-20,Lippard), approve(86-09-08,MCR7539),
 21      audit(86-10-15,Farley), install(86-10-20,MR12.0-1189):
 22      Modified by Jim Lippard to fix ref names allocation bug, fix supplied
 23      by Steve Harris (UNCA).
 24   3) change(90-07-26,WAAnderson), approve(90-07-26,MCR8182),
 25      audit(90-08-10,Schroth), install(90-08-21,MR12.4-1030):
 26      Replaced call to ref_name_$get_refnames with call to
 27      ref_name_$get_refname.  This change reduces stack space requirements
 28      and corrects the list_ref_names infinite loop bug.
 29                                                    END HISTORY COMMENTS */
 30 
 31 
 32 /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */
 33 
 34 fs_get: proc;
 35 
 36 /*        Modified 03/05/85 by Melanie Weaver to remove entry label  $call_name */
 37 /*        Modified 02/25/85 by Keith Loepere to use dc_find for name lookup check for path_name. */
 38 /*        Modified 10/16/84 by Keith Loepere to use dc_find for access computations. */
 39 /*        Modified 7/17/84 by Keith Loepere to use the new dc_find. */
 40 /*        Modified 5/17/83 by E. N. Kittlitz to decrement ref on get_link_target.
 41 /*        Modified 1/3/83 by Jay Pattin to add access_modes entry */
 42 /*        Modified 01/15/79 by C. D. Tavares to compute access correctly w.r.t. dir extended ring brackets */
 43 /*        Modified March 1977 by M. Weaver to get rntp from stack */
 44 /*        Modified March 1976 by R. Bratt for initiated_mode and to fix get_search_rules bug */
 45 /*        Modified April 1975 by E. Stone to put access info in kst */
 46 /*        Modified April 1975 by R. Bratt for new kst */
 47 /*        Modified  Feb 1975 by R. Bratt to use get_pathname_ */
 48 /*        Modified by Kobziar July 74 to call appropriate entry point in access_mode */
 49 /*
 50    -- ->  fs_get$brackets returns the mode and ring brackets of the current
 51    user for the segment specified by segptr.
 52 
 53    USAGE: call fs_get$brackets (segptr, mode, rings, code);
 54 
 55    1) segptr ptr - - - pointer to segment
 56    2) mode fixed bin(5) - - - mode of user (output)
 57    3) rings (3) fixed bin(6) - - - ring brackets of user (output)
 58    4) code fixed bin - - - error code (output)
 59 
 60    -- ->  fs_get$ex_mode_name returns the mode, brackets, extended access, and
 61    primary name of a segment for the current user.
 62 
 63    USAGE: call fs_get$ex_mode_name(segptr,mode,rings,ex_mode,name,code);
 64 
 65    4) ex_mode is the extended access mode.
 66 
 67    5) name is the primary name of the segment.
 68 
 69    All other arguments same as fs_get$brackets.
 70 
 71    -- ->  fs_get$mode returns the mode of the current user at the current
 72    validation level for the segment specified by segptr.
 73 
 74    USAGE: call fs_get$mode (segptr, mode, code);
 75 
 76    The arguments are the same as for fs_get$brackets.
 77 
 78    -- ->  fs_get$access_modes returns both mode and extended modes.
 79 
 80    USAGE:  call fs_get$access_modes (segptr, mode, exmodes, code);
 81 
 82    -- ->  fs_get$segptr returns a pointer to a segment given its reference name.
 83 
 84    USAGE: call fs_get$segptr (refname, segptr, code);
 85 
 86    1) refname char(*) - - - refernce name of segment
 87    2) segptr ptr - - - pointer to segment (output)
 88    3) code fixed bin - - - error code (output)
 89 
 90    -- ->  fs_get$search_rules  returns in a space provided by the user a list of
 91    of the search rules currently in use by the user for his validation level.
 92 
 93    USAGE:call fs_get$search_rules (search_rules_ptr);
 94 
 95    1) search_rules_ptr ptr - - - is a pointer to the space where the list of names will be stored.
 96 
 97    The names are stored in a structure of the form:
 98 
 99    dcl 1 ret_struc aligned,
100    2 num fixed bin, number of rules
101    2 names(21) char(168) aligned;
102 
103 
104    -- ->  fs_get$path_name returns the pathname of the directory immediately superior
105    to, and the entry name of the segment specified by segptr.
106 
107    USAGE: call fs_get$path_name (segptr, dirname, lnd, ename, code);
108 
109    1) segptr ptr - - - pointer to the segment
110    2) dirname char(168) - - - pathname of superior directory (output)
111    3) lnd fixed bin - - - number of significant chars in pathname (output)
112    4) ename char(32) - - - entry name of segment (output)
113    5) code fixed bin - - - error code (output)
114 
115    -- ->  fs_get$dir_name returns the pathname of the directory immediatetly superior
116    to the segment specified by segptr.
117 
118    USAGE: call fs_get$dir_name (segptr, dirname, lnd, code);
119 
120    The arguments are the same as fs_get$path_name.
121 
122    -- ->  fs_get$ref_name returns the reference name corresponding to namecnt for
123    the segment specified by segptr.
124 
125    USAGE: call fs_get$ref_name (segptr, namecnt, refname, code);
126 
127    1) segptr ptr - - - pointer to the segment
128    2) namecnt fixed bin(17) - - - number of the reference name desired
129    3) refname char(*) - - - reference name (output)
130    4) code fixed bin - - - error code (output)
131 
132    -- ->  fs_get$trans_sw returns the current value of the transparent usage/modification
133    switch and sets it to a new value.
134 
135    USAGE: call fs_get$trans_sw (newsw, oldsw)
136 
137    1) newsw fixed bin - - - new value for switch, if > 3, don't set switch
138    2) oldsw fixed bin - - - old value of switch (output)
139 
140    */
141 
142 /* Parameters */
143 
144 dcl  a_code                             fixed bin (35) parameter;
145 dcl  a_dirname                          char (*) parameter;
146 dcl  a_ename                            char (*) parameter;
147 dcl  a_ex_mode                          bit (*) parameter;  /* extended access  bits EX ACC */
148 dcl  a_ex_modes                         bit (36) aligned parameter;
149 dcl  a_ldir                             char (*) parameter;
150 dcl  a_lentry                           char (*) parameter;
151 dcl  a_lnd                              fixed bin (17) parameter;
152 dcl  a_mode                             fixed bin (5) parameter;
153 dcl  a_name                             char (*) parameter; /* name of segment EX ACC */
154 dcl  a_namecnt                          fixed bin (17) parameter;
155 dcl  a_new_mode                         bit (36) aligned parameter;
156 dcl  a_newsw                            fixed bin (17) parameter;
157 dcl  a_oldsw                            fixed bin (17) parameter;
158 dcl  a_ptr                              ptr parameter;
159 dcl  a_refname                          char (*) parameter;
160 dcl  a_rings                            (3) fixed bin (3) parameter;
161 dcl  a_rname                            char (*) parameter;
162 dcl  a_segptr                           ptr parameter;
163 
164 /* Constants */
165 
166 dcl  access_modes                       fixed bin static options (constant) init (5);
167 dcl  brackets                           fixed bin static options (constant) init (3);
168 dcl  ex_mode_name                       fixed bin static options (constant) init (4);
169 dcl  just_mode                          fixed bin static options (constant) init (0);
170 
171 /* Variables */
172 
173 dcl  aptr                               ptr;
174 dcl  code                               fixed bin (35);
175 dcl  dirsw                              bit (1) aligned;
176 dcl  dlen                               fixed bin (17);
177 dcl  end_rule                           fixed bin (17);
178 dcl  entry_point                        fixed bin;
179 dcl  extended_mode                      bit (36) aligned;
180 dcl  i                                  fixed bin;
181 dcl  l                                  fixed bin;
182 dcl  ldir                               char (168);
183 dcl  lentry                             char (32);
184 dcl  mode                               bit (36) aligned;
185 dcl  namecnt                            fixed bin (17);
186 dcl  newsw                              fixed bin (17);
187 dcl  oldsw                              fixed bin (17);
188 dcl  pathname                           char (201) varying;
189 dcl  rb                                 (3) fixed bin (3);
190 dcl  return_ename                       bit (1) aligned;
191 dcl  ring                               fixed bin;
192 dcl  rname                              char (32) varying;
193 dcl  segnum                             fixed bin (17);
194 dcl  segptr                             ptr;
195 dcl  srpp                               ptr;
196 
197 /* Based */
198 
199 dcl  1 ret_struc                        based aligned,
200        2 num                            fixed bin,
201        2 names                          (21) char (168);
202 
203 dcl  1 sr                               (22) based aligned,
204        2 segno                          fixed bin (17) unaligned,
205        2 offset                         fixed bin (17) unaligned,
206        2 uid                            bit (36);
207 
208 /* External */
209 
210 dcl  error_table_$dirseg                fixed bin (35) external;
211 dcl  error_table_$noentry               fixed bin (35) external;
212 dcl  error_table_$root                  fixed bin (35) external;
213 dcl  pds$stacks                         (0:7) ptr external;
214 dcl  pds$transparent                    bit (2) external aligned;
215 
216 /* Entries */
217 
218 dcl  get_pathname_                      entry (fixed bin (17), char (*) varying, fixed bin (35));
219 dcl  level$get                          entry returns (fixed bin);
220 dcl  ref_name_$get_refname              entry (fixed bin (17), fixed bin (17), char (*) varying, fixed bin (35));
221 dcl  ref_name_$get_segno                entry (char (32) varying, fixed bin (17), fixed bin (35));
222 
223 /* Misc */
224 
225 dcl  (baseno, baseptr, binary, fixed, hbound, index, lbound, length, max, null, reverse, segno, substr) builtin;
226 %page;
227 mode: entry (a_segptr, a_mode, a_code);
228 
229           entry_point = just_mode;                          /* Set entry switch */
230           go to join_mode;
231 
232 brackets: entry (a_segptr, a_mode, a_rings, a_code);
233 
234           entry_point = brackets;                           /* Set entry switch */
235           go to join_mode;
236 
237 access_modes:
238      entry (a_segptr, a_new_mode, a_ex_modes, a_code);      /* new_mode because has correct dcl */
239 
240           entry_point = access_modes;                       /* Set entry switch */
241           go to join_mode;
242 
243 ex_mode_name:
244      entry (a_segptr, a_mode, a_rings, a_ex_mode, a_name, a_code); /* extended acess entry EX ACC */
245 
246           entry_point = ex_mode_name;                       /* set entry switch EX ACC */
247 join_mode:
248           segptr = a_segptr;                                /* copy arg */
249 
250           call dc_find$obj_modes_ptr (segptr, mode, extended_mode, rb, code);
251           if code ^= 0 then
252                if code = error_table_$dirseg then do;
253                     code = 0;
254                     dirsw = "1"b;
255                end;
256                else go to err0;
257           else dirsw = "0"b;
258 
259           if (entry_point = brackets) | (entry_point = ex_mode_name) then do;
260                a_rings = rb;
261                if entry_point = ex_mode_name then do;
262                     a_ex_mode = extended_mode;
263                     a_name = "";
264                end;
265           end;
266           if entry_point = access_modes then do;
267                if dirsw then code = error_table_$dirseg;
268                else do;
269                     a_new_mode = mode;
270                     a_ex_modes = extended_mode;
271                end;
272           end;
273           else do;
274                if dirsw then mode = substr (mode, 1, 1) || "1"b || substr (mode, 2, 2);
275                a_mode = fixed (substr (mode, 1, 4), 5);
276           end;
277 
278 err0:
279           a_code = code;
280           return;
281 %page;
282 
283 /* * * * * * * * * * * * * * * * * * * */
284 
285 seg_ptr: entry (a_rname, a_segptr, a_code);
286 
287           call ref_name_$get_segno ((a_rname), segnum, code);
288           if code = 0 then a_segptr = baseptr (segnum);
289           else a_segptr = null ();
290           a_code = code;
291           return;
292 
293 /* * * * * * * * * * * * * * * * * * * * */
294 search_rules: entry (a_ptr);
295 
296           aptr = a_ptr;                                     /* copy arg */
297           ring = level$get ();
298           rntp = pds$stacks (ring) -> stack_header.rnt_ptr;
299           srpp = rntp -> rnt.srulep;
300           end_rule = binary (END_RULE);                     /* pull computation out of loop */
301           do i = lbound (srpp -> sr, 1) to hbound (srpp -> sr, 1) while (srpp -> sr (i).offset ^= end_rule); /* now get the search rule names */
302                if srpp -> sr (i).offset ^= 0 then aptr -> ret_struc.names (i) = search_rule_names (srpp -> sr (i).offset);
303                else do;
304                     segnum = srpp -> sr (i).segno;
305                     segptr = baseptr (segnum);
306                     call dc_find$obj_existence_ptr (segptr, ep, code);
307                     if code ^= 0 then aptr -> ret_struc.names (i) = "invalid search rule pointer";
308                     else do;
309                          call get_pathname_ (segnum, pathname, code);
310                          if code ^= 0 then aptr -> ret_struc.names (i) = "invalid search rule pointer";
311                          else aptr -> ret_struc.names (i) = pathname; /* copy name */
312                          call dc_find$finished (ep, DC_FIND_UNLOCK_DIR);
313                     end;
314                end;
315           end;
316           aptr -> ret_struc.num = i - 1;
317           return;
318 
319 /* * * * * * * * * * * * * * * * * * * * */
320 
321 get_link_target:
322      entry (a_ldir, a_lentry, a_dirname, a_ename, a_code);
323 
324           ldir = a_ldir;                                    /* copy input arguments */
325           lentry = a_lentry;
326 
327           a_dirname = "";                                   /* set default values for return arguments */
328           a_ename = "";
329 
330           call dc_find$link_target (ldir, lentry, code);
331 
332           if code = 0 | code = error_table_$noentry then do;
333                a_dirname = ldir;
334                a_ename = lentry;
335           end;
336 
337           a_code = code;
338           return;
339 
340 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
341 
342 path_name: entry (a_segptr, a_dirname, a_lnd, a_ename, a_code);
343           return_ename = "1"b;
344           goto name_join;
345 
346 dir_name: entry (a_segptr, a_dirname, a_lnd, a_code);
347           return_ename = "0"b;
348 
349 name_join:
350           code = 0;
351           segptr = a_segptr;
352           call dc_find$obj_existence_ptr (segptr, ep, code);
353           if code = 0 then do;
354                call get_pathname_ (segno (segptr), pathname, code);
355                call dc_find$finished (ep, DC_FIND_UNLOCK_DIR);
356           end;
357           else if code = error_table_$root then do;
358                code = 0;
359                pathname = ">";
360           end;
361           else goto name_return;
362 
363           i = index (reverse (pathname), ">");
364           l = length (pathname);
365           dlen = max (l - i, 1);
366           if return_ename then if dlen = 1 then dlen = 0;
367           a_dirname = substr (pathname, 1, dlen);
368           a_lnd = dlen;
369           if return_ename then a_ename = substr (pathname, l + 2 - i, i - 1);
370 name_return:
371           a_code = code;
372           return;
373 
374 /* * * * * * * * * * * * * * * * * * */
375 
376 ref_name: entry (a_segptr, a_namecnt, a_refname, a_code);
377 
378           namecnt = max(a_namecnt, 1);
379 
380           segnum = fixed (baseno (a_segptr), 17);
381           call ref_name_$get_refname (segnum, namecnt, rname, code);
382           if code = 0 then do;
383              a_refname = rname;
384              a_code = 0;
385           end;
386           else a_code = code;
387 
388           return;
389 
390 /* * * * * * * * * * * * * * * * * * */
391 
392 trans_sw: entry (a_newsw, a_oldsw);
393 
394           newsw = a_newsw;
395           oldsw = fixed (pds$transparent, 2);
396           if newsw > 3 then go to fin2;                     /* newsw > 3 means only go to fin2 oldsw, don't change newsw */
397           if newsw < 0 then go to fin2;
398           if newsw = 0 then pds$transparent = "0"b;
399           else if newsw = 1 then pds$transparent = "01"b;
400           else pds$transparent = "11"b;                     /* can't have modified transparent without used */
401 
402 fin2:     a_oldsw = oldsw;
403           return;
404 %page; %include dc_find_dcls;
405 %page; %include dir_entry;
406 %page; %include dir_name;
407 %page; %include fs_types;
408 %page; %include rnt;
409 %page; %include sdw;
410 %page; %include search_rule_flags;
411 %page; %include stack_header;
412      end fs_get;