1 /****^  **************************************************************
  2         *                                                            *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                   *
  4         *                                                            *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1983    *
  6         *                                                            *
  7         * Copyright, (C) Massachusetts Institute of Technology, 1983 *
  8         *                                                            *
  9         ************************************************************** */
 10 
 11 
 12 /****^  HISTORY COMMENTS:
 13   1) change(86-11-11,Lippard), approve(86-12-08,MCR7589),
 14      audit(87-02-16,Farley), install(87-03-23,MR12.1-1009):
 15      Modified to allow damaged switch for directories.
 16   2) change(87-08-21,TLNguyen), approve(87-08-21,MCR7556),
 17      audit(87-09-01,Lippard), install(87-12-07,MR12.2-1009):
 18      a. Change the switch_on to return an error message to the user when
 19         it fails to determine the type of a specified non-existent entry.
 20 
 21      b. Change the switch_on to set a specified support switch name on
 22         for a specified existing extended entry type such as forum.
 23   3) change(88-05-12,Lippard), approve(88-05-02,MCR7881),
 24      audit(88-06-16,Fawcett), install(88-08-02,MR12.2-1074):
 25      Changed to allow setting of audit_switch.
 26   4) change(88-08-16,TLNguyen), approve(88-08-16,MCR7921),
 27      audit(88-08-17,Parisek), install(88-08-23,MR12.2-1091):
 28      Prevents an infinitive loop when one of the specified existent paths is a
 29      Multisegment-file (MSF).
 30                                                    END HISTORY COMMENTS */
 31 
 32 
 33 /* format: style2,idind30,indcomtxt */
 34 switch_on:
 35 swn:
 36      procedure options (variable);
 37 
 38 /****
 39       Syntax:  switch_on name paths {-chase/-no_chase}
 40       switch_off name paths {-chase/-no_chase}
 41 
 42       Turns on or off the named switch (safety, copy, no_complete_volume_dump, etc.) for the
 43       specified pathnames. The star convention is allowed in paths.
 44 
 45       For an MSF, the switches of the MSF dir (when possible) and those of all the non-link components are set. */
 46 
 47 /* Written 06/18/80 by S. Herbst */
 48 /* Fixed to see links with starname only if -chase 11/17/80 S. Herbst */
 49 /* Modified September 1982, J. Bongiovanni, for synchronized switch */
 50 /* Added -name 10/26/82 S. Herbst */
 51 /* Modified 2/20/83 Jay Pattin for object_type_ */
 52 /* Modified 830927 BIM for object_type_ --> fs_util_ */
 53 /* Fixed to detect "Entry not found" 12/13/83 S. Herbst */
 54 /* Fixed to not blow out trying to find obj map of null seg, 1984.08.26, MAP */
 55 /* 850206 MSharpe to replace -fcnt with -inase/inaee */
 56 /* 850226 MSharpe to give better error messages when invalid switch names
 57    are given in conjunction with starnames */
 58 
 59 /* Constants */
 60 
 61           dcl     long_key                      (8) char (32) int static options (constant)
 62                                                 init ("copy", "damaged", "complete_volume_dump",
 63                                                 "incremental_volume_dump", "perprocess_static", "safety", "synchronized","audit");
 64 
 65           dcl     short_key                     (8) char (32) int static options (constant)
 66                                                 init ("cp", "dm", "cvd", "ivd", "pps", "sf", "synch", "ad");
 67 
 68           dcl     long_long_key                 (8) char (32) int static options (constant)
 69                                                 init ("copy_switch", "damaged_switch", "complete_volume_dump_switch",
 70                                                 "incremental_volume_dump_switch", "perprocess_static_switch",
 71                                                 "safety_switch", "synchronized_switch","audit_switch");
 72 
 73           dcl     short_long_key                (8) char (32) int static options (constant)
 74                                                 init ("csw", "dsw", "cvds", "ivds", "ppsw", "ssw", "synsw","asw");
 75 
 76           dcl     DIR_ALLOWED                   bit (8) aligned static options (constant) init ("01000101"b);
 77 
 78           dcl     (UNKNOWN_KEY, GENERAL_SET)    fixed bin int static options (constant) init (9);
 79 
 80           dcl     NO_CHASE                      fixed bin (1) int static options (constant) init (0);
 81 
 82           dcl     BRANCHES_ONLY                 fixed bin int static options (constant) init (2);
 83           dcl     BRANCHES_AND_LINKS            fixed bin int static options (constant) init (3);
 84 
 85           dcl     (
 86                   LINK_TYPE                     init (0),
 87                   SEG_TYPE                      init (1),
 88                   DIR_TYPE                      init (2),
 89                   MSF_TYPE                      init (3),
 90                   EXTENDED_TYPE                 init (4)
 91                   )                             fixed bin static options (constant);
 92 
 93 
 94 /* Based */
 95 
 96           dcl     arg                           char (arg_len) based (arg_ptr);
 97 
 98           dcl     1 entries                     (entries_count) aligned based (entries_ptr),
 99                     2 type                      fixed bin (2) unaligned unsigned,
