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