1 inq: proc options (variable);
2
3 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
4 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
5 dcl requote_string_ entry (char(*)) returns(char(*));
6
7 dcl arg char (arg_len) based (arg_ptr);
8 dcl nargs fixed bin;
9 dcl ret_arg char (ret_arg_len) varying based (ret_arg_ptr);
10 dcl op char (op_len) based (op_ptr);
11 dcl key char (key_len) based (key_ptr);
12 dcl (arg_len, op_len, key_len, ret_arg_len)
13 fixed bin (21);
14 dcl (arg_ptr, op_ptr, key_ptr, ret_arg_ptr)
15 ptr;
16 dcl userid char (200) varying;
17 dcl privacy_flag bit (1);
18 dcl userid_array (userid_count) char (20) varying based (userid_ptr);
19 dcl userid_count fixed bin;
20 dcl userid_ptr ptr;
21
22 dcl get_system_free_area_ entry() returns(ptr);
23 dcl inquire_$get_all_userids entry (ptr, ptr, fixed bin, fixed bin(35));
24 dcl inquire_$close_db entry (fixed bin (35));
25 dcl inquire_$set_fields entry (ptr, ptr, fixed bin(35));
26 dcl inquire_$fields_from_userid
27 entry (char(*) var, ptr, ptr, ptr, fixed bin(35));
28 dcl inquire_$fields_from_lname entry (char(*) var, ptr, ptr, ptr, fixed bin(35));
29 dcl inquire_$get_field_privacy_flags
30 entry (ptr, ptr, fixed bin(35));
31 dcl inquire_$set_field_privacy_flags
32 entry (ptr, ptr, fixed bin(35));
33 dcl inquire_$get_entry_privacy_flag
34 entry (bit (1), fixed bin (35));
35 dcl inquire_$set_entry_privacy_flag
36 entry (bit (1), fixed bin (35));
37
38
39 dcl inquire_data_$field_names external fixed bin;
40 dcl known_field_names (inquire_data_$field_count) char (32) based (addr (inquire_data_$field_names));
41
42 dcl code fixed bin (35);
43 dcl (i, j) fixed bin;
44 dcl (error_table_$not_act_fnc,
45 error_table_$bad_conversion,
46 error_table_$noarg,
47 error_table_$active_function,
48 error_table_$badopt,
49 inquire_et_$invalid_field)
50 fixed bin(35) ext static;
51 dcl active_fnc_err_ entry() options(variable);
52 dcl active_fnc_err_$suppress_name
53 entry() options(variable);
54 dcl com_err_ entry() options(variable);
55 dcl com_err_$suppress_name entry() options(variable);
56 dcl error_proc variable entry () options (variable);
57 dcl error_proc_suppress_name variable entry () options (variable);
58 dcl ioa_ entry() options(variable);
59
60 dcl af bit (1);
61 dcl whoami char (3) static options (constant) init ("inq");
62
63 %include inquire_dcls;
64
65 call cu_$af_return_arg (nargs, ret_arg_ptr, ret_arg_len, code);
66 if code = error_table_$not_act_fnc
67 then do;
68 af = "0"b;
69 error_proc = com_err_;
70 error_proc_suppress_name = com_err_$suppress_name;
71 end;
72 else do;
73 if code ^= 0 then do;
74 call active_fnc_err_ (code, whoami, "Getting argument count.");
75 return;
76 end;
77 af = "1"b;
78 error_proc = active_fnc_err_;
79 error_proc_suppress_name = active_fnc_err_$suppress_name;
80 end;
81
82 if nargs < 1 then do;
83 call error_proc_suppress_name (0, whoami, "Usage: ^[[^]inq KEY {args}^[]^]", af, af);
84 return;
85 end;
86
87 call cu_$arg_ptr (1, op_ptr, op_len, code);
88 if code ^= 0 then do;
89 call error_proc (code, whoami, "While getting first argument.");
90 return;
91 end;
92
93 if op = "-get" then go to inq_GET;
94 else if op = "-set" then go to inq_SET;
95 else if op = "-list" | op = "-ls" then go to inq_LIST;
96 else if op = "-get_fpriv" then go to inq_GET_FIELD_PRIV;
97 else if op = "-set_fpriv" then go to inq_SET_FIELD_PRIV;
98 else if op = "-get_epriv" then go to inq_GET_ENTRY_PRIV;
99 else if op = "-set_epriv" then go to inq_SET_ENTRY_PRIV;
100 else if op = "-close" then go to inq_CLOSE;
101 else if op = "-all_userids" | op = "-au" then go to inq_GET_ALL_USERIDS;
102 else if op = "-getn" then go to inq_GET_NAME;
103
104 call error_proc (error_table_$badopt, whoami, op);
105 return;
106
107 inq_GET: if nargs < 2 then userid = "";
108 else do;
109 call get_userid_arg ();
110 if code ^= 0 then do;
111 call error_proc (code, whoami, "Getting userid arg.");
112 return;
113 end;
114 end;
115 allocate inq_field_names;
116 if nargs < 3 then do;
117 inq_field_names.name_count = inquire_data_$field_count;
118 inq_field_names.name = known_field_names;
119 end;
120
121 else do;
122 inq_field_names.name_count = nargs - 2;
123 do i = 3 to nargs;
124 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
125 if code ^= 0 then do;
126 call error_proc (code, whoami, "Getting argument ^i.", i);
127 return;
128 end;
129 inq_field_names.name (i-2) = arg;
130 end;
131 end;
132
133 call inquire_$fields_from_userid (userid, addr (inq_field_names), get_system_free_area_ (), inq_field_values_ptr, code);
134 if code ^= 0 then do;
135 if code > 0 then call error_proc (code, whoami, "Getting Inquire information.");
136
137 else call error_proc (inquire_et_$invalid_field, whoami, "No such field: ^a.", inq_field_names.name (-code));
138 return;
139 end;
140
141 if ^af & nargs > 2 then call ioa_ ("Userid: ^a", userid);
142 if af then ret_arg = "";
143 do i = 1 to inq_field_values.value_count;
144 if af then do;
145 if i > 1 then ret_arg = ret_arg || " ";
146 ret_arg = ret_arg || requote_string_ ((inq_field_values.entry (1).value (i)));
147 end;
148 else call ioa_ ("^a:^20t^a", inq_field_names.name (i), inq_field_values.entry (1).value (i));
149 end;
150 return;
151
152 inq_SET: if af then do;
153 call com_err_ (error_table_$active_function, whoami, "The -set key is not permitted in active functions.");
154 return;
155 end;
156
157 if code ^= 0 then do;
158 call error_proc_suppress_name (0, whoami, "Usage: inq -set {field_name field_val} ...");
159 return;
160 end;
161
162 if nargs-1 ^= 2 * divide (nargs-1, 2, 17) then do;
163 call error_proc (0, whoami, "Last field_name has no corresponding value.");
164 return;
165 end;
166
167 allocate inq_field_names;
168 inq_fv_size = 1;
169 allocate inq_field_values;
170 inq_field_names.name_count, inq_field_values.value_count = divide ((nargs - 1), 2, 17);
171 inq_field_values.entry_count = 1;
172 do i = 2 to nargs by 2;
173 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
174 if code ^= 0 then do;
175 call error_proc (code, whoami, "Getting argument ^i.", i);
176 return;
177 end;
178 inq_field_names.name (divide (i, 2, 17)) = arg;
179 call cu_$arg_ptr (i+1, arg_ptr, arg_len, code);
180 if code ^= 0 then do;
181 call error_proc (code, whoami, "Getting argument ^i.", i+1);
182 return;
183 end;
184 inq_field_values.entry (1).value (divide (i, 2, 17)) = arg;
185 end;
186 call inquire_$set_fields (addr (inq_field_names), addr (inq_field_values), code);
187 if code ^= 0 then do;
188 if code > 0 then call error_proc (code, whoami, "Setting Inquire information.");
189
190 else call error_proc (inquire_et_$invalid_field, whoami, "No such field: ^a.", inq_field_names.name (-code));
191 return;
192 end;
193
194 return;
195
196 inq_GET_FIELD_PRIV:
197 allocate inq_field_names;
198 if nargs < 2 then do;
199 inq_field_names.name_count = inquire_data_$field_count;
200 inq_field_names.name = known_field_names;
201 end;
202
203 else do;
204 inq_field_names.name_count = nargs - 1;
205 do i = 2 to nargs;
206 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
207 if code ^= 0 then do;
208 call error_proc (code, whoami, "Getting argument ^i.", i);
209 return;
210 end;
211 inq_field_names.name (i-1) = arg;
212 end;
213 end;
214
215 allocate inq_field_privacies;
216 call inquire_$get_field_privacy_flags (addr (inq_field_names), inq_field_privacies_ptr, code);
217 if code ^= 0 then do;
218 if code > 0 then call error_proc (code, whoami, "Getting Inquire information.");
219
220 else call error_proc (inquire_et_$invalid_field, whoami, "No such field: ^a.", inq_field_names.name (-code));
221 return;
222 end;
223
224 if af then ret_arg = "";
225 do i = 1 to inq_field_privacies.value_count;
226 if af then do;
227 if i > 1 then ret_arg = ret_arg || " ";
228 if inq_field_privacies.value (i) then ret_arg = ret_arg || "true";
229 else ret_arg = ret_arg || "false";
230 end;
231 else call ioa_ ("^a:^20t^[Private^;Public^]", inq_field_names.name (i), inq_field_privacies.value (i));
232 end;
233 return;
234
235 inq_SET_FIELD_PRIV:
236 if af then do;
237 call com_err_ (error_table_$active_function, whoami, "The -set_fpriv key is not permitted in active functions.");
238 return;
239 end;
240
241 call get_userid_arg ();
242 if code ^= 0 then do;
243 call error_proc_suppress_name (0, whoami, "Usage: inq -set_fpriv userid {field_name field_val} ...");
244 return;
245 end;
246
247 if nargs-1 ^= 2 * divide (nargs-1, 2, 17) then do;
248 call error_proc (0, whoami, "Last field_name has no corresponding value.");
249 return;
250 end;
251
252 allocate inq_field_names;
253 allocate inq_field_privacies;
254 inq_field_names.name_count, inq_field_privacies.value_count = divide ((nargs - 1), 2, 17);
255 do i = 2 to nargs by 2;
256 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
257 if code ^= 0 then do;
258 call error_proc (code, whoami, "Getting argument ^i.", i);
259 return;
260 end;
261 j = divide (i, 2, 17);
262 inq_field_names.name (j) = arg;
263 call cu_$arg_ptr (i+1, arg_ptr, arg_len, code);
264 if code ^= 0 then do;
265 call error_proc (code, whoami, "Getting argument ^i.", i+1);
266 return;
267 end;
268 if arg = "on" | arg = "1" | arg = "true"
269 then inq_field_privacies.value (j) = "1"b;
270 else if arg = "off" | arg = "0" | arg = "false"
271 then inq_field_privacies.value (j) = "0"b;
272 else do;
273 call error_proc (error_table_$bad_conversion, whoami, "^/Privacy values must be ""on"", ""1"", ""true"", ""off"", ""0"", or ""false"". Not ""^a"".", arg);
274 return;
275 end;
276 end;
277 call inquire_$set_field_privacy_flags (addr (inq_field_names), addr (inq_field_privacies), code);
278 if code ^= 0 then do;
279 if code > 0 then call error_proc (code, whoami, "Setting Inquire information.");
280
281 else call error_proc (inquire_et_$invalid_field, whoami, "No such field: ^a.", inq_field_names.name (-code));
282 return;
283 end;
284
285 return;
286
287 inq_GET_ENTRY_PRIV:
288 call inquire_$get_entry_privacy_flag (privacy_flag, code);
289 if code ^= 0 then do;
290 call error_proc (code, whoami, "Getting Inquire information.");
291 return;
292 end;
293 if af then do;
294 if privacy_flag then ret_arg = "true";
295 else ret_arg = "false";
296 end;
297 else call ioa_ ("Privacy flag is ^[on^;off^]", privacy_flag);
298 return;
299
300 inq_SET_ENTRY_PRIV:
301 if af then do;
302 call com_err_ (error_table_$active_function, whoami, "The -set_epriv key is not permitted in active functions.");
303 return;
304 end;
305
306 call cu_$arg_ptr (2, arg_ptr, arg_len, code);
307 if code ^= 0 then do;
308 call error_proc (code, whoami, "Getting entry privacy setting.");
309 return;
310 end;
311 if arg = "on" | arg = "1" | arg = "true"
312 then call inquire_$set_entry_privacy_flag ("1"b, code);
313 else if arg = "off" | arg = "0" | arg = "false"
314 then call inquire_$set_entry_privacy_flag ("0"b, code);
315 else do;
316 call error_proc (error_table_$bad_conversion, whoami, "^/Privacy value must be ""on"", ""1"", ""true"", ""off"", ""0"", or ""false"". Not ""^a"".", arg);
317 return;
318 end;
319 if code ^= 0 then call error_proc (code, whoami, "Setting privacy flag.");
320 return;
321
322 inq_CLOSE:
323 if af then do;
324 call com_err_ (error_table_$active_function, whoami, "The -close key is not permitted in active functions.");
325 return;
326 end;
327
328 call inquire_$close_db (code);
329 if code ^= 0 then do;
330 call error_proc (code, whoami, "Closing the database.");
331 return;
332 end;
333 return;
334
335 inq_GET_ALL_USERIDS:
336 call inquire_$get_all_userids (get_system_free_area_ (), userid_ptr, userid_count, code);
337 if code ^= 0 then do;
338 call error_proc (code, whoami, "Getting userids.");
339 return;
340 end;
341 if af then do;
342 ret_arg = "";
343 do i = 1 to userid_count;
344 if i ^= 1 then ret_arg = ret_arg || " ";
345 ret_arg = ret_arg || requote_string_ ((userid_array (i)));
346 end;
347 end;
348 else call ioa_ ("^(^3(^20a^5x^)^/^)", userid_array);
349 return;
350
351 inq_GET_NAME:
352 if nargs < 2 then do;
353 call error_proc_suppress_name (0, whoami, "Usage: ^[[^]inq -getn last_name {field_name} ...^[]^]", af, af);
354 return;
355 end;
356 else do;
357 call get_userid_arg ();
358 if code ^= 0 then do;
359 call error_proc (code, whoami, "Getting last_name arg.");
360 return;
361 end;
362 end;
363 allocate inq_field_names;
364 if nargs < 3 then do;
365 inq_field_names.name_count = inquire_data_$field_count;
366 inq_field_names.name = known_field_names;
367 end;
368
369 else do;
370 inq_field_names.name_count = nargs - 2;
371 do i = 3 to nargs;
372 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
373 if code ^= 0 then do;
374 call error_proc (code, whoami, "Getting argument ^i.", i);
375 return;
376 end;
377 inq_field_names.name (i-2) = arg;
378 end;
379 end;
380
381 call inquire_$fields_from_lname (userid, addr (inq_field_names), get_system_free_area_ (), inq_field_values_ptr, code);
382 if code ^= 0 then do;
383 if code > 0 then call error_proc (code, whoami, "Getting Inquire information.");
384
385 else call error_proc (inquire_et_$invalid_field, whoami, "No such field: ^a.", inq_field_names.name (-code));
386 return;
387 end;
388
389 if ^af then call ioa_ ("Last name: ^a", userid);
390 if af then ret_arg = "";
391 do j = 1 to inq_field_values.entry_count;
392 if ^af then call ioa_ ("");
393 do i = 1 to inq_field_values.value_count;
394 if af then do;
395 if i > 1 | j > 1 then ret_arg = ret_arg || " ";
396 ret_arg = ret_arg || requote_string_ ((inq_field_values.entry (j).value (i)));
397 end;
398 else call ioa_ ("^a:^20t^a", inq_field_names.name (i), inq_field_values.entry (j).value (i));
399 end;
400 end;
401 return;
402
403
404 get_userid_arg:
405 proc ();
406
407 if nargs < 2 then do;
408 code = error_table_$noarg;
409 return;
410 end;
411 call cu_$arg_ptr (2, arg_ptr, arg_len, code);
412 if code = 0 then userid = arg;
413 return;
414 end;
415
416 inq_LIST: if af then do;
417 ret_arg = "";
418 do i = 1 to inquire_data_$field_count;
419 if i ^= 1 then ret_arg = ret_arg || " ";
420 ret_arg = ret_arg || rtrim (known_field_names (i));
421 end;
422 end;
423 else call ioa_ ("Valid fields:^/^(^4( ^14a^)^/^)^/", known_field_names);
424 return;
425
426
427 end;