1
2
3
4
5
6 link: lk: proc;
7
8
9
10
11
12
13
14
15
16 dcl WHITE_SPACE char (5) int static options (constant) init (" ^K
17 ^L");
18 dcl ALL_ENTRIES fixed bin (2) int static options (constant) init (3);
19 dcl (CHASE init (1), NO_CHASE init (0)) fixed (1) int static options (constant);
20 dcl LINK_TYPE fixed (2) int static options (constant) init (0);
21
22
23
24 dcl arg char (arg_len) based (arg_ptr);
25
26
27
28 dcl (dn, first_arg, target_dn) char (168);
29 dcl (en, target_en) char (32);
30
31 dcl (chase_sw, check_sw, copy_names_sw, errsw, got_path_sw, name_sw, second_arg_sw, star_sw) bit (1);
32
33 dcl arg_ptr ptr;
34
35 dcl (arg_count, arg_len, i) fixed;
36 dcl type fixed bin (2);
37 dcl code fixed bin (35);
38
39 dcl error_table_$action_not_performed fixed (35) ext;
40 dcl error_table_$badopt fixed (35) ext;
41 dcl error_table_$namedup fixed (35) ext;
42 dcl error_table_$no_s_permission fixed (35) ext;
43 dcl error_table_$noentry fixed (35) ext;
44 dcl error_table_$segnamedup fixed (35) ext;
45
46 dcl check_star_name_$entry entry (char (*), fixed (35));
47 dcl (com_err_, com_err_$suppress_name) entry options (variable);
48 dcl copy_names_ entry (char (*), char (*), char (*), char (*), char (*), bit (1), fixed (35));
49 dcl cu_$arg_count entry (fixed, fixed (35));
50 dcl cu_$arg_ptr entry (fixed, ptr, fixed, fixed (35));
51 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed (35));
52 dcl get_equal_name_ entry (char (*), char (*), char (*), fixed (35));
53 dcl get_system_free_area_ entry returns (ptr);
54 dcl get_wdir_ entry returns (char (168));
55 dcl hcs_$append_link entry (char (*), char (*), char (*), fixed (35));
56 dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed (35));
57 dcl hcs_$star_ entry (char (*), char (*), fixed (2), ptr, fixed, ptr, ptr, fixed (35));
58 dcl hcs_$status_minf entry (char (*), char (*), fixed (1), fixed (2), fixed (24), fixed (35));
59 dcl nd_handler_ entry (char (*), char (*), char (*), fixed (35));
60 dcl pathname_ entry (char (*), char (*)) returns (char (168));
61
62 dcl (fixed, null, search, verify) builtin;
63
64 dcl cleanup condition;
65 %page;
66 call cu_$arg_count (arg_count, code);
67 if code ^= 0 then do;
68 call com_err_ (code, "link");
69 return;
70 end;
71
72 chase_sw, check_sw, copy_names_sw, got_path_sw = "0"b;
73
74 do i = 1 to arg_count;
75 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
76
77 if verify (arg, WHITE_SPACE) = 0 then do;
78 call com_err_ (0, "link", "Invalid name ""^a""", arg);
79 return;
80 end;
81
82 if substr (arg, 1, 1) = "-" then
83 if arg = "-chase" then chase_sw = "1"b;
84 else if arg = "-no_chase" then chase_sw = "0"b;
85 else if arg = "-check" | arg = "-ck" then check_sw = "1"b;
86 else if arg = "-no_check" | arg = "-nck" then check_sw = "0"b;
87 else if arg = "-copy_names" | arg = "-cpnm" then copy_names_sw = "1"b;
88 else if arg = "-no_copy_names" | arg = "-ncpnm" then copy_names_sw = "1"b;
89 else if arg = "-name" | arg = "-nm" then i = i + 1;
90 else do;
91 call com_err_ (error_table_$badopt, "link", "^a", arg);
92 return;
93 end;
94
95 else got_path_sw = "1"b;
96 end;
97
98 if ^got_path_sw then do;
99 call com_err_$suppress_name (0, "link",
100 "Usage: link target_path1 link_path1 ... target_pathN {link_pathN} {-control_args}");
101 return;
102 end;
103
104 second_arg_sw = "0"b;
105 name_sw = "0"b;
106
107 do i = 1 to arg_count;
108
109 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
110
111 if substr (arg, 1, 1) = "-" then
112 if arg = "-name" | arg = "-nm" then do;
113 i = i + 1;
114 if i > arg_count then do;
115 call com_err_ (0, "link", "No value specified for -name");
116 return;
117 end;
118 name_sw = "1"b;
119 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
120 if second_arg_sw then go to SECOND_ARG;
121 else do;
122 call com_err_ (0, "link", "-name not allowed before target path.");
123 return;
124 end;
125 end;
126 else;
127
128 else if ^second_arg_sw then do;
129 FIRST_ARG:
130 second_arg_sw = "1"b;
131 first_arg = arg;
132
133 call expand_pathname_ (arg, target_dn, target_en, code);
134 if code ^= 0 then do;
135 PATH_ERR: call com_err_ (code, "link", "^a", arg);
136 return;
137 end;
138
139 call check_star_name_$entry (target_en, code);
140 if code ^= 0 then
141 if code = 1 | code = 2 then star_sw = "1"b;
142 else do;
143 call com_err_ (code, "link", "^a", target_en);
144 return;
145 end;
146 else star_sw = "0"b;
147 end;
148
149 else do;
150
151 name_sw = "0"b;
152 SECOND_ARG:
153 second_arg_sw = "0"b;
154
155 if name_sw then do;
156 name_sw = "0"b;
157 dn = get_wdir_ ();
158 en = arg;
159 end;
160 else do;
161 call expand_pathname_ (arg, dn, en, code);
162 if code ^= 0 then go to PATH_ERR;
163
164 call check_star_name_$entry (en, code);
165 if code ^= 0 then do;
166 if code = 1 | code = 2 then call com_err_ (0, "link",
167 "Stars not allowed in link pathname. ^a", arg);
168 else call com_err_ (code, "link", "^a", en);
169 return;
170 end;
171 end;
172
173 if star_sw then call link_stars (dn, en, target_dn, target_en);
174
175 else call link_one (dn, en, target_dn, target_en);
176 end;
177 end;
178
179 if second_arg_sw then do;
180 if search (first_arg, "<>") = 0 then do;
181 call com_err_ (0, "link", "Link points to itself; not created. ^a",
182 pathname_ (target_dn, target_en));
183 return;
184 end;
185
186 dn = get_wdir_ ();
187 en = "===";
188
189 if star_sw then call link_stars (dn, en, target_dn, target_en);
190
191 else call link_one (dn, en, target_dn, target_en);
192 end;
193
194 RETURN: return;
195 %page;
196 link_one: proc (P_dn, P_en, P_target_dn, P_target_en);
197
198 dcl (P_dn, P_en, P_target_dn, P_target_en) char (*);
199 dcl (target_dn, target_path, ultimate_dn) char (168);
200 dcl (en, target_en, ultimate_en) char (32);
201
202 target_dn = P_target_dn;
203 target_en = P_target_en;
204 target_path = pathname_ (target_dn, target_en);
205
206 call get_equal_name_ (target_en, P_en, en, code);
207 if code ^= 0 then do;
208 call com_err_ (code, "link", "^a for ^a", en, target_en);
209 return;
210 end;
211
212 if check_sw then do;
213 call hcs_$status_minf (target_dn, target_en, CHASE, type, 0, code);
214 if code ^= 0 & code ^= error_table_$no_s_permission then do;
215 if code = error_table_$noentry then do;
216 call hcs_$status_minf (target_dn, target_en, NO_CHASE, 0, 0, code);
217 if code ^= error_table_$noentry then do;
218 call com_err_ (0, "link", "No ultimate target for intended target ^a",
219 pathname_ (target_dn, target_en));
220 go to RETURN;
221 end;
222 end;
223 call com_err_ (code, "link", "Link target ^a", pathname_ (target_dn, target_en));
224 go to RETURN;
225 end;
226 end;
227
228 if chase_sw then do;
229 call hcs_$get_link_target (target_dn, target_en, ultimate_dn, ultimate_en, code);
230 if ultimate_dn ^= "" then do;
231 target_dn = ultimate_dn;
232 target_en = ultimate_en;
233 target_path = pathname_ (target_dn, target_en);
234 end;
235 end;
236
237 LINK: call hcs_$append_link (P_dn, en, target_path, code);
238 if code ^= 0 then
239 if code = error_table_$namedup then do;
240 call nd_handler_ ("link", P_dn, en, code);
241 if code = 0 then go to LINK;
242 else if code = error_table_$action_not_performed then return;
243 else go to RETURN;
244 end;
245 else call com_err_ (code, "link", "^a^[>^]^a", dn, dn ^= ">", en);
246
247 else if copy_names_sw then do;
248 call copy_names_ (target_dn, target_en, P_dn, en, "link -copy_names", errsw, code);
249 if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segnamedup then
250 if errsw then call com_err_ (code, "link", "^a", pathname_ (P_dn, en));
251 else call com_err_ (code, "link", "^a", pathname_ (target_dn, target_en));
252 end;
253
254 end link_one;
255 %page;
256 link_stars: proc (P_dn, P_en, P_target_dn, P_target_en);
257
258 dcl (P_dn, P_en, P_target_dn, P_target_en) char (*);
259 dcl 1 entries (entry_count) based (entries_ptr),
260 2 pad bit (18) unaligned,
261 2 nindex bit (18) unaligned;
262 dcl names (999) char (32) aligned based (names_ptr);
263 dcl target_en char (32);
264 dcl area area based (area_ptr);
265 dcl (area_ptr, entries_ptr, names_ptr) ptr;
266 dcl (entry_count, j) fixed bin;
267
268 area_ptr = get_system_free_area_ ();
269 entries_ptr, names_ptr = null;
270
271 on cleanup call star_cleanup;
272
273 call hcs_$star_ (P_target_dn, P_target_en, ALL_ENTRIES, area_ptr, entry_count, entries_ptr, names_ptr, code);
274 if code ^= 0 then do;
275 call com_err_ (code, "link", "^a", pathname_ (P_target_dn, P_target_en));
276 return;
277 end;
278
279 do j = 1 to entry_count;
280
281 target_en = names_ptr -> names (fixed (entries_ptr -> entries (j).nindex));
282
283 call link_one (P_dn, P_en, P_target_dn, target_en);
284 end;
285
286 call star_cleanup;
287
288 return;
289
290 star_cleanup: proc;
291
292 if entries_ptr ^= null then free entries in (area);
293 if names_ptr ^= null then free names in (area);
294
295 end star_cleanup;
296
297 end link_stars;
298
299 end link;