1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 
 16 /****^  HISTORY COMMENTS:
 17   1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
 18      audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
 19      Modified to call object_lib_$initiate to check if a file is an object
 20      segment or MSF instead of calling object_info_.
 21   2) change(88-10-24,Brunelle), approve(88-10-24,MCR7911),
 22      audit(88-10-25,Wallman), install(88-10-28,MR12.2-1199):
 23      Dprint_arg_version_7 removed from declaration in program because now
 24      defined in dprint_arg include file.
 25                                                    END HISTORY COMMENTS */
 26 
 27 
 28 /* dprint and dpunch commands: request the I/O daemon to print or punch a segment */
 29 
 30 /* Initially coded in April 1969 by V. Voydock */
 31 /* Modified on February 12, 1970 at 5:50 P. M. by V. Voydock */
 32 /* Modified by Nate Adleman on December 20, 1969 at 1123 to add the no_questions entry which does not ask the user
 33           any questions */
 34 /* Modified for punching by M A Padlipsky April 1970 */
 35 /* Modified by M. Weaver 22 April 1970--added  test_init1 entry for on-line testing */
 36 /* Modified by E. Stone 10/21/70 to add the call to com_query_ */
 37 /* Modified by Dennis Capps 11/02/71 to change the call to com_query_ to a call to command_query_ */
 38 /* Modified by M. Weaver 15 January 1971 22:30 */
 39 /* Modified by Paul Green on January 23, l971 to clean up the incredible mess, and to add the number_of_copies feature */
 40 /* Modified April 1973 by R. S. Coren to interface through dprint_ using message segments, and to add the -destination
 41           and -queue control arguments */
 42 /* Modified October 1973 by Robert S. Coren to accept -device_class control argument and handle submission errors more
 43           cleanly */
 44 /* Modified by J. Stern 3/11/75 to add -request_type control arg */
 45 /* Bug with -bf at end of line fixed 12/8/75 Steve Herbst */
 46 /* Changed not to query in most error cases 10/18/76 S. Herbst */
 47 /* Modified by J. C. Whitmore, 5/78, for new dprint_arg structure during Daemon upgrade, bug fixes and removal of -dvc */
 48 /* Modified to reject object segments by S. Herbst, 10/25/78 */
 49 /* Modified to allow object segments to be punched, but not printed 02/03/79 W. Olin Sibert */
 50 /* Modified: 8 March 1981 by G. Palter to ignore error_table_$no_s_permission, accept "-ind" for "-indent" and do some
 51           minor cleanup of the code */
 52 /* Modified: 10 April 1981 by G. Palter to allow request type names longer than 8 characters */
 53 /* Modified: 8 September 1981 by G. Palter to accept -forms control argument */
 54 /* Modified: June 1982 by R. Kovalcik to accept -defer_until_process_termination */
 55 /* Modified: 84-11-01 by EJ Sharpe for new mdc_$get_lv_access arglist, also
 56                     create internal dprint_arg_version_7 constant since include
 57                     file has been upgraded to version 8 */
 58 
 59 dprint:
 60 dp:  procedure () options (variable);
 61 
 62 
 63           dcl     count                  fixed bin;         /* number of segs already queued by this invocation */
 64           dcl     indx                   fixed bin;
 65           dcl     lng                    fixed bin;
 66           dcl     lcnt                   fixed bin;         /* number of realready quests already queued */
 67           dcl     nargs                  fixed bin;
 68           dcl     i                      fixed bin;
 69           dcl     queue                  fixed bin;
 70           dcl     mode                   bit (36) aligned;
 71           dcl     pub_bit                bit (1) aligned;   /* Public flag returned from mdc_$get_lv_access */
 72           dcl     code                   fixed bin (35);
 73           dcl     bc                     fixed bin (24);    /* for bit count of MSF component */
 74           dcl     fcbp                   ptr;
 75           dcl     dum                    ptr;               /* dummy pointer arg */
 76 
 77           dcl     max_queues             fixed bin int static options (constant) init (4);
 78           dcl     MAX_PAGE_WIDTH         fixed bin int static options (constant) init (136); /* For prt300, etc. */
 79           dcl     io_coord               char (16) int static options (constant) init ("IO.SysDaemon");
 80 
 81           dcl     (addr, index, length, max, null, substr, fixed, rtrim, string) builtin;
 82 
 83           dcl     cleanup                condition;
 84 
 85           dcl     punching               initial ("0"b) bit (1); /* punch or print? */
 86           dcl     no_questions           initial ("0"b) bit (1); /* mainly for use by daemons */
 87 
 88           dcl     control_arg            bit (1);           /* last arg was a control arg */
 89           dcl     some_path              bit (1);           /* some pathname in command line */
 90           dcl     brief                  bit (1);           /* for brief option */
 91           dcl     top_lbl_sw             bit (1);
 92           dcl     bottom_lbl_sw          bit (1);
 93           dcl     access_lbl_sw          bit (1);
 94 
 95           dcl     (del_acc, r_acc)       bit (1) aligned;
 96           dcl     s_acc                  bit (1) aligned;
 97 
 98           dcl     access_class           bit (72) aligned;
 99           dcl     access_label           char (136);
