1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1984 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 copy_deadproc:      proc();
 10 
 11 /* format: off */
 12 
 13 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 14 /*                                                                           */
 15 /* This is a tool to copy dead processes from the >pdd to >dumps>save_pdirs  */
 16 /* directory.                                                                */
 17 /*                                                                           */
 18 /* Status:                                                                   */
 19 /*                                                                           */
 20 /* 0) Created:     June 1984 by B. Braun                                     */
 21 /* 1) Modified:    06 Dec 84 by B. Braun to not set system_privileges when   */
 22 /*                             getting the access class of the source dir    */
 23 /*                             fails.  Print better error message when       */
 24 /*                             deleting the source dir fails.                */
 25 /* 2) Modified: 23 Jan 85 by B. Braun to set the 256K switch.                */
 26 /*                                                                           */
 27 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 28 
 29 /****^  HISTORY COMMENTS:
 30   1) change(87-07-09,Parisek), approve(87-07-09,MCR7746),
 31      audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049):
 32      Add the no_copy_delete control functionality.
 33   2) change(87-07-18,GDixon), approve(88-03-09,MCR7861),
 34      audit(88-07-08,Farley), install(88-07-12,MR12.2-1055):
 35       A) Add copy_liveproc command.
 36       B) Correct problem in cleanup.
 37   3) change(87-10-26,GDixon), approve(88-03-09,MCR7861),
 38      audit(88-07-08,Farley), install(88-07-12,MR12.2-1055):
 39       A) Fix bug in determine_hphcs_need internal subroutine.
 40                                                    END HISTORY COMMENTS */
 41 %page;
 42 /* External entries */
 43 
 44 dcl aim_check_$equal                    entry (bit(72) aligned, bit(72) aligned) returns(bit(1) aligned);
 45 dcl check_gate_access_                  entry (char(*), ptr, fixed bin(35));
 46 dcl com_err_                            entry() options(variable);
 47 dcl command_query_$yes_no               entry() options(variable);
 48 dcl copy_pdir_$deadproc                 entry (char(*), char(*), char(*), char(*), char(*), char(*), bit(1),
 49                                                 fixed bin(35));
 50 dcl copy_pdir_$delete                   entry (char(*), char(*), char(*), fixed bin(35));
 51 dcl copy_pdir_$liveproc                 entry (char(*), char(*), char(*), char(*), char(*), char(*), bit(1),
 52                                                 char(*), fixed bin(35));
 53 dcl cu_$arg_count                       entry (fixed bin, fixed bin(35));
 54 dcl cu_$arg_ptr                         entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
 55 dcl expand_pathname_                    entry (char(*), char(*), char(*), fixed bin(35));
 56 dcl get_authorization_                  entry returns (bit (72));
 57 dcl get_privileges_                     entry() returns(bit(36) aligned);
 58 dcl hcs_$get_access_class               entry (char(*), char(*), bit(72) aligned, fixed bin(35));
 59 dcl hcs_$get_user_effmode               entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35));
 60 dcl hcs_$set_256K_switch                entry (bit(2) aligned, bit(2) aligned, fixed bin(35));
 61 dcl hcs_$status_minf                    entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
 62 dcl pathname_                           entry (char(*), char(*)) returns(char(168));
 63 dcl system_privilege_$dir_priv_off      entry (fixed bin(35));
 64 dcl system_privilege_$dir_priv_on       entry (fixed bin(35));
 65 dcl system_privilege_$seg_priv_off      entry (fixed bin(35));
 66 dcl system_privilege_$seg_priv_on       entry (fixed bin(35));
 67 dcl upd_free_name_$retain_suffix        entry (char(*), char(*), char(*), fixed bin(35));
 68 dcl upd_free_name_$restore_with_suffix  entry (char(*), char(*), char(*), fixed bin(35));
 69 
 70 dcl (
 71      error_table_$action_not_performed,
 72      error_table_$badopt,
 73      error_table_$incorrect_access,
 74      error_table_$moderr,
 75      error_table_$no_m_permission,
 76      error_table_$no_s_permission,
 77      error_table_$noarg,
 78      error_table_$noentry,
 79      error_table_$notadir
 80      )              fixed bin(35) ext static;
 81 
 82 /* options constant variables */
 83 
 84 dcl (
 85      DEFAULT_DIR                        char(5) init(">pdd>"),
 86      DIR_TYPE                           fixed bin(2) init(2),
 87      FALSE                              bit (1) init ("0"b),
 88      PDIR_PATH                          char(17) init(">dumps>save_pdirs"),
 89      PDIR_SUFFIX                        char(4) init ("pdir"),
 90      TRUE                               bit (1) init ("1"b)
 91      )                                  int static options(constant);
 92 %page;
 93 /* Builtins */
 94 
 95 dcl (addr, before, index, null,
 96      rtrim, search, substr)             builtin;
 97 
 98 /* Condition handlers */
 99 
