1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 perprocess_static_sw_on:
 12      proc;
 13 
 14 /* This command sets the perprocess_static bit in an object map */
 15 /* coded 5/77 by Melanie Weaver */
 16 /* modified 10/79 by Melanie Weaver to make argument handling more standard */
 17 
 18           dcl     (i, j, alng, lng, arg_count)
 19                                          fixed bin;
 20           dcl     wordcount              fixed bin (18);
 21           dcl     type                   fixed bin (2);
 22           dcl     code                   fixed bin (35);
 23           dcl     bitcnt                 fixed bin (24);
 24 
 25           dcl     (mapp, segptr, argptr, lastword, aclptr)
 26                                          ptr;
 27 
 28           dcl     arg_found              bit (1) aligned;
 29           dcl     new_value              bit (1) aligned;
 30           dcl     delete_sw              bit (1) aligned;
 31           dcl     saved_mode             bit (36) aligned;
 32 
 33           dcl     arg                    char (alng) based (argptr);
 34           dcl     dirname                char (168);
 35           dcl     ename                  char (32);
 36           dcl     me                     char (24);
 37 
 38           dcl     (addr, addrel, bin, divide, index, null)
 39                                          builtin;
 40 
 41           dcl     1 segment_acl          (1) aligned,
 42                     2 access_name        char (32),
 43                     2 mode               bit (36),
 44                     2 pad                bit (36),
 45                     2 status_code        fixed bin (35);
 46 
 47           dcl     error_table_$badopt    fixed bin (35) external;
 48 
 49           dcl     cu_$arg_count          entry () returns (fixed bin);
 50           dcl     cu_$arg_ptr            entry (fixed bin, ptr, fixed bin, fixed bin (35));
 51           dcl     com_err_               entry options (variable);
 52           dcl     com_err_$suppress_name entry () options (variable);
 53           dcl     cv_ptr_                entry (char (*), fixed bin (35)) returns (ptr);
 54           dcl     get_group_id_          entry () returns (char (32) aligned);
 55           dcl     hcs_$status_mins       entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
 56           dcl     hcs_$fs_get_path_name  entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
 57           dcl     hcs_$list_acl          entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
 58           dcl     hcs_$add_acl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
 59           dcl     hcs_$delete_acl_entries
 60                                          entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
 61 
 62 %include object_map;
 63 
 64 
 65           new_value = "1"b;
 66           me = "perprocess_static_sw_on";
 67 
 68 join:
 69           arg_count = cu_$arg_count ();
 70           if arg_count = 0
 71           then do;
 72 usage:
 73                     call com_err_$suppress_name (0, me, "Usage:  ^a pathname", me);
 74                     return;
 75                end;
 76           arg_found = "0"b;
 77 
 78           do j = 1 to arg_count;
 79                call cu_$arg_ptr (j, argptr, alng, code);
 80                if code ^= 0
 81                then do;
 82                          call com_err_ (code, me, "Argument ^d", j);
 83                          return;
 84                     end;
 85 
 86                if index (arg, "-") = 1
 87                then do;
 88                          call com_err_ (error_table_$badopt, me, "^a", arg);
 89                     end;
 90                else do;
 91                          arg_found = "1"b;
 92                          call process_arg;
 93                     end;
 94           end;
 95 
 96           if ^arg_found
 97           then go to usage;
 98 
 99           return;
100 
101 
102 perprocess_static_sw_off:
103      entry;
104 
105           new_value = "0"b;
106           me = "perprocess_static_sw_off";
107           goto join;
108 ^L
109 process_arg:
110      proc;
111 
112           segptr = cv_ptr_ (arg, code);
113           if code ^= 0
114           then do;
115 err2:
116                     call com_err_ (code, me, "^a", arg);
117                     return;
118                end;
119 
120           call hcs_$status_mins (segptr, type, bitcnt, code);
121           if code ^= 0
122           then goto err2;
123 
124 
125           wordcount = divide (bitcnt + 35, 36, 18, 0);
126           lastword = addrel (segptr, wordcount - 1);
127           i = bin (lastword -> map_ptr, 18);
128           if (i <= 0) | (i >= wordcount)
129           then do;
130 err3:
131                     call com_err_ (0, me, "Obsolete or non object segment ^a", arg);
132                     return;
133                end;
134           mapp = addrel (segptr, lastword -> map_ptr);
135           if mapp -> object_map.identifier ^= "obj_map "
136           then goto err3;
137           if mapp -> object_map.decl_vers ^= 2
138           then goto err3;
139 
140 /* be sure we have write access to segment so we can change it */
141 
142           aclptr = addr (segment_acl);
143           segment_acl (1).access_name = get_group_id_ ();
144           call hcs_$fs_get_path_name (segptr, dirname, lng, ename, code);
145           if code ^= 0
146           then do;
147 err4:
148                     call com_err_ (code, me, "Cannot set access on ^a", arg);
149                     return;
150                end;
151 
152           call hcs_$list_acl (dirname, ename, null, lastword, aclptr, 1, code);
153           if code ^= 0
154           then goto err4;
155           if segment_acl (1).status_code ^= 0
156           then delete_sw = "1"b;                            /* no previous acl entry for us */
157           else do;
158                     delete_sw = "0"b;
159                     saved_mode = segment_acl (1).mode;
160                end;
161 
162           segment_acl (1).mode = "101"b;                    /* set our access to rw */
163           call hcs_$add_acl_entries (dirname, ename, aclptr, 1, code);
164           if code ^= 0
165           then goto err4;
166 
167           mapp -> object_map.format.perprocess_static = new_value;
168 
169 /* now restore acl */
170 
171           if delete_sw
172           then call hcs_$delete_acl_entries (dirname, ename, aclptr, 1, code);
173           else do;
174                     segment_acl (1).mode = saved_mode;
175                     call hcs_$add_acl_entries (dirname, ename, aclptr, 1, code);
176                end;
177 
178           return;
179 
180      end;                                                   /* of process_arg */
181 
182 
183 
184      end;