100 
101           dcl     accname                character (32);
102           dcl     generic_type           char (32);
103           dcl     rqt_gen_type           char (32);
104           dcl     last_arg               char (32);
105 
106           dcl     argptr                 ptr;
107           dcl     seg_ptr                ptr;
108           dcl     based_arg              char (lng) based (argptr) unaligned;
109           dcl     arg                    char (32) aligned;
110           dcl     ans                    char (12) varying;
111 
112           dcl     question               char (132);
113           dcl     quest_len              fixed bin;
114 
115           dcl     dname                  char (168);        /* directory in which segment to be printed lies */
116           dcl     ename                  char (32);         /* entry name of segment to be printed */
117           dcl     lvname                 char (32);
118           dcl     suf                    char (1) aligned;
119           dcl     id                     char (6) aligned;
120 
121           dcl     (error_table_$lock_wait_time_exceeded, error_table_$dirseg, error_table_$no_s_permission, error_table_$noentry,
122                   error_table_$nostars, error_table_$moderr, error_table_$badopt, error_table_$notalloc, error_table_$id_not_found,
123                   error_table_$zero_length_seg)
124                                          fixed binary (35) external;
125 
126           dcl     cv_dec_check_          entry (char (*), fixed bin (35)) returns (fixed bin);
127           dcl     dprint_                entry (char (*), char (*), ptr, fixed bin (35));
128           dcl     dprint_$check_daemon_access entry (character (*), character (*), character (*), bit (1) aligned, bit (1) aligned,
129                                          bit (1) aligned, character (*), fixed binary (35));
130           dcl     dprint_$queue_contents entry (character (*), fixed binary, fixed binary, fixed binary (35));
131           dcl     check_star_name_$entry entry (char (*), fixed bin (35));
132           dcl     cu_$arg_ptr            ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
133           dcl     cu_$arg_count          entry (fixed bin, fixed binary (35));
134           dcl     expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
135           dcl     (com_err_, com_err_$suppress_name) entry options (variable);
136           dcl     ioa_                   entry options (variable);
137           dcl     ioa_$ioa_stream        entry options (variable);
138           dcl     ioa_$rsnnl             entry options (variable);
139           dcl     command_query_         entry options (variable);
140           dcl     hcs_$status_long       entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
141           dcl     hcs_$get_access_class  entry (char (*), char (*), bit (72) aligned, fixed bin (35));
142           dcl     convert_authorization_$to_string entry (bit (72) aligned, char (*), fixed bin (35));
143           dcl     mdc_$find_lvname       entry (bit (36), char (*), fixed bin (35));
144           dcl     mdc_$get_lv_access     entry (char (*), fixed bin (3), bit (36) aligned, bit (1) aligned, fixed bin (35));
145           dcl     iod_info_$generic_type entry (char (*), char (32), fixed bin (35));
146           dcl     msf_manager_$open      entry (char (*), char (*), ptr, fixed bin (35));
147           dcl     msf_manager_$close     entry (ptr);
148           dcl     msf_manager_$get_ptr   entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
149 
150           dcl     hcs_$terminate_noname  entry (ptr, fixed bin (35));
151           dcl     object_lib_$initiate   entry (char (*), char (*), char (*), bit (1), ptr, fixed bin (24), bit (1), fixed bin (35));
152 
153 %include dprint_arg;
154 
155 %include query_info;
156 
157 %include branch_status;
158 ^L
159 /* dprint: dp: procedure () options (variable); */
160 
161           queue = 0;                                        /* we want the default queue */
162           go to start_1;
163 
164 
165 no_questions:
166      entry () options (variable);
167           no_questions = "1"b;
168           queue = 0;                                        /* want the default queue */
169           go to start_1;
170 
171 
172 dp1: entry () options (variable);
173           queue = 1;
174           go to start_1;
175 
176 dp2: entry () options (variable);
177           queue = 2;
178           go to start_1;
179 
180 dpunch:
181 dpn: entry () options (variable);
182           punching = "1"b;
183           queue = 0;                                        /* again the default queue */
184           go to start_1;
185 
186 dpn1: entry () options (variable);
187           punching = "1"b;
188           queue = 1;
189           go to start_1;
190 
191 dpn2: entry () options (variable);
192           punching = "1"b;
193           queue = 2;
194 
195 
196 start_1:  call init_variables;                              /* get everything set up */
197 
198           if punching then do;
199                     dprint_arg.pt_pch = 2;                  /* indicate to dprint_ that its a punch request */
200                     dprint_arg.output_module = 3;           /* assume mcc format as a default */
201                     generic_type,
202                          dprint_arg.request_type = "punch";
203                     id = "dpunch";
204                end;
205           else do;
206                     dprint_arg.pt_pch = 1;                  /* otherwise this is a print request */
207                     dprint_arg.output_module = 1;
208                     generic_type,
209                          dprint_arg.request_type = "printer";
210                     id = "dprint";
211                end;
212 
213 
214           on cleanup begin;
215                     if fcbp ^= null then call msf_manager_$close (fcbp);
216                end;
217 
218           call cu_$arg_count (nargs, code);                 /* check if called as a command also */
219           if code ^= 0 then do;
220                     call com_err_ (code, id);
221                     return;
222                end;
223 
224           do indx = 1 to nargs;
225                call cu_$arg_ptr (indx, argptr, lng, code);  /* get args, one at a time */
226                arg = based_arg;                             /* copy into temp for option testing */
227 
228                if index (based_arg, "-") = 1 then call process_control_arg;
229                else do;                                     /* Process path name */
230                          some_path = "1"b;
231                          control_arg = "0"b;                /* seen a pathname since last control arg */
232                          call expand_pathname_ (based_arg, dname, ename, code);
233                          if code ^= 0 then do;
234                                    call com_err_ (code, id, "^a", based_arg);
235                                    go to no_request;
236                               end;
237                          else do;
238                                    call check_star_name_$entry (ename, code);
239                                    if code ^= 0 then do;
240                                              if code <= 2 then /* a legal star name */
241                                                   code = error_table_$nostars;
242                                              call com_err_ (code, id, "^a^[>^]^a", dname, (dname ^= ">"), ename);
243                                              go to no_request;
244                                         end;
245                                    else do;
246                                                             /* See if file to be printed exists */
247                                              call hcs_$status_long (dname, ename, 1, addr (branch_status), null, code);
248                                              if (code ^= 0) & (code ^= error_table_$no_s_permission) then do;
249                                                        call com_err_ (code, id, "^a^[>^]^a", dname, (dname ^= ">"), ename);
250 no_request:                                            call com_err_$suppress_name (0, id, "Request not submitted.");
251                                                   end;
252                                              else do;
253 
254 /* Make sure it's not an object segment. */
255 
256                                                        if ^punching then do;
257                                                                  call object_lib_$initiate (dname, ename, "", "1"b, seg_ptr, (0), (""b), code);
258                                                                  if seg_ptr ^= null then do;
259                                                                            call hcs_$terminate_noname (seg_ptr, (0)); /* we're done with it */
260                                                                            call com_err_ (0, id, "^a^[>^]^a is an object segment.",
261                                                                                 dname, (dname ^= ">"), ename);
262                                                                            go to no_request;
263                                                                       end;
264                                                             end;
265 
266 /* Check that user has access, length nonzero, public volume */
267 
268                                                        if ^substr (branch_status.mode, 2, 1) then do; /* check "r" access */
269                                                                  code = error_table_$moderr;
270 CALL_COM:                                                        call com_err_ (code, id, "^a^[>^]^a", dname, (dname ^= ">"), ename);
271                                                                  go to no_request;
272                                                             end;
273 
274                                                        dprint_arg.bit_count = 0; /* start with no length */
275 
276                                                        if branch_status.type = directory_type then do; /* directory or MSF */
277                                                                  if branch_status.bit_count = "0"b then do; /* a directory */
278                                                                            code = error_table_$dirseg;
279                                                                            go to CALL_COM;
280                                                                       end;
281 
282 /*                                      For the MSF case, get the total bit count of the file */
283 
284                                                                  call msf_manager_$open (dname, ename, fcbp, code);
285                                                                  if code ^= 0 then go to CALL_COM;
286 
287                                                                  do i = 0 to fixed (branch_status.bit_count, 17, 0) - 1;
288                                                                       bc = 0;
289                                                                       call msf_manager_$get_ptr (fcbp, i, "0"b, dum, bc, code);
290                                                                       if code ^= 0 then go to CALL_COM;
291                                                                       dprint_arg.bit_count = dprint_arg.bit_count + bc; /* add the bit count */
292                                                                  end;
293 
294                                                                  call msf_manager_$close (fcbp);
295                                                                  fcbp = null;
296                                                             end;
297                                                        else dprint_arg.bit_count = fixed (branch_status.bit_count, 24);
298 
299                                                        if dprint_arg.bit_count = 0 then do;
300                                                                  code = error_table_$zero_length_seg;
301                                                                  go to CALL_COM;
302                                                             end;
303 
304 /* Check that the volume is public. */
305                                                        call mdc_$find_lvname (branch_status.lvid, lvname, code);
306                                                        if code ^= 0 then go to CALL_COM;
307                                                        call mdc_$get_lv_access (lvname, 1, mode, pub_bit, code);
308                                                        if code ^= 0 then go to CALL_COM; /* The daemon driver won't mount it */
309                                                        if ^pub_bit then do;
310                                                                  call com_err_ (0, id, "^a^[>^]^a is not on a public volume.",
311                                                                       dname, (dname ^= ">"), ename);
312                                                                  go to no_request;
313                                                             end;
314 
315 /* find out if daemon has access to the segment. If not, warn the user */
316 
317                                                        call dprint_$check_daemon_access (dname, ename, dprint_arg.request_type, del_acc,
318                                                             r_acc, s_acc, accname, code);
319                                                        if code ^= 0 then /* We couldn't figure it out. */
320                                                             call com_err_ (0, id, "Warning: Unable to check IO daemon access to ^a^[>^]^a",
321                                                                  dname, (dname ^= ">"), ename);
322                                                        else do;
323                                                                  if ^r_acc then do;
324                                                                            call com_err_ (0, id, "^a requires r access to ^a^[>^]^a",
325                                                                                 accname, dname, (dname ^= ">"), ename);
326                                                                            go to no_request;
327                                                                       end;
328                                                                  if ^s_acc then
329                                                                       call ask ("^a does not have status access on ^a^s");
330                                                                  if ^del_acc & (dprint_arg.delete ^= 0) then
331                                                                       call com_err_ (0, "Warning", "^a has insufficient access to delete ^a^[>^]^a",
332                                                                            io_coord, dname, (dname ^= ">"), ename); /* this is info only */
333                                                             end;
334 
335 QUEUE_IT:                                              if access_lbl_sw then call make_access_lbl;
336                                                        dprint_arg.queue = queue; /* want default or from -q arg */
337                                                        code = 0;
338                                                        call dprint_ (dname, ename, dpap, code);
339                                                        if code ^= 0 then do;
340                                                                  call com_err_ (code, id, "Queue ^d for request type ^a",
341                                                                       dprint_arg.queue, dprint_arg.request_type);
342                                                                  if code = error_table_$lock_wait_time_exceeded then do; /* Queue locked */
343                                                                            if no_questions then go to next_arg; /* If he won't answer questions, skip it. */
344                                                                            query_info.status_code = code;
345                                                                            call command_query_ (addr (query_info), ans, id, "Do you wish to try again?");
346                                                                            if ans = "yes" then go to QUEUE_IT;
347                                                                       end;
348 
349                                                                  else if code = error_table_$noentry then
350                                                                       call ioa_$ioa_stream ("error_output",
351                                                                            "Request type or queue argument is probably invalid.");
352 
353                                                                  else if code = error_table_$notalloc then
354                                                                       call ioa_$ioa_stream ("error_output", "Queue is full at present.");
355                                                                  go to no_request;
356                                                             end;
357 
358                                                        else count = count + 1;
359                                                   end;
360                                         end;
361                               end;
362                     end;
363 next_arg: end;
364 
365           if count > 0 | ^some_path then call print_counts;
366           if some_path then if control_arg then call com_err_ (0, id,
367                          "Warning: Control arguments following last pathname are ignored.");
368 
369 RETURN:   return;
370 
371 /* ===================================================== */
372 
373 process_control_arg: proc;
374 
375           if arg = "-bf" | arg = "-brief" then do;          /* Check for brief option */
376                     brief = "1"b;
377                     return;                                 /* allow -bf at end of line */
378                end;
379 
380           control_arg = "1"b;                               /* must be an option if it has "-" */
381 
382           if arg = "-dl" | arg = "-delete" | arg = "-d" then /* Check for "print and delete" */
383                dprint_arg.delete = 1;
384           else if arg = "-he" | arg = "-header" | arg = "-h" then do; /* Check for heading option */
385                     call get_parameter;
386                     dprint_arg.heading = " for " || based_arg;
387                end;
388           else if arg = "-ds" | arg = "-destination" then do; /* Check for destination */
389                     call get_parameter;
390                     dprint_arg.destination = based_arg;
391                end;
392           else if arg = "-rqt" | arg = "-request_type" then do;
393                     if count > 0 then call print_counts;
394                     call get_parameter;
395                     call iod_info_$generic_type (based_arg, rqt_gen_type, code);
396                     if code ^= 0 then
397                          if code = error_table_$id_not_found then do;
398                                    call com_err_ (0, id, "Unknown request type.  ^a", based_arg);
399                                    go to RETURN;
400                               end;
401                          else call com_err_ (0, id, "Warning -- Unable to check request type ^a.", based_arg);
402                     else if rqt_gen_type ^= generic_type then do;
403                               call com_err_ (0, id, "Request type ^a is not of generic type ^a.", based_arg, generic_type);
404                               go to RETURN;
405                          end;
406                     else if length (rtrim (based_arg)) > length (dprint_arg.request_type) then do;
407                               call com_err_ (0, id, "Request type name ""^a"" must be ^d characters or less in length.",
408                                    based_arg, length (dprint_arg.request_type));
409                               go to RETURN;
410                          end;
411                     else dprint_arg.request_type = based_arg;
412                end;
413           else if arg = "-cp" | arg = "-copy" then do;      /* Check for number of copies */
414                     call get_parameter;
415                     dprint_arg.copies = cv_dec_check_ (based_arg, code);
416                     if code ^= 0 | dprint_arg.copies < 1 then do;
417                               call com_err_ (0, id, "Invalid copy request ^a", based_arg);
418                               go to RETURN;
419                          end;
420                     else if dprint_arg.copies > 4 then do;
421                               dprint_arg.copies = 4;
422                               call com_err_ (0, id, "Too many copies specified; 4 will be supplied.");
423                          end;
424                end;
425           else if arg = "-nt" | arg = "-notify" then /* Check for "notify me when printed" */
426                dprint_arg.notify = 1;
427           else if arg = "-q" | arg = "-queue" then do;      /* Check for queue number */
428                     if count > 0 then call print_counts;
429                     call get_parameter;
430                     queue = cv_dec_check_ (based_arg, code);
431                     if code ^= 0 | queue < 1 | queue > max_queues then do; /* dprint_ makes the real check */
432                               call com_err_ (0, id, "Invalid queue number ^a", based_arg);
433                               go to RETURN;
434                          end;
435                end;
436           else if arg = "-dupt" | arg = "-defer_until_process_termination" then /* Check for "don't process request until requesting process terminates" */
437                dprint_arg.defer_until_process_termination = 1;
438           else if ^punching then do;                        /* If printing, lots of new interesting args. */
439                     if arg = "-nep" | arg = "-no_endpage" then do;
440                               dprint_arg.nep = "1"b;
441                               go to NL_OPT;                 /* no_label implied */
442                          end;
443                     else if arg = "-ned" | arg = "-non_edited" then
444                          dprint_arg.non_edited = "1"b;
445                     else if arg = "-tc" | arg = "-truncate" then
446                          dprint_arg.truncate = "1"b;
447                     else if arg = "-ll" | arg = "-line_length" then do;
448                               call get_parameter;
449                               dprint_arg.line_lth = cv_dec_check_ (based_arg, code);
450                               if code ^= 0 | dprint_arg.line_lth < 1 then do;
451                                         call com_err_ (0, id, "Invalid line length ^a", based_arg);
452                                         go to RETURN;
453                                    end;
454                               if dprint_arg.line_lth > MAX_PAGE_WIDTH then
455                                    call com_err_ (0, "Warning", "Specified line length is greater then normal printer maximum.");
456                          end;
457                     else if arg = "-in" | arg = "-ind" | arg = "-indent" then do;
458                               call get_parameter;
459                               dprint_arg.lmargin = cv_dec_check_ (based_arg, code);
460                               if code ^= 0 | dprint_arg.lmargin < 0 | dprint_arg.lmargin > MAX_PAGE_WIDTH then do;
461                                         call com_err_ (0, id, "Invalid indentation ^a", based_arg);
462                                         go to RETURN;
463                                    end;
464                          end;
465                     else if arg = "-sg" | arg = "-single" then
466                          dprint_arg.single = "1"b;
467                     else if arg = "-pl" | arg = "-page_length" then do;
468                               call get_parameter;
469                               dprint_arg.page_lth = cv_dec_check_ (based_arg, code);
470                               if code ^= 0 | dprint_arg.page_lth < 1 then do;
471                                         call com_err_ (0, id, "Invalid page length ^a", based_arg);
472                                         go to RETURN;
473                                    end;
474                          end;
475                     else if arg = "-lbl" | arg = "-label" then do;
476                               call get_parameter;
477                               if dprint_arg.nep then do;
478 skip_labels:                            call com_err_ (0, id, "Warning: Labels are ignored with -no_endpage.");
479                                         return;
480                                    end;
481                               dprint_arg.top_label,
482                                    dprint_arg.bottom_label = based_arg;
483                               access_lbl_sw = "0"b;         /* don't try to add access labels */
484                               top_lbl_sw, bottom_lbl_sw = "1"b; /* this is like giving both */
485                               dprint_arg.center_top_label,
486                                    dprint_arg.center_bottom_label = "0"b; /* only center access labels */
487                          end;
488                     else if arg = "-tlbl" | arg = "-top_label" then do;
489                               call get_parameter;
490                               if dprint_arg.nep then go to skip_labels;
491                               dprint_arg.top_label = based_arg;
492                               if bottom_lbl_sw then access_lbl_sw = "0"b; /* when both cancel access labels */
493                               top_lbl_sw = "1"b;
494                               dprint_arg.center_top_label = "0"b; /* in case this was set from last path */
495                          end;
496                     else if arg = "-blbl" | arg = "-bottom_label" then do;
497                               call get_parameter;
498                               if dprint_arg.nep then go to skip_labels;
499                               dprint_arg.bottom_label = based_arg;
500                               if top_lbl_sw then access_lbl_sw = "0"b; /* when both cancel access labels */
501                               bottom_lbl_sw = "1"b;
502                               dprint_arg.center_bottom_label = "0"b; /* only for access labels */
503                          end;
504                     else if arg = "-albl" | arg = "-access_label" then do;
505                               if dprint_arg.nep then go to skip_labels;
506                               access_lbl_sw = "1"b;
507                               top_lbl_sw, bottom_lbl_sw = "0"b;
508                          end;
509                     else if arg = "-nlbl" | arg = "-no_label" then do;
510 NL_OPT:                       access_lbl_sw = "0"b;
511                               top_lbl_sw, bottom_lbl_sw = "0"b;
512                               dprint_arg.center_top_label, dprint_arg.center_bottom_label = "0"b;
513                               dprint_arg.top_label, dprint_arg.bottom_label = "";
514                          end;
515                     else if arg = "-forms" then do;
516                               call get_parameter;
517                               if length (rtrim (based_arg)) > length (dprint_arg.form_name) then do;
518                                         call com_err_ (0, id, "Forms specification ""^a"" must be ^d characters or less in length.",
519                                              based_arg, length (dprint_arg.form_name));
520                                         go to RETURN;
521                                    end;
522                               dprint_arg.form_name = based_arg;
523                          end;
524                     else do;                                /* Bad dprint option */
525 BAD_OPT:                      call com_err_ (error_table_$badopt, id, " ^a ", based_arg);
526                               go to RETURN;
527                          end;
528                end;                                         /* of print-only */
529           else if punching then do;                         /* punch args only for dpunch */
530                     if arg = "-mcc" then
531                          dprint_arg.output_module = 3;
532                     else if arg = "-raw" then
533                          dprint_arg.output_module = 4;
534                     else if arg = "-7p" | arg = "-7punch" then
535                          dprint_arg.output_module = 2;
536                     else go to BAD_OPT;                     /* Bad dpunch option */
537                end;
538 
539      end process_control_arg;
540 
541 print_counts: proc;
542 
543           if ^brief then do;
544                     dprint_arg.queue = queue;               /* use the queue we would have requested */
545                                                             /* find out how many requests have already been queued */
546                     call dprint_$queue_contents (dprint_arg.request_type, dprint_arg.queue, lcnt, code);
547                     if code ^= 0 then
548                          call com_err_ (code, id, "Cannot get count for request type ^a, queue ^d",
549                               dprint_arg.request_type, dprint_arg.queue);
550 
551                     else if count = 0 then do;
552                               if lcnt = 1 then suf = ""; else suf = "s";
553                               call ioa_ ("^d request^a in ^a queue ^d", lcnt, suf, dprint_arg.request_type, dprint_arg.queue);
554                          end;
555                     else do;
556                               if count = 1 then suf = ""; else suf = "s";
557                               call ioa_ ("^d request^a signalled, ^d already in ^a queue ^d", count, suf, max (0, lcnt - count),
558                                    dprint_arg.request_type, dprint_arg.queue);
559                               count = 0;
560                          end;
561 
562                end;
563 
564      end print_counts;
565 
566 ask: proc (format);
567 
568           dcl     format                 char (*);
569 
570           if no_questions then go to next_arg;
571           call ioa_$rsnnl (format, question, quest_len, accname, dname, ename);
572           query_info.status_code = code;
573           call command_query_ (addr (query_info), ans, id, "^a.  Do you still wish request?  ", question);
574           if substr (ans, 1, 3) ^= "yes" then go to next_arg;
575           go to QUEUE_IT;                                   /* User wants request anyway */
576 
577      end ask;
578 
579 make_access_lbl: proc;
580 
581           access_label = "";
582           call hcs_$get_access_class (dname, ename, access_class, code);
583           if code ^= 0 then go to CALL_COM;
584           call convert_authorization_$to_string (access_class, access_label, code);
585           if ^top_lbl_sw then do;
586                     dprint_arg.top_label = access_label;
587                     dprint_arg.center_top_label = "1"b;
588                end;
589           if ^bottom_lbl_sw then do;
590                     dprint_arg.bottom_label = access_label;
591                     dprint_arg.center_bottom_label = "1"b;
592                end;
593      end make_access_lbl;
594 
595 
596 
597 
598 get_parameter: proc;
599 
600           last_arg = arg;
601           indx = indx + 1;
602           call cu_$arg_ptr (indx, argptr, lng, code);
603           if code ^= 0 then do;
604                     call com_err_ (0, id, "No value specified for ^a.", last_arg);
605                     go to RETURN;
606                end;
607 
608      end get_parameter;
609 
610 init_variables: proc;
611 
612           fcbp = null;                                      /* no MSF's open yet */
613           count = 0;                                        /* number of requests already signalled */
614 
615           query_info.yes_or_no_sw = "1"b;                   /* only want yes or no on queries */
616 
617           control_arg = "0"b;
618           some_path = "0"b;
619           brief = "0"b;
620           top_lbl_sw = "0"b;
621           bottom_lbl_sw = "0"b;
622           access_lbl_sw = "1"b;                             /* we want access labels by default if not blank */
623 
624           dpap = addr (dprint_arg_buf);                     /* initialize template dprint args */
625           dprint_arg.version = dprint_arg_version_7;
626           dprint_arg.queue = queue;                         /* initialize the queue as requested */
627           dprint_arg.notify = 0;                            /* establish some default values */
628           dprint_arg.copies = 1;
629           dprint_arg.delete = 0;
630           dprint_arg.dest = "";                             /* be sure the old fields are set */
631           dprint_arg.forms = "";
632           dprint_arg.heading = "";
633           string (dprint_arg.carriage_control) = "0"b;
634           dprint_arg.lmargin = 0;
635           dprint_arg.line_lth = 0;
636           dprint_arg.page_lth = 0;
637           dprint_arg.top_label = "";
638           dprint_arg.bottom_label = "";
639           dprint_arg.chan_stop_path = "";
640           dprint_arg.destination = "";                      /* just be sure this is clear */
641           dprint_arg.form_name = "";                        /* and this too */
642           dprint_arg.defer_until_process_termination = 0;
643 
644      end init_variables;
645 
646      end dprint;