100 dcl cleanup                             condition;
101 
102 /* Based variables */
103 
104 dcl arg                                 char (al) based (ap);
105 dcl dir_str                             char(dir_len) based(dir_ptr);
106 dcl name_str                            char(name_len) based(name_ptr);
107 dcl 1 privileges                        like aim_privileges  based (addr(priv_string));
108 
109 /* Automatic */
110 
111 dcl al                                  fixed bin(21);
112 dcl ap                                  ptr;
113 dcl argno                               fixed bin;
114 dcl caller_access_class                 bit(72) aligned;
115 dcl code                                fixed bin (35);
116 dcl delete_sw                           bit(1);
117 dcl deadproc                            bit(1);
118 dcl dir_len                             fixed bin(21);
119 dcl dir_ptr                             ptr;
120 dcl dirname                             char(168);
121 dcl ename                               char(32);
122 dcl ignore                              fixed bin(24);
123 dcl ignore_code                         fixed bin(35);
124 dcl mode                                fixed bin(5);
125 dcl myname                              char(13);
126 dcl name_sw                             bit(1);
127 dcl nargs                               fixed bin;
128 dcl name_len                            fixed bin(21);
129 dcl name_ptr                            ptr;
130 dcl ncd_sw                              bit(1);
131 dcl need_hphcs                          bit(1);
132 dcl need_priv                           bit(1);
133 dcl no_chase                            fixed bin(1);
134 dcl old_256k_sw                         bit(2) aligned;
135 dcl owner_sw                            bit(1);
136 dcl parent_access                       bit(1);
137 dcl parent_access_class                 bit (72) aligned;
138 dcl person_proj                         char(32);
139 dcl pdir_access_class                   bit (72) aligned;
140 dcl pdir_path                           char(168);
141 dcl pdir_to_create                      char(32);
142 dcl priv_string                         bit(36) aligned;
143 dcl privileges_are_set                  bit(1);
144 dcl restore_names                       bit(1);
145 dcl target_dir                          char(168);
146 dcl target_dirname                      char(168);
147 dcl target_parent                       char(168);
148 dcl tdirname                            char(168);
149 dcl tename                              char(32);
150 dcl type                                fixed bin(2);
151 dcl yes_sw bit(1);
152 %page;
153     deadproc = TRUE;
154     myname =  "copy_deadproc";
155     go to COMMON;
156 
157 copy_liveproc:
158     entry;
159 
160     deadproc = FALSE;
161     myname = "copy_liveproc";
162     go to COMMON;
163 
164 COMMON:
165     delete_sw, name_sw, ncd_sw, old_256k_sw, owner_sw,
166        need_hphcs, need_priv, restore_names,
167        parent_access, privileges_are_set = FALSE;
168     target_dir =  PDIR_PATH;
169     name_ptr, dir_ptr = null();
170     code = 0;
171     no_chase = 0;
172 
173     on cleanup begin;
174        call clean_up();
175        end;
176 
177     call cu_$arg_count(nargs, code);
178     if code ^= 0 then do;
179        call com_err_(code,myname);
180        goto EXIT;
181        end;
182 
183     if nargs = 0 then
184        if deadproc then
185           call argument_error (error_table_$noarg,
186           "^/A process directory name must be provided.^/^a",
187           "Usage: copy_deadproc {deadproc_name} {-ctl_args}", "");
188        else
189           call argument_error (error_table_$noarg,
190           "^/A process directory name and user name must be provided.^/^a",
191           "Usage: copy_liveproc {live_pdir_name} {user_name} {-ctl_args}", "");
192 %page;
193     do argno = 1 to nargs;                                  /* process args  */
194        call cu_$arg_ptr(argno, ap, al, (0));
195 
196        if deadproc & (arg = "-delete" | arg = "-dl") then delete_sw = TRUE;
197        else if deadproc & (arg = "-no_delete" | arg = "-ndl") then
198           delete_sw = FALSE;
199        else if deadproc & (arg = "-no_copy_delete" | arg = "-ncd") then
200           ncd_sw = TRUE;
201        else if arg = "-owner" | arg = "-ow" then owner_sw = TRUE;
202        else if ^deadproc & (arg = "-directory" | arg = "-dir" | arg = "-dr") then do;
203           if dir_ptr ^= null then
204              call argument_error (0,
205              "More than one directory was specified. ^a, ^a", dir_str, arg);
206           call get_next_arg ("directory name", dir_ptr, dir_len);
207           end;
208        else if arg = "-name" | arg = "-nm" then do;
209           if name_ptr ^= null() then
210              call argument_error (0, "More than one name is specified. ^a, ^a",
211              name_str, arg);
212           if deadproc then
213              call get_next_arg ("deadproc name", name_ptr, name_len);
214           else
215              call get_next_arg ("user name", name_ptr, name_len);
216           end;
217        else if substr(arg, 1, 1) ^= "-" then do;            /* assume either */
218           if ^deadproc & dir_ptr = null then do;            /*  pdir pathname */
219              dir_len = al;
220              dir_ptr = ap;
221              end;
222           else if name_ptr = null() then do;                /*  or deadproc  */
223              name_len = al;                                 /*  or user name */
224              name_ptr = ap;
225              end;
226           else call argument_error (0,
227              "More than one name is specified. ^a, ^a", name_str, arg);
228           end;
229        else call argument_error(error_table_$badopt, " ^a",arg, "");
230        end;                                                 /* end args loop */
231 
232     if deadproc then do;
233        if name_ptr = null() then
234           call argument_error(error_table_$noarg, "A deadproc name must be specified.", "", "");
235 
236        if search(name_str, "<>") = 0 then
237           pdir_path = DEFAULT_DIR || name_str;   /* process_dir_dir is the default */
238        else  pdir_path = name_str;
239        end;
240     else do;
241        if dir_ptr = null() then
242           call argument_error(error_table_$noarg, "A liveproc directory name must be specified.", "", "");
243        if name_ptr = null() then
244           call argument_error(error_table_$noarg, "A user name must be specified.", "", "");
245        if search(dir_str, "<>") = 0 then
246           pdir_path = DEFAULT_DIR || dir_str;   /* process_dir_dir is the default */
247        else  pdir_path = dir_str;
248        end;
249 %page;
250     /* need access to phcs_ */
251     call check_gate_access_ ("phcs_", null(), code);
252     if code ^= 0 then do;
253        if code = error_table_$noentry then call report_error(code, "Checking access to the phcs_ gate.", "", "");
254        else if code = error_table_$moderr then call report_error(code,
255                       "Execute access is required on the phcs_ gate.", "", "");
256        end;
257 
258     /* does the pdir specified exist? */
259 
260     call expand_pathname_ (pdir_path, dirname, ename, code);
261     if code  ^= 0 then call report_error(code, "^a", pathname_(dirname, ename), "");
262 
263     /* get access class of source pdir */
264     call hcs_$get_access_class (dirname, ename, pdir_access_class, code);
265     if code ^= 0 then call report_error(code, "^a", pathname_(dirname, ename), "");
266 
267     caller_access_class = get_authorization_ ();            /*  get the access_class of the process */
268 
269     if aim_check_$equal (caller_access_class, pdir_access_class) then;  /* dont need privileges */
270     else do;   /* need privileges */
271        if ^(privileges_are_set) then call set_privileges(code);
272        if code ^= 0 then do;
273           if code = error_table_$noentry then
274              call report_error(code, "Checking access to the system_privilege_ gate.", "", "");
275           else if code = error_table_$moderr then
276              call report_error(code, "Execute access is required on the system_privilege_ gate.", "", "");
277           else call report_error(code, "^a", pathname_(dirname, ename), "");
278           end;
279        parent_access = TRUE;
280        end;
281 
282     /*  If -owner is specified, then the pdir can only be copied if the access class of the   */
283     /*  source pdir is equal to the target parent dir.                                        */
284 
285     if owner_sw then do;
286        call expand_pathname_ (target_dir, target_dirname, target_parent, code);
287        if code  ^= 0 then call report_error(code, "^a", pathname_(target_dirname, target_parent), "");
288                                                             /* get access class of parent of target dir */
289        call hcs_$get_access_class (target_dirname, target_parent, parent_access_class, code);
290        if code ^= 0  then call report_error(code, "^a", pathname_(target_dirname, target_parent), "");
291 
292        if pdir_access_class ^= parent_access_class then call report_error (error_table_$action_not_performed,
293           "^/When -owner is used, the access class of pdir ^a must equal the access class of the target directory ^a.",
294            pathname_(dirname, ename), pathname_(target_dirname, target_parent));
295        end;
296 
297     call hcs_$status_minf (dirname, ename, no_chase, type, ignore, code);
298     if code ^= 0 then call report_error(code, "^a", pathname_(dirname, ename), "");
299     if type ^= DIR_TYPE then call report_error(error_table_$notadir, "^a", pathname_(dirname, ename), "");
300 
301     /* determine access of the pdir to be copied */
302 
303     call hcs_$get_user_effmode (dirname, ename, "", -1, mode, code);
304     if code ^= 0 then  call report_error(code, "^a", pathname_(dirname, ename), "");
305     if mode ^= SMA_ACCESS_BIN & mode ^= SM_ACCESS_BIN then call report_error(error_table_$moderr,
306                               "SM access is required on ^a", pathname_(dirname, ename), "");
307 %page;
308     if delete_sw | ncd_sw then do;
309        /* to delete user needs SM on containing dir */
310 
311        call expand_pathname_ (dirname, tdirname, tename, code);
312        if code  ^= 0 then call report_error(code, "^a", dirname, "");
313 
314        call hcs_$get_user_effmode (tdirname, tename, "", -1, mode, code);
315        if code ^= 0 then  call report_error(code, "^a", dirname, "");
316 
317        if mode ^= SMA_ACCESS_BIN & mode ^= SM_ACCESS_BIN then do;
318           /* query the user to continue */
319           if mode = S_ACCESS_BIN then code = error_table_$no_m_permission;
320           else if mode = M_ACCESS_BIN then code = error_table_$no_s_permission;
321           else  code = error_table_$incorrect_access;
322 
323           if ncd_sw then
324              call report_error (error_table_$incorrect_access,
325                 "Modify access is needed on containing dir ^a to delete ^a.",
326                 dirname, pathname_(dirname, ename));
327 
328           if delete_sw then call command_query_$yes_no (yes_sw, code, myname,
329 "In order to delete the pdir ^a, Modify access is needed on the containing dir ^a.  If you continue, the pdir will be copied but not deleted.",
330              "The directory ^a can be copied but not deleted. Do you wish to continue?",
331              pathname_(dirname, ename), dirname);
332           if ^(yes_sw) then
333              call report_error(error_table_$action_not_performed,
334              "Copying ^a.", ename, "");
335           delete_sw = FALSE;                                /* continue and  */
336           end;                                              /* dont delete   */
337        end;
338 
339     if deadproc                                             /* get target dir*/
340     then call construct_names_from_pdir (ename, pdir_to_create, person_proj);
341     else do;
342        pdir_to_create = rtrim(name_str) || "." || PDIR_SUFFIX;
343        person_proj = name_str;
344        end;
345 
346     if ^ncd_sw then do;
347        need_hphcs = determine_hphcs_need(dirname, ename, person_proj);
348        if need_hphcs then do;
349           /* To copy the user needs "re" to hphcs_ gate. */
350           call check_gate_access_ ("hphcs_", null(), code);
351           if code ^= 0 then do;
352              if code = error_table_$noentry then
353                 call report_error(code, "Checking access to the hphcs_ gate.",
354                 "", "");
355              else if code = error_table_$moderr then
356                 call report_error(code,
357                 "Execute access is required on the hphcs_ gate.", "", "");
358              end;
359            end;
360 %page;
361        if ^deadproc & owner_sw then;
362        else if owner_sw then do;
363           if (person_proj = ename) then
364              call report_error(error_table_$action_not_performed,
365              "Cannot construct person.project from name given ^a.", ename, "");
366           end;
367        else person_proj = "";                               /* only need     */
368                                                             /* person.project*/
369                                                             /* if owner given*/
370 
371                                                             /* target dir    */
372                                                             /* exist already?*/
373        call hcs_$status_minf (target_dir, pdir_to_create, no_chase, type, ignore,
374           code);
375        if code = 0 then do;                                 /* yes, rename it*/
376           restore_names = TRUE;
377           call upd_free_name_$retain_suffix (target_dir, pdir_to_create,
378              "pdir", code);
379           if code ^= 0 then
380              call report_error(code, "While renaming the pdir directory ^a",
381              pathname_(target_dir, pdir_to_create), "");
382           end;
383 
384                                                             /* set 256K sw   */
385                                                             /* just in case  */
386        call hcs_$set_256K_switch ( "11"b, old_256k_sw, code);
387        if code ^= 0 then call com_err_(myname, code, "Warning, unable to set the 256K switch...continuing copying.");
388 
389        if deadproc                                          /* copy the pdir */
390        then call copy_pdir_$deadproc (myname, dirname, ename,  target_dir, pdir_to_create, person_proj, need_hphcs, code);
391        else call copy_pdir_$liveproc (myname, dirname, ename,  target_dir, pdir_to_create, person_proj, need_hphcs,
392           before(name_str,"."), code);
393        if code ^= 0 then call report_error(code, "While copying ^a to ^a.",
394           pathname_(dirname, ename), pathname_(target_dir, pdir_to_create));
395 
396        restore_names = FALSE;    /* successful copy, dont restore */
397        end;
398 
399     if delete_sw | ncd_sw then do;
400        call copy_pdir_$delete (myname, dirname, ename, code);
401        if code ^= 0 then
402           call report_error(code, "Deleting ^a.", pathname_(dirname, ename),
403           "");
404        end;
405 
406 END_COPY:
407     call clean_up();
408 
409 EXIT:
410     return;
411 %page;
412 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
413 /*                                                                           */
414 /* Reports error messages pertaining to argument processing and aborts the   */
415 /* command.                                                                  */
416 /*                                                                           */
417 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
418 
419 argument_error: proc(ecode, message, str1, str2);
420 
421 dcl ecode                               fixed bin(35),
422     (message, str1, str2)               char(*);
423 
424    call com_err_(ecode, myname, message, str1, str2);
425    goto EXIT;
426 
427 end argument_error;
428 
429 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
430 %page;
431 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
432 
433 
434 clean_up: proc();
435 
436 dcl code fixed bin(35);
437 
438     code = 0;
439     if restore_names then
440        call upd_free_name_$restore_with_suffix (target_dir, pdir_to_create,
441        "pdir", ignore_code);
442     restore_names = FALSE;
443     if privileges_are_set then do;
444        if ^(privileges.dir) then call system_privilege_$dir_priv_off (ignore_code);
445        if ^(privileges.seg) then call system_privilege_$seg_priv_off (ignore_code);
446        end;
447     call hcs_$set_256K_switch (old_256k_sw, (""b), ignore_code);
448 
449 end clean_up;
450 
451 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
452 %page;
453 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
454 /*                                                                           */
455 /* Attempts to construct the person.pdir name for the target pdir name and   */
456 /* the person.project for the owner acl.                                     */
457 /*                                                                           */
458 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
459 
460 construct_names_from_pdir:  proc (old_name, new_name, acl_name);
461 
462 dcl acl_name char(*);
463 dcl new_name char(*);
464 dcl old_name char(*);
465 
466 dcl temp_name char(32) var;
467 dcl temp_idx fixed bin;
468 
469 /* old_name is assumed to be at the very least person.project */
470 
471     acl_name, new_name = "";
472     temp_name = rtrim(old_name);
473 
474     temp_idx = index(old_name, ".");
475     if temp_idx ^= 0 then new_name = substr(temp_name, 1, temp_idx-1);
476     else  /* doesn't appear to be a person.project */
477        new_name = old_name;   /* return as is */
478 
479     new_name = rtrim(new_name) || "." || PDIR_SUFFIX;
480 
481 /* To construct person.project, the old name is assumed to be of the form person.project.f.channel */
482 
483     temp_idx = index(temp_name, ".f.");
484     if temp_idx ^= 0 then acl_name = substr(temp_name, 1, temp_idx-1);
485     else  /* doesn't appear to be a person.project.f.chnl */
486        acl_name = old_name;   /* return as is */
487 
488 end construct_names_from_pdir;
489 
490 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
491 %page;
492 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
493 
494 
495 determine_hphcs_need: proc(dirname, ename, person_proj) returns(bit(1));
496 
497 dcl dirname char(168);
498 dcl ename char(32);
499 dcl person_proj char(32);
500 
501 dcl code fixed bin(35);
502 dcl userid char(32);
503 dcl get_group_id_             entry() returns(char(32));
504 dcl get_group_id_$tag_star    entry() returns(char(32));
505 
506     userid = get_group_id_$tag_star();
507     if person_proj = substr(userid, 1, index(userid, ".*")-1)
508     then return("0"b);
509     else do;
510        call hcs_$get_user_effmode (dirname, ename, get_group_id_(),
511           -1, mode, code);
512        if code ^= 0 then  call report_error(code, "^a", dirname, "");
513        if mode = SMA_ACCESS_BIN
514        then do;
515           call hcs_$get_user_effmode (pathname_ (dirname, ename),
516              "pit", get_group_id_(), -1, mode, code);
517           if mode = REW_ACCESS_BIN then
518           return ("0"b);
519           else return ("1"b);
520           end;
521        else return("1"b);
522        end;
523 
524 end determine_hphcs_need;
525 
526 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
527 %page;
528 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
529 /*                                                                           */
530 /* This guy gets the next argument from the argument string, complaining     */
531 /* if it's not there.                                                        */
532 /*                                                                           */
533 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
534 
535 get_next_arg: proc(arg_expected, ap1, al1);
536 
537 dcl arg_expected                        char(*);
538 dcl (ap1                                ptr,
539      al1                                fixed bin(21),
540      code                               fixed bin(35));
541 
542     argno = argno + 1;
543     if argno > nargs then do;
544        call argument_error(error_table_$noarg, "A ^a expected after ^a.", arg_expected, arg);
545        return;
546        end;
547 
548     call cu_$arg_ptr (argno, ap1, al1, code);
549     if code ^= 0 then call argument_error(code, "get_next_arg", "", "");
550 
551 end get_next_arg;
552 
553 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
554 %page;
555 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
556 /*                                                                           */
557 /* reports error messages and aborts the line.                               */
558 /*                                                                           */
559 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
560 
561 report_error: proc(ecode, message, str1, str2);
562 
563 dcl ecode                               fixed bin(35),
564     (message, str1, str2)               char(*);
565 
566    call com_err_(ecode, myname, message, str1, str2);
567    goto END_COPY;
568 
569 end report_error;
570 
571 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
572 %page;
573 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
574 
575 
576 set_privileges:  proc(code);
577 
578 dcl code fixed bin(35);
579 
580     code = 0;
581     priv_string =  get_privileges_();
582 
583     /* first make sure they have re to system_privileges_ gate */
584     call check_gate_access_ ("system_privilege_", null(), code);
585     if code ^= 0 then return;
586 
587     if privileges.dir then;   /* caller already has it on */
588     else call system_privilege_$dir_priv_on (code);
589     if privileges.seg then;   /* caller already has it on */
590     else call system_privilege_$seg_priv_on (code);
591 
592     privileges_are_set = "1"b;
593 
594 end set_privileges;
595 
596 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
597 %page;%include access_mode_values;
598 %page;%include aim_privileges;
599 
600 end copy_deadproc;