1
2
3
4
5
6
7
8
9
10
11 get_raw_access_: proc (tptr, tlng, user_name, ring, dmode, emode, code);
12
13
14
15
16
17
18
19
20
21 dcl (tdir, dir, retpn) char (168);
22 dcl (ent, tent) char (32);
23 dcl user_name char (*);
24 dcl (ring, rl, rlev, lng, tlng, rlng) fixed bin;
25 dcl code fixed bin (35);
26 dcl (dmode, emode) fixed bin (5);
27 dcl (dptr, eptr, pptr, tptr, bptr, nptr) ptr;
28 dcl noent bit (1) aligned;
29 dcl name1 char (tlng) based (tptr);
30 dcl name2 char (lng) based (dptr);
31 dcl name3 char (lng) based (pptr);
32 dcl narea (0:959);
33 dcl (addr, fixed, index, null, ptr, substr, unspec) builtin;
34
35 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
36 dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35));
37 dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
38 dcl (error_table_$root, error_table_$noentry) ext fixed bin (35);
39 dcl tarea (0:3);
40
41
42 rl, rlev = 0;
43 bptr = addr (tarea);
44 nptr = addr (narea);
45 pptr = addr (tdir);
46 call absolute_pathname_ (name1, tdir, code);
47 if code ^= 0 then return;
48 rlng = index (tdir, " ") - 1;
49
50 call chase_ (pptr, rlng, retpn, code);
51
52 if code ^= 0 then do;
53 if code = error_table_$noentry then do;
54 dir = retpn;
55 dptr = addr (dir);
56 noent = "1"b;
57 go to get_dmode;
58 end;
59 else return;
60 end;
61 noent = "0"b;
62 pptr = addr (retpn);
63 dptr = addr (dir);
64 eptr = addr (ent);
65 lng = index (retpn, " ") - 1;
66 call expand_pathname_ (name3, dir, ent, code);
67 if code ^= 0 then go to ret;
68
69 call hcs_$get_user_effmode (dir, ent, user_name, ring, emode, code);
70 if code ^= 0 then go to ret;
71
72
73
74
75 get_dmode: pptr = addr (tdir);
76 eptr = addr (tent);
77 lng = index (dir, " ") - 1;
78 call expand_pathname_ (name2, tdir, tent, code);
79 if code ^= 0 then go to ret;
80
81 call hcs_$get_user_effmode (tdir, tent, user_name, ring, dmode, code);
82
83 if code = 0 then if noent then code = error_table_$noentry;
84 else;
85 else if code = error_table_$root then do;
86 code = 0;
87 dmode = 0100b;
88 end;
89 ret: return;
90
91
92 chase_: proc (pptr, tlng, retpn, code) recursive;
93
94
95
96
97
98
99
100
101
102
103
104 dcl (path based (pptr), retpn, dir) char (168);
105 dcl (ent, tent) char (32);
106 dcl mode fixed bin (5);
107 dcl (lng, tlng, trl, elng, i) fixed bin;
108 dcl code fixed bin (35);
109 dcl (pptr, dptr, eptr) ptr;
110 dcl 1 link based aligned,
111 2 (type bit (2), nnames bit (16), nrp bit (18)) unaligned,
112 2 (dtem, dtd) bit (36) unaligned,
113 2 (pnl, pnrp) bit (18) unaligned;
114 dcl lpname char (168) aligned based;
115 dcl gt char (1) var;
116
117 dcl (error_table_$noaccess, error_table_$linkmoderr, error_table_$toomanylinks,
118 error_table_$pathlong) ext fixed bin;
119 dcl area_ entry (fixed bin, ptr);
120 dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
121
122
123
124
125 dptr = addr (dir);
126 process: do i = tlng to 1 by -1 while (substr (path, i, 1) ^= ">"); end;
127 ent = substr (path, i+1, tlng-i);
128 if i = 1 then do;
129 retpn = ">";
130 go to havadir;
131 end;
132 dir = substr (path, 1, i-1);
133 lng = i - 1;
134 trl = rl;
135 rlev = rlev + 1;
136
137 call chase_ (dptr, lng, retpn, code);
138 if code ^= 0 then return;
139 rlev = rlev - 1;
140
141 havadir: call area_ (960, nptr);
142
143 call hcs_$status_ (retpn, ent, 0, bptr, nptr, code);
144 if code ^= 0 then do;
145 noacc: if rlev > 0 & code = error_table_$noentry then code = error_table_$noaccess;
146 return;
147 end;
148 rl = trl;
149 lng = index (retpn, " ") - 1;
150
151 if bptr -> link.type = "00"b then do;
152
153 do i = lng to 1 by -1 while (substr (retpn, i, 1) ^= ">"); end;
154 if i = 1 then dir = ">";
155 else dir = substr (retpn, 1, i-1);
156 tent = substr (retpn, i+1, lng-i);
157 if user_name ^= "" then do;
158 call hcs_$get_user_effmode (dir, tent, user_name, ring, mode, code);
159 if code ^= 0 then go to noacc;
160 if ^substr (unspec (mode), 34, 1) then do;
161 code = error_table_$linkmoderr;
162 return;
163 end;
164 end;
165 if rl >= 10 then do;
166 code = error_table_$toomanylinks;
167 return;
168 end;
169
170 path = ptr (nptr, bptr -> link.pnrp) -> lpname;
171 tlng = fixed (bptr -> link.pnl, 18);
172 rl = rl + 1;
173 go to process;
174 end;
175
176
177
178 elng = index (ent, " ");
179 if elng = 0 then elng = 33;
180 if lng = -1 then go to too_long;
181 if lng + elng > 168 then do;
182 too_long: code = error_table_$pathlong;
183 return;
184 end;
185 rl = 0;
186 if lng = 1 then gt = ""; else gt = ">";
187 retpn = substr (retpn, 1, lng) || gt || ent;
188 return;
189 end chase_;
190 end get_raw_access_;