1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22 test_match_star_name:
23 procedure () options (variable);
24
25 declare (addcharno, character, index, ltrim, rtrim, substr)
26 builtin;
27
28 declare arg_count fixed bin (17),
29 arg_len fixed bin (21),
30 arg_ptr ptr,
31 argx fixed bin (17),
32 charx fixed bin (17),
33 check_star_type fixed bin (2),
34 check_status fixed bin (35),
35 entry_star_type fixed bin (2),
36 entry_status fixed bin (35),
37 idx fixed bin (17),
38 invert bit (1) aligned,
39 mask bit (36),
40 match_status fixed bin (35),
41 path_star_type fixed bin (2),
42 path_status fixed bin (35),
43 self_status fixed bin (35),
44 star_mask bit (36) aligned,
45 star_type fixed bin (2),
46 status fixed bin (35),
47 star_len fixed bin (21),
48 star_ptr ptr,
49 whoami char (32);
50
51 declare arg char (arg_len) based (arg_ptr),
52 star char (star_len) based (star_ptr);
53
54 declare (
55 error_table_$archive_pathname,
56 error_table_$bad_arg,
57 error_table_$bad_file_name,
58 error_table_$badequal,
59 error_table_$badpath,
60 error_table_$badstar,
61 error_table_$entlong,
62 error_table_$inconsistent,
63 error_table_$invalid_ascii,
64 error_table_$nomatch,
65 error_table_$nostars,
66 error_table_$null_name_component
67 ) fixed bin (35) external;
68
69 declare check_star_name_ entry (char (*), bit (36), fixed bin (2), fixed bin (35)),
70 check_star_name_$entry entry (char (*), fixed bin (35)),
71 check_star_name_$path entry (char (*), fixed bin (35)),
72 com_err_ entry () options (variable),
73 com_err_$suppress_name entry () options (variable),
74 convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned),
75 cu_$arg_count entry (fixed bin (17), fixed bin (35)),
76 cu_$arg_ptr entry (fixed bin (17), ptr, fixed bin (21), fixed bin (35)),
77 ioa_ entry () options (variable),
78 match_star_name_ entry (char (*), char (*), fixed bin (35)),
79 requote_string_ entry (char (*)) returns (char (*));
80 %page;
81 %include check_star_name;
82 %page;
83 whoami = "test_match_star_name";
84
85 call cu_$arg_count (arg_count, status);
86 if status ^= 0
87 then do;
88 call com_err_ (status, whoami);
89 return;
90 end;
91
92 if arg_count < 2
93 then do;
94 call com_err_$suppress_name (0, whoami, "Usage: ^a key starname {matchnames}", whoami);
95 return;
96 end;
97
98 call cu_$arg_ptr (1, arg_ptr, arg_len, (0));
99 if arg_len = 0 then go to INVALID_KEYWORD;
100
101 idx = index ("012", substr (arg, 1, 1)) - 1;
102 if idx >= 0
103 then do;
104 check_star_type, entry_star_type, path_star_type = idx;
105 check_status, entry_status, match_status, path_status, self_status = 0;
106 end;
107 else if substr (arg, 1, 1) = "b"
108 then do;
109 check_star_type, entry_star_type, path_star_type = 0;
110 check_status, entry_status, match_status, path_status, self_status = error_table_$badstar;
111 end;
112 else go to INVALID_KEYWORD;
113
114 if arg_len = 1 then go to DO_TEST;
115 charx = 2;
116
117 idx = index ("012", substr (arg, charx, 1)) - 1;
118 if idx >= 0
119 then do;
120 entry_star_type = idx;
121 entry_status = 0;
122 end;
123 else if substr (arg, charx, 1) = "b"
124 then do;
125 entry_star_type = 0;
126 entry_status = error_table_$badstar;
127 end;
128 else go to CHECK_NOMATCH;
129
130 if arg_len = charx then go to DO_TEST;
131 charx = charx + 1;
132
133 idx = index ("012", substr (arg, charx, 1)) - 1;
134 if idx >= 0
135 then do;
136 path_star_type = idx;
137 path_status = 0;
138 end;
139 else if substr (arg, charx, 1) = "b"
140 then do;
141 path_star_type = 0;
142 path_status = error_table_$badstar;
143 end;
144 else go to CHECK_NOMATCH;
145
146 if charx = arg_len then go to DO_TEST;
147 charx = charx + 1;
148
149 CHECK_NOMATCH:
150 if substr (arg, charx) = "n"
151 then match_status = error_table_$nomatch;
152 else do;
153 INVALID_KEYWORD:
154 call com_err_ (0, whoami, "Invalid key ^a.", requote_string_ (rtrim (arg)));
155 return;
156 end;
157
158 DO_TEST:
159 call cu_$arg_ptr (2, star_ptr, star_len, (0));
160
161 call check_star_name_ (star, CHECK_STAR_IGNORE_ALL, star_type, status);
162 if star_type ^= check_star_type | status ^= check_status
163 then call error ("CHECK", check_star_type, check_status);
164
165 call check_star_name_$entry (star, status);
166 if status >= 0 & status <= 2
167 then do;
168 star_type = status;
169 status = 0;
170 end;
171 else star_type = 0;
172 if star_type ^= entry_star_type | status ^= entry_status
173 then call error ("ENTRY", entry_star_type, entry_status);
174
175 call check_star_name_$path (star, status);
176 if status >= 0 & status <= 2
177 then do;
178 star_type = status;
179 status = 0;
180 end;
181 else star_type = 0;
182 if star_type ^= path_star_type | status ^= path_status then call error ("PATH", path_star_type, path_status);
183
184 star_type = -1;
185 call match_star_name_ (star, star, status);
186 if status ^= self_status then call error ("SELF", -1, self_status);
187
188 do argx = 3 to arg_count;
189
190 call cu_$arg_ptr (argx, arg_ptr, arg_len, (0));
191
192 call match_star_name_ (arg, star, status);
193 if status ^= match_status then call error ("MATCH", -1, match_status);
194 end;
195
196 return;
197 %page;
198 error:
199 procedure (test, expected_star_type, expected_status);
200
201 declare test char (*) parameter,
202 expected_star_type fixed bin (2) parameter,
203 expected_status fixed bin (35) parameter;
204
205 declare actual_message char (256) varying,
206 expected_message char (256) varying;
207
208 call classify_status (star_type, expected_star_type, status, expected_status, actual_message);
209 if expected_star_type = -1
210 then call classify_status (expected_star_type, expected_star_type, expected_status, expected_status + 1,
211 expected_message);
212 else call classify_status (expected_star_type, expected_star_type + 1, expected_status, expected_status + 1,
213 expected_message);
214
215 if test = "MATCH"
216 then call ioa_ ("^a:^9t^a expected ^a got ^a with ^a.", test, requote_string_ (star), expected_message,
217 actual_message, requote_string_ (arg));
218 else call ioa_ ("^a:^9t^a expected ^a got ^a.", test, requote_string_ (star), expected_message, actual_message)
219 ;
220
221 return;
222
223 end error;
224
225 classify_status:
226 procedure (star_type, expected_star_type, status, expected_status, message);
227
228 declare star_type fixed bin (2) parameter,
229 expected_star_type fixed bin (2) parameter,
230 status fixed bin (35) parameter,
231 expected_status fixed bin (35) parameter,
232 message char (256) varying parameter;
233
234 declare buffer char (100) aligned;
235
236 if star_type = expected_star_type
237 then message = "";
238 else do;
239 if star_type = 0 then message = "type 0";
240 else if star_type = 1 then message = "type 1";
241 else if star_type = 2 then message = "type 2";
242 else message = "invalid type " || ltrim (character (star_type));
243
244 if status = expected_status then return;
245
246 message = message || " with ";
247 end;
248
249 if status = 0 then message = message || "NO_ERROR";
250 else if status = error_table_$archive_pathname then message = message || "ARCHIVE_PATHNAME";
251 else if status = error_table_$bad_arg then message = message || "BAD_ARG";
252 else if status = error_table_$bad_file_name then message = message || "BAD_FILE_NAME";
253 else if status = error_table_$badequal then message = message || "BADEQUAL";
254 else if status = error_table_$badpath then message = message || "BADPATH";
255 else if status = error_table_$badstar then message = message || "BADSTAR";
256 else if status = error_table_$entlong then message = message || "ENTLONG";
257 else if status = error_table_$inconsistent then message = message || "INCONSISTENT";
258 else if status = error_table_$invalid_ascii then message = message || "INVALID_ASCII";
259 else if status = error_table_$nomatch then message = message || "NOMATCH";
260 else if status = error_table_$nostars then message = message || "NOSTARS";
261 else if status = error_table_$null_name_component then message = message || "NULL_NAME_COMPONENT";
262 else do;
263 call convert_status_code_ (status, (""), buffer);
264 message = message || "unexpected ";
265 message = message || requote_string_ (rtrim (buffer));
266 end;
267
268 return;
269
270 end classify_status;
271 %page;
272 test_check_star_name:
273 entry () options (variable);
274
275 whoami = "test_check_star_name";
276
277 call cu_$arg_count (arg_count, status);
278 if status ^= 0
279 then do;
280 call com_err_ (status, whoami);
281 return;
282 end;
283
284 if arg_count ^= 4
285 then do;
286 call com_err_$suppress_name (0, whoami, "Usage: ^a starname mask_list type code", whoami);
287 return;
288 end;
289
290 call cu_$arg_ptr (2, arg_ptr, arg_len, (0));
291
292 mask = ""b;
293 do while (arg_len > 0);
294
295 star_len = index (arg, ",") - 1;
296 if star_len < 0 then star_len = arg_len;
297 if star_len = 0
298 then do;
299 call com_err_ (0, whoami, "Bad syntax in mask_list ^a.", requote_string_ (arg));
300 return;
301 end;
302
303 star_ptr = arg_ptr;
304 arg_len = arg_len - star_len - 1;
305 arg_ptr = addcharno (arg_ptr, star_len + 1);
306
307 invert = "0"b;
308 if substr (star, 1, 1) = "^"
309 then do;
310 invert = "1"b;
311 star_len = star_len - 1;
312 star_ptr = addcharno (star_ptr, 1);
313 end;
314
315 if star = "entry_default" then star_mask = CHECK_STAR_ENTRY_DEFAULT;
316 else if star = "ignore_all" then star_mask = CHECK_STAR_IGNORE_ALL;
317 else if star = "ignore_archive" then star_mask = CHECK_STAR_IGNORE_ARCHIVE;
318 else if star = "ignore_entrypoint" then star_mask = CHECK_STAR_IGNORE_ENTRYPOINT;
319 else if star = "ignore_equal" then star_mask = CHECK_STAR_IGNORE_EQUAL;
320 else if star = "ignore_length" then star_mask = CHECK_STAR_IGNORE_LENGTH;
321 else if star = "ignore_nonascii" then star_mask = CHECK_STAR_IGNORE_NONASCII;
322 else if star = "ignore_null" then star_mask = CHECK_STAR_IGNORE_NULL;
323 else if star = "ignore_path" then star_mask = CHECK_STAR_IGNORE_PATH;
324 else if star = "process_archive" then star_mask = CHECK_STAR_PROCESS_ARCHIVE;
325 else if star = "path_default" then star_mask = CHECK_STAR_PATH_DEFAULT;
326 else if star = "process_entrypoint" then star_mask = CHECK_STAR_PROCESS_ENTRYPOINT;
327 else if star = "process_path" then star_mask = CHECK_STAR_PROCESS_PATH;
328 else if star = "reject_wild" then star_mask = CHECK_STAR_REJECT_WILD;
329 else if star = "unimplemented" then star_mask = CHECK_STAR_UNIMPLEMENTED;
330 else do;
331 call com_err_ (0, whoami, "Invalid mask keyword ^a.", requote_string_ (star));
332 return;
333 end;
334
335 if invert
336 then mask = mask & ^star_mask;
337 else mask = mask | star_mask;
338 end;
339
340 call cu_$arg_ptr (3, arg_ptr, arg_len, (0));
341
342 if arg = "0" | arg = "pl1" | arg = "pl/1" | arg = "PL1" | arg = "PL/I"
343 then check_star_type = STAR_TYPE_USE_PL1_COMPARE;
344 else if arg = "1" | arg = "match" | arg = "MATCH" then check_star_type = STAR_TYPE_USE_MATCH_PROCEDURE;
345 else if arg = "2" | arg = "any" | arg = "ANY" | arg = "every" | arg = "EVERY"
346 then check_star_type = STAR_TYPE_MATCHES_EVERYTHING;
347 else do;
348 call com_err_ (0, whoami, "Invalid star type keyword ^a.", requote_string_ (arg));
349 return;
350 end;
351
352 call cu_$arg_ptr (4, arg_ptr, arg_len, (0));
353
354 if arg = "0" | arg = "no_error" | arg = "NO_ERROR" then check_status = 0;
355 else if arg = "archive_pathname" | arg = "ARCHIVE_PATHNAME" then check_status = error_table_$archive_pathname;
356 else if arg = "bad_arg" | arg = "BAD_ARG" then check_status = error_table_$bad_arg;
357 else if arg = "bad_file_name" | arg = "BAD_FILE_NAME" then check_status = error_table_$bad_file_name;
358 else if arg = "badequal" | arg = "BADEQUAL" then check_status = error_table_$badequal;
359 else if arg = "badpath" | arg = "BADPATH" then check_status = error_table_$badpath;
360 else if arg = "badstar" | arg = "BADSTAR" then check_status = error_table_$badstar;
361 else if arg = "entlong" | arg = "ENTLONG" then check_status = error_table_$entlong;
362 else if arg = "inconsistent" | arg = "INCONSISTENT" then check_status = error_table_$inconsistent;
363 else if arg = "invalid_ascii" | arg = "INVALID_ASCII" then check_status = error_table_$invalid_ascii;
364 else if arg = "nostars" | arg = "NOSTARS" then check_status = error_table_$nostars;
365 else if arg = "null_name_component" | arg = "NULL_NAME_COMPONENT"
366 then check_status = error_table_$null_name_component;
367 else do;
368 call com_err_ (0, whoami, "Invalid error keyword ^a.", requote_string_ (arg));
369 return;
370 end;
371
372 call cu_$arg_ptr (1, star_ptr, star_len, (0));
373
374 call check_star_name_ (star, mask, star_type, status);
375
376 if star_type ^= check_star_type | status ^= check_status
377 then call error ("CHECK", check_star_type, check_status);
378
379 return;
380
381 end test_match_star_name;