1
2
3
4
5
6
7
8
9
10
11
12
13
14 copy_acl:
15 procedure options (variable);
16
17
18
19
20
21
22
23
24 dcl arg char (al) based (ap);
25 dcl (dn1, dn2) char (168);
26 dcl (en1, en2) char (32);
27 dcl error_sw bit (1);
28 dcl (ap, areap) ptr;
29 dcl (eptr, nptr) ptr init (null);
30 dcl whoami char (13);
31 dcl (i, ecount) fixed bin;
32 dcl al fixed bin (21);
33 dcl an fixed bin init (1);
34 dcl (starsw, areasw) bit (1) init ("0"b);
35
36 dcl system_area area ((1024)) based (areap);
37
38 dcl 1 entries (100) based (eptr) aligned,
39 2 type bit (2) unaligned,
40 2 nnames bit (16) unaligned,
41 2 nindex bit (18) unaligned;
42
43 dcl names (100) char (32) based (nptr);
44
45 dcl arg_count fixed bin;
46 dcl code fixed bin (35);
47 dcl error_table_$badopt fixed bin (35) ext;
48 dcl error_table_$noarg fixed bin (35) ext;
49 dcl error_table_$odd_no_of_args fixed bin (35) ext;
50 dcl error_table_$badequal fixed bin (35) ext;
51
52 dcl check_star_name_$entry entry (char (*), fixed bin (35));
53 dcl com_err_ entry options (variable);
54 dcl com_err_$suppress_name entry options (variable);
55 dcl cu_$arg_count entry (fixed bin, fixed bin (35));
56 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
57 dcl get_equal_name_ entry (char (*), char (*), char (*), fixed bin (35));
58 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
59 dcl hcs_$star_ entry (char (*), char (*), fixed bin, ptr, fixed bin, ptr, ptr,
60 fixed bin (35));
61 dcl get_system_free_area_ entry () returns (ptr);
62 dcl get_wdir_ entry returns (char (168));
63 dcl copy_acl_ entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35));
64 dcl copy_iacl_$dir entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35));
65 dcl copy_iacl_$seg entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35));
66 dcl pathname_ entry (char (*), char (*)) returns (char (168));
67
68 dcl (addr, addrel, bin, null) builtin;
69 dcl cleanup condition;
70 ^L
71
72
73 whoami = "copy_acl";
74 go to start;
75
76 copy_iacl_seg:
77 entry;
78 whoami = "copy_iacl_seg";
79 go to start;
80
81 copy_iacl_dir:
82 entry;
83 whoami = "copy_iacl_dir";
84
85 start:
86 call cu_$arg_count (arg_count, code);
87 if code ^= 0
88 then do;
89 call com_err_ (code, whoami);
90 return;
91 end;
92 if arg_count = 0
93 then do;
94 call com_err_$suppress_name (0, whoami, "Usage: ^a path11 {path21 ... pathN1 {pathN2}}", whoami);
95 return;
96 end;
97
98 do an = 1 to arg_count by 2;
99 call cu_$arg_ptr (an, ap, al, (0));
100
101 if index (arg, "-") = 1
102 then if arg = "-working_dir" | arg = "-wd"
103 then call expand_pathname_ (get_wdir_ (), dn1, en1, code);
104 else do;
105 BADOPT:
106 call com_err_ (error_table_$badopt, whoami, "^a", arg);
107 return;
108 end;
109 else call expand_pathname_ (arg, dn1, en1, code);
110
111 if code ^= 0
112 then do;
113 call com_err_ (code, whoami, "^a", arg);
114 return;
115 end;
116
117 call check_star_name_$entry (en1, code);
118 if code = 0
119 then starsw = "0"b;
120 else if code <= 2
121 then do;
122 if ^areasw
123 then do;
124 areasw = "1"b;
125 areap = get_system_free_area_ ();
126 on condition (cleanup) call cleanup_handler;
127 end;
128 call hcs_$star_ (dn1, en1, 3, areap, ecount, eptr, nptr, code);
129 if code ^= 0
130 then do;
131 call com_err_ (code, whoami, "Could not star list ^a.", pathname_ (dn1, en1));
132 return;
133 end;
134 starsw = "1"b;
135 end;
136 else
137 PATHNAME_ERROR:
138 do;
139 call com_err_ (code, whoami, "^a.", pathname_ (dn1, en1));
140 return;
141 end;
142
143 if an = arg_count
144 then do;
145 dn2 = get_wdir_ ();
146 en2 = "===";
147 end;
148 else do;
149 call cu_$arg_ptr (an+1, ap, al, (0));
150
151 if index (arg, "-") = 1
152 then if arg = "-working_dir" | arg = "-wd"
153 then call expand_pathname_ (get_wdir_ (), dn2, en2, code);
154 else go to BADOPT;
155 else call expand_pathname_ (arg, dn2, en2, code);
156
157 if code ^= 0
158 then go to PATHNAME_ERROR;
159 end;
160
161 if ^starsw
162 then call PERFORM_COPY (en1);
163 else do i = 1 to ecount;
164 call PERFORM_COPY (names (bin (entries (i).nindex, 18)));
165 end;
166 again:
167 if starsw
168 then call cleanup_handler;
169 end;
170 ^L
171 PERFORM_COPY:
172 proc (oldent);
173
174 dcl oldent char (32);
175 dcl newent char (32);
176
177 call get_equal_name_ (oldent, en2, newent, code);
178 if code ^= 0
179 then if code = error_table_$badequal
180 then go to PATHNAME_ERROR;
181 else do;
182 call com_err_ (code, whoami, arg);
183 return;
184 end;
185
186 if whoami = "copy_acl"
187 then call copy_acl_ (dn1, oldent, dn2, newent, error_sw, code);
188 else if whoami = "copy_iacl_seg"
189 then call copy_iacl_$seg (dn1, oldent, dn2, newent, error_sw, code);
190 else if whoami = "copy_iacl_dir"
191 then call copy_iacl_$dir (dn1, oldent, dn2, newent, error_sw, code);
192
193 if code ^= 0
194 then do;
195 if error_sw
196 then call com_err_ (code, whoami, "^a", pathname_ (dn2, newent));
197 else call com_err_ (code, whoami, "^a", pathname_ (dn1, oldent));
198 end;
199
200 end PERFORM_COPY;
201
202 cleanup_handler:
203 proc;
204 if eptr ^= null
205 then free entries in (system_area);
206 if nptr ^= null
207 then free names in (system_area);
208 end cleanup_handler;
209
210 end copy_acl;