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 
 15 copy_names:
 16      procedure options (variable);
 17 
 18 /**** * The commands copy_names and move_names copy and move all
 19       the additional names from one designated segment to another.
 20       copy_names also copies the designated name. Name duplication
 21       within a directory is handled in the accepted manner.
 22       Any number of pairs of arguments is allowed and the = convention
 23       is followed in the second argument of a pair. */
 24 
 25 /* Karolyn Martin 5/30/69 */
 26 /* modified by M. Weaver 9 April 1970 6:35 PM -- recoded into PL/I */
 27 /* last modified by M. Weaver 31 December 1970 */
 28 /* modified 6/3/75 by S. Herbst: command names changed to copy_names and move_names */
 29 /* TR7429 Changed to reject starnames 10/30/80 S. Herbst */
 30 /* Housecleaned, but not entirely, J Pattin and BIM 83-(8, 9, 10) */
 31 /* Allow star names in first argument. C Spitzer 12/20/83 */
 32 
 33           dcl     arg                           char (lng) based (ap);
 34 
 35           dcl     (copy, errsw)                 bit (1) aligned;
 36           dcl     (i, j, n)                     fixed bin (17);
 37           dcl     lng                           fixed bin (21);
 38           dcl     areap                         ptr;
 39           dcl     myarea                        area based (areap);
 40           dcl     bitcnt                        fixed bin (24);
 41           dcl     code                          fixed bin (35);
 42           dcl     (dir1, dir2)                  char (168);
 43           dcl     (en1, en2, qent)              char (32);
 44           dcl     cleanup                       condition;
 45           dcl     (null, sum)                   builtin;
 46           dcl     stars                         bit (1) aligned;
 47           dcl     ap                            ptr;
 48           dcl     whoami                        char (32);
 49           dcl     type                          fixed bin (2);
 50           dcl     cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 51           dcl     check_star_name_$entry        entry (character (*), fixed binary (35));
 52           dcl     expand_pathname_              entry (character (*), character (*), character (*), fixed binary (35));
 53           dcl     (
 54                   com_err_,
 55                   com_err_$suppress_name
 56                   )                             ext entry options (variable);
 57           dcl     error_table_$namedup          external fixed bin (35);
 58           dcl     error_table_$segnamedup       external fixed bin (35);
 59           dcl     get_wdir_                     ext entry returns (char (168));
 60           dcl     hcs_$star_                    entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
 61                                                 fixed bin (35));
 62           dcl     hcs_$status_minf              entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
 63                                                 fixed bin (35));
 64           dcl     copy_names_                   entry (character (*), character (*), character (*), character (*),
 65                                                 character (*), bit (1) aligned, fixed binary (35));
 66           dcl     move_names_                   entry (character (*), character (*), character (*), character (*),
 67                                                 character (*), bit (1) aligned, fixed binary (35));
 68           dcl     get_equal_name_               entry (character (*), character (*), character (32), fixed binary (35));
 69           dcl     cu_$arg_count                 ext entry (fixed bin, fixed bin (35));
 70           dcl     pathname_                     entry (character (*), character (*)) returns (character (168));
 71           dcl     get_system_free_area_         entry() returns(ptr);
 72 ^L
 73 /* The additional names are to be left on the original segment. */
 74 
 75           copy = "1"b;
 76           whoami = "copy_names";
 77           go to work;
 78 
 79 move_names:
 80      entry options (variable);
 81 
 82 /* The additional names are to be removed from the original segment. */
 83 
 84           copy = "0"b;
 85           whoami = "move_names";
 86 
 87 work:
 88           call cu_$arg_count (n, code);
 89           if code ^= 0
 90           then do;
 91                     call com_err_ (code, whoami);
 92                     return;
 93                end;
 94           if n = 0
 95           then do;
 96                     call com_err_$suppress_name (0, whoami, "Usage:  ^a from1 to1 ... fromj toj", whoami);
 97                     return;
 98                end;
 99 
100           areap = get_system_free_area_ ();
101           star_entry_ptr, star_names_ptr = null;
102           on cleanup call cleaner;
103 
104 /* The following master loop processes each pair of arguments completely
105    unless some error code is returned by the file system. */
106 
107           do i = 1 to n by 2;
108 
109 /* get first arg */
110                call cu_$arg_ptr (i, ap, lng, code);
111                call expand_pathname_ (arg, dir1, en1, code);
112                if code ^= 0
113                then do;
114                          call com_err_ (code, whoami, "^a", arg);
115                          return;
116                     end;
117                call check_star_name_$entry (en1, code);
118                if code ^= 0
119                then do;
120                          if code = 1 | code = 2
121                          then stars = "1"b;
122                          else do;
123                                    call com_err_ (code, whoami, "^a", en1);
124                                    return;
125                               end;
126                     end;
127 
128 /* get second arg */
129                if i = n
130                then do;
131                          qent = en1;                        /* have odd no. of args */
132                          dir2 = get_wdir_ ();
133                          call doit;
134                     end;
135                else do;
136                          call cu_$arg_ptr (i + 1, ap, lng, code);
137                          call expand_pathname_ (arg, dir2, qent, code);
138                          if code ^= 0
139                          then do;
140                                    call com_err_ (code, whoami, "^a", arg);
141                                    return;
142                               end;
143                          if stars
144                          then do;
145                                    call hcs_$star_ (dir1, en1, 3, areap, star_entry_count, star_entry_ptr, star_names_ptr,
146                                         code);
147                                    if code ^= 0
148                                    then do;
149 errseg1:
150                                              call com_err_ (code, whoami, "^a", pathname_ (dir1, en1));
151                                              goto next_arg;
152                                         end;
153                                    do j = 1 to star_entry_count;
154                                         en1 = star_names (star_entries (j).nindex);
155                                         call doit;
156                                    end;
157                                    call cleaner;            /* get rid of current star structures */
158                               end;
159                          else call doit;
160                     end;
161 next_arg:
162           end;
163 
164 
165 doit:
166      proc;
167 
168           call get_equal_name_ (en1, qent, en2, code);
169           if code ^= 0
170           then do;
171                     call com_err_ (code, whoami, "^a for ^a", qent, en1);
172                     return;
173                end;
174 
175 /* Does target segment exist?? */
176 
177           call hcs_$status_minf (dir2, en2, 0, type, bitcnt, code);
178           if code ^= 0
179           then go to errseg2;
180 
181 /* If so, then move the names. */
182 
183           if copy
184           then call copy_names_ (dir1, en1, dir2, en2, whoami, errsw, code);
185           else call move_names_ (dir1, en1, dir2, en2, whoami, errsw, code);
186 
187           if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segnamedup
188           then if errsw
189                then
190 errseg2:
191                     call com_err_ (code, whoami, "^a", pathname_ (dir2, en2));
192                else call com_err_ (code, whoami, "^a", pathname_ (dir1, en1));
193 
194      end doit;
195 
196 cleaner:
197      proc;
198 
199           if star_names_ptr ^= null
200           then do;
201                     free star_names in (myarea);
202                     star_names_ptr = null;
203                end;
204           if star_entry_ptr ^= null
205           then do;
206                     free star_entries in (myarea);
207                     star_entry_ptr = null;
208                end;
209 
210           return;
211      end cleaner;
212 
213 %page;
214 %include star_structures;
215 
216      end copy_names;