1 /* **************************************************************
  2    *                                                            *
  3    * Copyright, (C) Massachusetts Institute of Technology, 1983 *
  4    *                                                            *
  5    * Copyright, (C) Honeywell Information Systems Inc., 1983    *
  6    *                                                            *
  7    ************************************************************** */
  8 
  9 
 10 
 11 
 12 /* format: style2,idind30,indcomtxt */
 13 
 14 copy_acl:
 15      procedure options (variable);
 16 
 17 /* COPY_ACL, COPY_IACL_SEG, COPY_IACL_DIR */
 18 /* initial coding 8/76 THVV */
 19 /* Added -working_dir or -wd in place of pathnames 07/25/80 S. Herbst */
 20 /* cleaned and neatened BIM and J. Pattin, 83-(8 9) */
 21 /* Modified 11/01/83 by C. Spitzer.  fix arg processing bug, allow equal
 22    convention in place of missing last argument */
 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;                          /* No stars */
120                else if code <= 2
121                then do;                                     /* Name1 has stars */
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;                                     /* last argument missing */
145                     dn2 = get_wdir_ ();
146                     en2 = "===";                            /* same name in current [wd] */
147                     end;
148                else do;
149                     call cu_$arg_ptr (an+1, ap, al, (0));   /* Get Name2 */
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;                   /* skip this pair of arguments */
181                else do;                                     /* must be longeql */
182                          call com_err_ (code, whoami, arg); /* print arg name in error message */
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;