100                     2 nnames                    fixed bin (15) unaligned,
101                     2 nindex                    fixed bin (17) unaligned;
102 
103           dcl     names                         (99 /* arbitrary */) char (32) aligned based (names_ptr);
104 
105 
106 /* Automatic */
107 
108           dcl     (dn, target_dn)               char (168);
109           dcl     (en, key_name, me, star_en, target_en)
110                                                 char (32);
111 
112           dcl     (chase_arg_given_sw, chase_sw, force_no_type_sw, got_key, got_path, name_sw, some_sw, star_sw,
113                   switch_value)                 bit (1) aligned;
114 
115           dcl     area                          area based (area_ptr);
116 
117           dcl     (area_ptr, arg_ptr, entries_ptr, names_ptr)
118                                                 ptr;
119 
120           dcl     (arg_count, arg_len, entries_count, i, j, key_index, star_type, type)
121                                                 fixed bin;
122           dcl     code                          fixed bin (35);
123 
124           dcl     error_table_$argerr           fixed bin (35) ext;
125           dcl     error_table_$badopt           fixed bin (35) ext;
126           dcl     error_table_$incorrect_access fixed bin (35) ext;
127           dcl     error_table_$moderr           fixed bin (35) ext;
128           dcl     error_table_$no_dir           fixed bin (35) ext;
129           dcl     error_table_$no_s_permission  fixed bin (35) ext;
130           dcl     error_table_$nomatch          fixed bin (35) ext;
131           dcl     error_table_$not_a_branch     fixed bin (35) ext;
132           dcl     error_table_$root             fixed bin (35) ext;
133 
134           dcl     (
135                   com_err_,
136                   com_err_$suppress_name
137                   )                             entry options (variable);
138           dcl     check_star_name_$entry        entry (char (*), fixed bin (35));
139           dcl     cu_$arg_count                 entry (fixed bin, fixed bin (35));
140           dcl     cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin, fixed bin (35));
141           dcl     expand_pathname_              entry (char (*), char (*), char (*), fixed bin (35));
142           dcl     get_group_id_                 entry returns (char (32));
143           dcl     get_system_free_area_         entry returns (ptr);
144           dcl     get_wdir_                     entry returns (char (168));
145           dcl     hcs_$add_acl_entries          entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
146           dcl     hcs_$delete_acl_entries       entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
147           dcl     hcs_$get_link_target          entry (char (*), char (*), char (*), char (*), fixed bin (35));
148           dcl     hcs_$initiate_count           entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr,
149                                                 fixed bin (35));
150           dcl     hcs_$list_acl                 entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
151           dcl     hcs_$set_copysw               entry (char (*), char (*), fixed bin (1), fixed bin (35));
152           dcl     hcs_$set_damaged_sw           entry (char (*), char (*), bit (1), fixed bin (35));
153           dcl     hcs_$set_safety_sw            entry (char (*), char (*), bit (1), fixed bin (35));
154           dcl     hcs_$set_synchronized_sw      entry (char (*), char (*), bit (1) aligned, fixed bin (35));
155           dcl     hcs_$set_volume_dump_switches entry (char (*), char (*), fixed bin, fixed bin, fixed bin (35));
156           dcl     hcs_$star_                    entry (char (*), char (*), fixed bin, ptr, fixed bin, ptr, ptr,
157                                                 fixed bin (35));
158           dcl     hcs_$status_minf              entry (char (*), char (*), fixed bin (1), fixed bin, fixed bin (24),
159                                                 fixed bin (35));
160           dcl     hcs_$terminate_noname         entry (ptr, fixed bin (35));
161           dcl     fs_util_$set_switch           entry (char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
162           dcl     fs_util_$get_type             entry (character (*), character (*), character (*), fixed binary (35));
163           dcl     pathname_                     entry (char (*), char (*)) returns (char (168));
164           dcl     system_privilege_$set_entry_audit_switch
165                   entry (char (*), char (*), bit (1), fixed bin (35));
166 
167           dcl     (addr, addrel, divide, fixed, hbound, index, null, rtrim, substr)
168                                                 builtin;
169 
170           dcl     test_linkage_entry            entry variable options (variable);
171 
172 
173           dcl     cleanup                       condition;
174           dcl     linkage_error                 condition;
175 %page;
176           me = "switch_on";
177           switch_value = "1"b;
178           go to COMMON;
179 
180 switch_off:
181 swf:
182      entry;
183 
184           me = "switch_off";
185           switch_value = "0"b;
186 
187 COMMON:
188           call cu_$arg_count (arg_count, code);
189           if code ^= 0
190           then do;
191                     call com_err_ (code, me);
192                     return;
193                end;
194 
195 /* Read control args */
196 
197           chase_sw, chase_arg_given_sw, force_no_type_sw = "0"b;
198 
199           do i = 1 to arg_count;
200 
201                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
202 
203                if substr (arg, 1, 1) = "-"
204                then if arg = "-chase"
205                     then chase_sw, chase_arg_given_sw = "1"b;
206                     else if arg = "-no_chase"
207                     then do;
208                               chase_sw = "0"b;
209                               chase_arg_given_sw = "1"b;
210                          end;
211 
212                     else if arg = "-interpret_as_standard_entry" | arg = "-inase"
213                     then force_no_type_sw = "1"b;
214 
215                     else if arg = "-interpret_as_extended_entry" | arg = "-inaee"
216                     then force_no_type_sw = "0"b;
217 
218                     else if arg = "-name" | arg = "-nm"
219                     then do;                                /* skip following arg */
220                               i = i + 1;
221                               if i > arg_count
222                               then do;
223                                         call com_err_ (0, me, "No value specified for -name");
224                                         return;
225                                    end;
226                          end;
227                     else do;
228                               call com_err_ (error_table_$badopt, me, "^a", arg);
229                               return;
230                          end;
231           end;
232 
233 /* Read and process other args */
234 
235           got_key, got_path, name_sw = "0"b;
236           area_ptr, entries_ptr, names_ptr = null;
237           on cleanup call clean_up;
238 
239           do i = 1 to arg_count;
240 
241                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
242 
243                if arg = "-name" | arg = "-nm"
244                then name_sw = "1"b;
245                else if index (arg, "-") ^= 1
246                then if ^got_key
247                     then do;
248                               key_name = arg;
249                               do j = hbound (long_key, 1) by -1 to 1 while (long_key (j) ^= key_name);
250                               end;
251                               if j = 0
252                               then do;
253                                         do j = hbound (short_key, 1) by -1 to 1 while (short_key (j) ^= key_name);
254                                         end;
255                                         if j = 0
256                                         then do;
257                                                   do j = hbound (long_long_key, 1) by -1 to 1
258                                                        while (long_long_key (j) ^= key_name);
259                                                   end;
260                                                   if j = 0
261                                                   then do;
262                                                             do j = hbound (short_long_key, 1) by -1 to 1
263                                                                  while (short_long_key (j) ^= key_name);
264                                                             end;
265                                                             if j = 0
266                                                             then if force_no_type_sw
267                                                                  then do;
268                                                                            call com_err_ (0, me,
269                                                                                 "Invalid switch name: ^a", key_name);
270                                                                            goto RETURN;
271                                                                       end;
272                                                                  else j = UNKNOWN_KEY;
273                                                             /* MAY BE EXTENDED OBJECT */
274                                                        end;
275                                              end;
276                                    end;
277                               key_index = j;
278                               got_key = "1"b;
279                               name_sw = "0"b;
280                          end;
281 
282                     else do;
283 
284                               got_path = "1"b;
285 
286                               if name_sw
287                               then do;
288                                         name_sw = "0"b;
289                                         dn = get_wdir_ ();
290                                         en = arg;
291                                         go to LITERAL_NAME;
292                                    end;
293 
294                               call expand_pathname_ (arg, dn, en, code);
295                               if code ^= 0
296                               then do;
297                                         call com_err_ (code, me, "^a", arg);
298                                         return;
299                                    end;
300 
301                               if dn = ">" & en = ""
302                               then do;
303                                         call com_err_ (error_table_$root, me, "^a", arg);
304                                         go to NEXT_ARG;
305                                    end;
306 
307                               call check_star_name_$entry (en, code);
308                               if code = 0
309                               then do;
310 LITERAL_NAME:
311                                         star_sw = "0"b;
312 
313                                         type = get_type (dn, en);
314                                                             /* no stars */
315 
316                                         if type = LINK_TYPE
317                                         then if chase_arg_given_sw & ^chase_sw
318                                              then call com_err_ (error_table_$not_a_branch, me, "^a", pathname_ (dn, en));
319 
320                                              else do;       /* default: chase if not stars */
321 
322                                                        call resolve_link (dn, en, target_dn, target_en, type, code);
323 
324                                                        if code = 0
325                                                        then call set_one (target_dn, target_en, type, key_index,
326                                                                  switch_value, code);
327                                                        else call com_err_ (code, me, "Chasing link ^a",
328                                                                  pathname_ (target_dn, target_en));
329 
330                                                   end;
331 
332                                         else call set_one (dn, en, type, key_index, switch_value, code);
333                                    end;
334 
335                               else if code > 2
336                               then do;                      /* bad syntax in starname */
337                                         call com_err_ (code, me, "^a", arg);
338                                         return;
339                                    end;
340 
341                               else do;
342                                         star_sw = "1"b;
343                                         star_en = en;
344 
345                                         if area_ptr = null
346                                         then area_ptr = get_system_free_area_ ();
347 
348                                         entries_ptr, names_ptr = null;
349 
350                                         if chase_sw
351                                         then star_type = BRANCHES_AND_LINKS;
352                                         else star_type = BRANCHES_ONLY;
353 
354                                         some_sw = "0"b;
355 
356                                         call hcs_$star_ (dn, en, star_type, area_ptr, entries_count, entries_ptr,
357                                              names_ptr, code);
358                                         if code ^= 0
359                                         then do;
360                                                   call com_err_ (code, me, "^a", pathname_ (dn, en));
361                                                   go to NEXT_ARG;
362                                              end;
363 
364                                         else do j = 1 to entries_count;
365 
366                                                   type = entries_ptr -> entries (j).type;
367                                                   if type = SEG_TYPE | type = DIR_TYPE
368                                                   then do;  /* not a link */
369 
370                                                             target_dn = dn;
371                                                             target_en =
372                                                                  names_ptr -> names (entries_ptr -> entries (j).nindex);
373 
374 BRANCH:
375                                                             type = get_type (target_dn, target_en);
376                                                             /* MSF?, EXTENDED? */
377 
378                                                             if (type ^= EXTENDED_TYPE) & key_index = UNKNOWN_KEY
379                                                             then ;
380                                                             else do;
381                                                                       call set_one (target_dn, target_en, type, key_index,
382                                                                            switch_value, code);
383 
384                                                                       if code ^= 0
385                                                                       then if code = error_table_$no_s_permission
386                                                                                 | code = error_table_$incorrect_access
387                                                                                 | code = error_table_$no_dir
388                                                                            then go to NEXT_ARG;
389                                                                  end;
390                                                        end;
391 
392                                                   else if chase_sw
393                                                   then do;  /* link */
394 
395                                                             en = names_ptr -> names (entries_ptr -> entries (j).nindex);
396 
397                                                             call resolve_link (dn, en, target_dn, target_en, type, code);
398 
399                                                             if code = 0
400                                                             then go to BRANCH;
401                                                             else if key_index = UNKNOWN_KEY
402                                                             then ;
403                                                             /* Quiet! Wasn't meant for this one anyway */
404                                                             else call com_err_ (code, me, "Chasing link ^a",
405                                                                       pathname_ (dn, en));
406                                                        end;
407                                              end;
408 
409                                         if star_sw & ^some_sw
410                                         then if key_index = UNKNOWN_KEY
411                                              then call com_err_ (0, me, "Invalid switch name: ^a", key_name);
412                                              else call com_err_ (error_table_$nomatch, me, "^a", pathname_ (dn, star_en));
413 
414 NEXT_ARG:
415                                         call clean_up;
416                                    end;
417                          end;
418           end;
419 
420           if ^got_path
421           then do;
422                     call com_err_$suppress_name (0, me, "Usage:  ^a keyword paths {-control_args}", me);
423                     return;
424                end;
425 
426 RETURN:
427           call clean_up;
428 
429           return;
430 %page;
431 get_type:
432      proc (P_dn, P_en) returns (fixed bin);
433 
434 /* Decides whether an entry is a segment, directory, or MSF */
435 
436           dcl     (P_dn, P_en)                  char (*);
437           dcl     type                          fixed bin;
438           dcl     bit_count                     fixed bin (24);
439           dcl     fs_util_type                  char (32);
440 
441           code = 0;                                         /* make get_type happy */
442           fs_util_type = "";
443 
444           if ^force_no_type_sw
445           then do;
446                     call fs_util_$get_type (P_dn, P_en, fs_util_type, code);
447 
448                     if code = 0 & ((substr (fs_util_type, 1, 1) ^= "-") | (fs_util_type = FS_OBJECT_TYPE_DM_FILE))
449                     then return (EXTENDED_TYPE);            /* extended object or DM files,i.e., non-hcs */
450                     else if code ^= 0
451                          then do;
452                               call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
453                               goto RETURN;
454                          end;
455                     else;
456                end;
457 
458           call hcs_$status_minf (P_dn, P_en, NO_CHASE, type, bit_count, code);
459           if code ^= 0 & code ^= error_table_$no_s_permission
460           then do;
461                     if key_index = UNKNOWN_KEY
462                     then call com_err_ (0, me, "Invalid switch name: ^a.", key_name);
463                     else call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
464                     go to RETURN;
465                end;
466 
467           if type = DIR_TYPE & bit_count > 0
468           then return (MSF_TYPE);
469           else return (type);
470 
471 %include suffix_info;
472 %include copy_flags;
473      end get_type;
474 %page;
475 resolve_link:
476      proc (P_dn, P_en, P_target_dn, P_target_en, P_type, P_code);
477 
478 /* Chases a link and gets the type of the target */
479 
480           dcl     (P_dn, P_en, P_target_dn, P_target_en)
481                                                 char (*);
482           dcl     P_type                        fixed bin;
483           dcl     P_code                        fixed bin (35);
484 
485           call hcs_$get_link_target (P_dn, P_en, P_target_dn, P_target_en, P_code);
486           if P_code ^= 0
487           then return;
488 
489           P_type = get_type (P_target_dn, P_target_en);
490 
491      end resolve_link;
492 %page;
493 set_one:
494      proc (P_dn, P_en, P_type, P_key_index, P_switch_value, P_code);
495 
496 /* Sets the switch of one segment by calling the appropriate routine */
497 
498           dcl     (P_dn, P_en)                  char (*);
499           dcl     P_switch_value                bit (1) aligned;
500           dcl     (P_key_index, P_type)         fixed bin;
501           dcl     P_code                        fixed bin (35);
502 
503           dcl     (entries_ptr, names_ptr)      ptr;
504           dcl     entries_count                 fixed bin;
505           dcl     code                          fixed bin (35);
506 
507           dcl     msf_path                      char (168);
508           dcl     component_name                char (32);
509           dcl     msf_component_index           fixed bin;  /* local */
510 
511           code = 0;                                         /* must initialize to avoid it was previously contained garbage */
512 
513           if P_type = MSF_TYPE
514           then do;                                          /* first set the switch on all the components */
515 
516                     if long_key (P_key_index) = "perprocess_static"
517                     then do;
518                               call com_err_ (0, me, "Operation not allowed on MSF's.  ^a", pathname_ (P_dn, P_en));
519                               return;
520                          end;
521 
522                     msf_path = P_dn;
523                     if msf_path ^= ">"
524                     then msf_path = rtrim (msf_path) || ">";
525                     msf_path = rtrim (msf_path) || P_en;
526 
527                     if area_ptr = null
528                     then area_ptr = get_system_free_area_ ();
529                     entries_ptr, names_ptr = null;
530 
531                     on cleanup call msf_cleanup;
532 
533                     call hcs_$star_ (msf_path, "**", BRANCHES_ONLY, area_ptr, entries_count, entries_ptr, names_ptr, code);
534 
535                     if code = 0 & entries_count > 0
536                     then do;
537                               do msf_component_index = 1 to entries_count;
538                                    component_name = names_ptr -> names (entries_ptr -> entries (msf_component_index).nindex);
539 
540                                    call set_whichever (msf_path, component_name, (entries_ptr -> entries (msf_component_index).type),
541                                         P_key_index, P_switch_value);
542                               end;
543 
544                               call msf_cleanup;
545                          end;
546                end;
547 
548           if P_type ^= MSF_TYPE | substr (DIR_ALLOWED, P_key_index, 1)
549           then call set_whichever (P_dn, P_en, P_type, P_key_index, P_switch_value);
550 
551           return;
552 
553 msf_cleanup:
554      proc;
555 
556           if entries_ptr ^= null
557           then free entries_ptr -> entries in (area);
558           if names_ptr ^= null
559           then free names_ptr -> names in (area);
560 
561      end msf_cleanup;
562 
563 
564      end set_one;
565 %page;
566 set_whichever:
567      proc (P_dn, P_en, P_type, P_key_index, P_switch_value);
568 
569 /* Calls the appropriate entry point to set a switch */
570 
571           dcl     (P_dn, P_en)                  char (*);
572           dcl     (P_type, P_key_index)         fixed bin;
573           dcl     P_switch_value                bit (1) aligned;
574           dcl     code                          fixed bin (35);
575 
576           dcl     (ncvd_value, nivd_value)      fixed bin;
577 
578           code = 0;                                         /* must initialize to avoid it was previously contained an unexpected value */
579 
580           if P_type = EXTENDED_TYPE
581           then goto SET (GENERAL_SET);
582 
583           if P_type = DIR_TYPE & ^substr (DIR_ALLOWED, P_key_index, 1)
584           then do;
585                     if ^star_sw
586                     then call com_err_ (0, me, "Directories do not support the ^a switch. ^a.", key_name,
587                               pathname_ (P_dn, P_en));
588                     return;
589                end;
590 
591           go to SET (P_key_index);
592 
593 SET (1):                                                    /* copy switch */
594           some_sw = "1"b;
595           call hcs_$set_copysw (P_dn, P_en, fixed (P_switch_value, 1), code);
596           if code ^= 0
597           then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
598           return;
599 
600 
601 SET (2):                                                    /* damaged_switch */
602           some_sw = "1"b;
603           call hcs_$set_damaged_sw (P_dn, P_en, (P_switch_value), code);
604           if code ^= 0
605           then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
606           return;
607 
608 SET (3):                                                    /* complete_volume_dump switch */
609           some_sw = "1"b;                                   /* use NOT of user's arg "complete_volume_dump_switch" */
610           if P_switch_value
611           then ncvd_value = -1;
612           else ncvd_value = 1;
613           call hcs_$set_volume_dump_switches (P_dn, P_en, 0, ncvd_value, code);
614           if code ^= 0
615           then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
616           return;
617 
618 SET (4):                                                    /* incremental_volume_dump switch */
619           some_sw = "1"b;                                   /* use NOT of user's arg "incremental_volume_dump_switch" */
620           if P_switch_value
621           then nivd_value = -1;
622           else nivd_value = 1;
623           call hcs_$set_volume_dump_switches (P_dn, P_en, nivd_value, 0, code);
624           if code ^= 0
625           then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
626 
627           return;
628 
629 SET (5):                                                    /* perprocess_static switch */
630           some_sw = "1"b;
631           call set_perprocess (P_dn, P_en, P_switch_value, code);
632           return;
633 
634 SET (6):                                                    /* safety switch */
635           some_sw = "1"b;
636           call hcs_$set_safety_sw (P_dn, P_en, (P_switch_value), code);
637           if code ^= 0
638           then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
639           return;
640 
641 SET (7):                                                    /* synchronized switch */
642           some_sw = "1"b;
643           call hcs_$set_synchronized_sw (P_dn, P_en, (P_switch_value), code);
644           if code ^= 0
645           then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
646           return;
647 
648 SET (8):                                                    /* entry audit switch */
649           some_sw = "1"b;
650           on linkage_error begin;
651              call com_err_ (error_table_$moderr, me, "system_privilege_");
652              goto no_sys_priv;
653              end;
654           test_linkage_entry = system_privilege_$set_entry_audit_switch;
655           call system_privilege_$set_entry_audit_switch (P_dn, P_en, (P_switch_value), code);
656           if code ^= 0
657           then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
658 
659 no_sys_priv:
660 
661           return;
662 SET (9):                                                    /* unknown keyname, only allowed for extended objects */
663           if type ^= EXTENDED_TYPE
664           then do;
665                     if ^star_sw
666                     then call com_err_ (0, me, "Invalid switch name: ^a.", key_name);
667                     return;
668                end;
669 
670           if key_index = UNKNOWN_KEY                        /* users specified a switch name for a specified extended entry */
671           then call fs_util_$set_switch (P_dn, P_en, key_name, P_switch_value, code);
672           else call fs_util_$set_switch (P_dn, P_en, long_key (key_index), P_switch_value, code);
673 
674           if code ^= 0
675           then do;
676 
677                if code = error_table_$argerr
678 
679                then if star_sw & P_key_index = UNKNOWN_KEY
680                     then return;                            /* we don't support this switch; if nobody else does,
681                                                                the Invalid switch error will be printed at the end */
682                     else call com_err_ (code, me, "^/This object does not support the ^a switch.  ^a", key_name,
683                               pathname_ (P_dn, P_en));      /* must display error code value to users */
684 
685                else call com_err_ (code, me, "^[Res^;S^]etting ^a switch on ^a.", ^P_switch_value, key_name,
686                          pathname_ (P_dn, P_en));
687                end;
688 
689           some_sw = "1"b;
690           return;
691 
692      end set_whichever;
693 %page;
694 set_perprocess:
695      proc (P_dn, P_en, P_switch_value, P_code);
696 
697 /* Sets the perprocess_static switch of an object segment, which is in the segment itself */
698 
699           dcl     (P_dn, P_en)                  char (*);
700           dcl     P_switch_value                bit (1) aligned;
701           dcl     P_code                        fixed bin (35);
702 
703 %include object_map;
704 
705           dcl     1 segment_acl                 (1) aligned,/* to force access to Person.Project.a */
706                     2 access_name               char (32),
707                     2 mode                      bit (36),
708                     2 pad                       bit (36),
709                     2 status_code               fixed bin (35);
710 
711           dcl     saved_mode                    bit (36);
712           dcl     delete_acl_sw                 bit (1);
713           dcl     (last_word_ptr, object_map_ptr, seg_ptr)
714                                                 ptr;
715           dcl     object_map_index              fixed bin;
716           dcl     word_count                    fixed bin (18);
717           dcl     bit_count                     fixed bin (24);
718           dcl     code                          fixed bin (35);
719 
720           seg_ptr = null;
721           delete_acl_sw = "0"b;
722 
723           on cleanup call sp_cleanup;
724 
725           call hcs_$initiate_count (P_dn, P_en, "", bit_count, 0, seg_ptr, P_code);
726           if seg_ptr = null
727           then do;
728                     call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
729                     return;
730                end;
731 
732           if bit_count = 0
733           then do;
734 BAD_OBJECT:
735                     if ^star_sw
736                     then call com_err_ (0, me, "Obsolete or non-object segment ^a", pathname_ (P_dn, P_en));
737                     P_code = 0;
738                     go to SP_RETURN;
739                end;
740 
741           word_count = divide (bit_count + 35, 36, 18, 0);
742           last_word_ptr = addrel (seg_ptr, word_count - 1);
743 
744           object_map_index = fixed (last_word_ptr -> map_ptr, 18);
745           if object_map_index <= 0 | object_map_index > word_count
746           then go to BAD_OBJECT;
747 
748           object_map_ptr = addrel (seg_ptr, last_word_ptr -> map_ptr);
749           if object_map_ptr -> object_map.identifier ^= "obj_map "
750           then go to BAD_OBJECT;
751 
752           if object_map_ptr -> object_map.decl_vers ^= 2
753           then go to BAD_OBJECT;                            /* obsolete version */
754 
755 /* Force write access if necessary */
756 
757           segment_acl (1).access_name = get_group_id_ ();   /* Person.Project.a */
758 
759           call hcs_$list_acl (P_dn, P_en, null, null, addr (segment_acl), 1, P_code);
760           if P_code ^= 0
761           then do;
762                     call com_err_ (P_code, me, "^a", pathname_ (P_dn, P_en));
763                     go to SP_RETURN;
764                end;
765 
766           if segment_acl (1).status_code ^= 0
767           then delete_acl_sw = "1"b;                        /* no such previous ACL term */
768           else do;
769                     delete_acl_sw = "0"b;                   /* have to restore previous access */
770                     saved_mode = segment_acl (1).mode;
771                end;
772 
773           segment_acl (1).mode = "101"b;                    /* set rw */
774 
775           call hcs_$add_acl_entries (P_dn, P_en, addr (segment_acl), 1, P_code);
776           if P_code ^= 0
777           then do;
778                     call com_err_ (P_code, me, "^a", pathname_ (P_dn, P_en));
779                     go to SP_RETURN;
780                end;
781 
782           on cleanup
783                begin;
784                     call restore_acl;
785                     call sp_cleanup;
786                end;
787 
788           object_map_ptr -> object_map.format.perprocess_static = P_switch_value;
789 
790           call restore_acl;
791 
792 SP_RETURN:
793           call sp_cleanup;
794 
795           return;
796 
797 
798 restore_acl:
799      proc;
800 
801           if delete_acl_sw
802           then call hcs_$delete_acl_entries (P_dn, P_en, addr (segment_acl), 1, code);
803           else do;
804                     segment_acl (1).mode = saved_mode;      /* restore previous access */
805                     call hcs_$add_acl_entries (P_dn, P_en, addr (segment_acl), 1, code);
806                end;
807 
808      end restore_acl;
809 
810 
811 sp_cleanup:
812      proc;
813 
814           if seg_ptr ^= null
815           then call hcs_$terminate_noname (seg_ptr, code);
816 
817      end sp_cleanup;
818 
819      end set_perprocess;
820 %page;
821 /* SAVED FOR LATER SHAPING UP
822    set_soos: proc (P_dn, P_en, P_switch_value, P_code);
823 
824    /* Turns soos on, or tests for consistent AIM attributes and turns soos off
825 
826    dcl (P_dn, P_en) char (*);
827    dcl P_switch_value bit (1);
828    dcl P_code fixed bin (35);
829 
830    dcl (code, old_dir_priv, old_soos_priv) fixed bin (35);
831 
832    on linkage_error begin;
833    call com_err_ (error_table_$moderr, me, "system_privilege_.");
834    go to RETURN;
835    end;
836 
837    if P_switch_value = "1"b then call system_privilege_$soos_on (P_dn, P_en, P_code);
838 
839    else do;
840 
841    old_dir_priv, old_soos_priv = 1;               /* don't restore privileges unless set
842 
843    on cleanup call clean_up_privs;
844 
845    call system_privilege_$dir_priv_on (old_dir_priv);       /* ensure necessary privileges
846    call system_privilege_$soos_priv_on (old_soos_priv);
847 
848    call system_privilege_$check_mode_reset (P_dn, P_en, P_code);
849    /* this entry point only succeeds if the branch's
850    AIM attributes are consistent
851    if P_code ^= 0 then call com_err_ (P_code, me, "^a", pathname_ (P_dn, P_en));
852    end;
853 
854 
855    clean_up_privs: proc;
856 
857    if old_dir_priv = 0 then call system_privilege_$dir_priv_off (code);
858    if old_soos_priv = 0 then call system_privilege_$soos_priv_off (code);
859 
860    end clean_up_privs;
861 
862 
863    end set_soos;
864 */
865 %page;
866 clean_up:
867      proc;
868 
869           if area_ptr = null
870           then return;
871           if entries_ptr ^= null
872           then free entries in (area);
873           if names_ptr ^= null
874           then free names in (area);
875           return;
876 
877      end clean_up;
878 
879 
880      end switch_on;