1 /****^  **************************************************************
  2         *                                                            *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1990      *
  4         *                                                            *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1983    *
  6         *                                                            *
  7         * Copyright, (C) Massachusetts Institute of Technology, 1983 *
  8         *                                                            *
  9         ************************************************************** */
 10 
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(88-10-03,Flegel), approve(88-11-16,MCR8020), audit(89-01-16,Lee),
 17      install(89-01-24,MR12.3-1012):
 18      phx19616 - created procedure change_source_dir, see function header for
 19                 info.
 20      phx20481 - repaired ioa_ control strings for calls to error and
 21                 warning so that all 3 arguments are properly accounted for.
 22      phx21214 - reorder the copying of characteristics so that the ACL is
 23                 copied last and the ring_brackets are second last.
 24   2) change(88-11-10,Flegel), approve(88-12-22,MCR8028), audit(89-01-16,Lee),
 25      install(89-01-24,MR12.3-1012):
 26      phx21056 / phx21147 - ignore error_table_$action_not_performed when
 27                 setting max_length and allow suffix_XXX_ to set the
 28                 max_length appropriately when the copy is first perfomed.
 29   3) change(89-01-31,Flegel), approve(89-03-08,PBF8020), audit(89-03-09,Lee),
 30      install(89-03-13,MR12.3-1023):
 31      Post Bug Fix - The call to sub_error_ had control string backwards in
 32      respect to the pathnames that were to be used based on the value of
 33      switch.
 34   4) change(89-11-15,Flegel), approve(89-11-16,MECR0014),
 35      audit(89-11-15,LZimmerman), install(89-11-16,MR12.3-1118):
 36      Repair "change_source_dir" subroutine to verify that the target is a real
 37      directory (which excludes MSFs).
 38   5) change(89-12-14,Flegel), approve(89-12-14,MCR8151),
 39      audit(89-12-14,LZimmerman), install(90-04-19,MR12.4-1007):
 40      Install MECR0014 through regular installation procedures.
 41   6) change(90-09-04,Huen), approve(90-09-04,MCR8195), audit(90-09-26,Vu),
 42      install(90-10-14,MR12.4-1039):
 43      phx21348 (cmds_837) - Fix the error handling of the copy/move commands by
 44      intercepting the "sub_error" condition.
 45                                                    END HISTORY COMMENTS */
 46 
 47 
 48 /* format: style2,indcomtxt,idind30 */
 49 
 50 copy_:
 51      proc (P_copy_options_ptr);
 52 
 53 /* This is the primitive used to copy (and move) segments.
 54 
 55    Jay Pattin 6/2/83 */
 56 
 57 /****
 58       BIM 830923 rework of object_type_ to fs_util_ */
 59 /**** BIM 831022 split into fs_copy_ and copy_. */
 60 /**** BIM 831031 fixed raw mode to use source type instead of target. */
 61 /**** BIM 1984-07-27 fix copying with the raw switch. */
 62 /**** C Spitzer 841102 fix bug in sub_err_ call */
 63 /**** MSharpe 850206 to check the hcs type of the source before calling nd_handler_ */
 64 
 65 /**** * copy_ is the advertised interface for copying objects.
 66       copy_ uses fs_util_$copy to copy the contents,
 67       and then various copy_XXX_ utilities to copy other
 68       atrributes. In raw mode, it forcibly uses segment or
 69       msf copying in fs_standard_object_, and does
 70       attributes appropriately. */
 71 
 72           declare P_copy_options_ptr            ptr parameter;
 73 
 74           declare errsw                         bit (1) aligned;
 75           declare forced_access                 bit (1) aligned;
 76           declare max_length                    fixed bin (19);
 77           declare raw                           bit (1) aligned;
 78           declare same_dir_sw                   bit (1) aligned;
 79           declare ring_brackets                 (64) fixed bin (3);
 80           declare source_dir                    char (168);
 81           declare source_name                   char (32);
 82           declare source_type                   char (32);
 83           declare target_dir                    char (168);
 84           declare target_name                   char (32);
 85           declare (source_uid, target_uid)      bit (36) aligned;
 86           declare fs_type                       char (32);
 87           declare (source_hcs_type, target_hcs_type)
 88                                                 fixed bin (2);
 89           declare old_source_dir                char (168);
 90 
 91           declare 1 bks                         aligned like status_for_backup;
 92           declare 1 si                          aligned like suffix_info;
 93           declare 1 cei                         aligned like copy_error_info;
 94 
 95           declare (
 96                   error_table_$nonamerr,
 97                   error_table_$dirseg,
 98                   error_table_$namedup,
 99                   error_table_$noentry,
100                   error_table_$no_info,
101                   error_table_$sameseg,
102                   error_table_$segnamedup,
103                   error_table_$unimplemented_version,
104                   error_table_$unsupported_operation,
105                   error_table_$action_not_performed
106                   )                             fixed bin (35) external;
107 
108           declare copy_acl_                     entry (char (*), char (*), char (*), char (*), bit (1) aligned,
109                                                 fixed bin (35));
110           declare copy_names_                   entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned,
111                                                 fixed bin (35));
112           declare delete_$path                  entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
113           declare expand_pathname_              entry (char (*), char (*), char (*), fixed bin (35));
114           declare (
115                   hcs_$chname_file,
116                   fs_util_$chname_file
117                   )                             entry (char (*), char (*), char (*), char (*), fixed bin (35));
118           declare hcs_$get_link_target          entry (char (*), char (*), char (*), char (*), fixed bin (35));
119           declare hcs_$get_uid_file             entry (char (*), char (*), bit (36) aligned, fixed bin (35));
120           declare hcs_$status_minf              entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
121                                                 fixed bin (35));
122           declare hcs_$set_entry_bound          entry (char (*), char (*), fixed bin (14), fixed bin (35));
123           declare hcs_$status_for_backup        entry (char (*), char (*), ptr, fixed bin (35));
124           declare move_names_                   entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned,
125                                                 fixed bin (35));
126           declare nd_handler_$switches          entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35));
127 
128           declare get_shortest_path_            entry (char (*)) returns (char (168));
129           declare get_system_free_area_         entry () returns (ptr);
130           declare hcs_$status_                  entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
131 
132           declare 1 entries                     aligned,
133                     2 (
134                     copy_entry                  entry (ptr, fixed bin (35)),
135                   (get_ml_entry, set_ml_entry)  entry (char (*), char (*), fixed bin (19), fixed bin (35)),
136                   (get_rb_entry, set_rb_entry)  entry (char (*), char (*), (*) fixed bin (3), fixed bin (35)),
137                   (get_switch_entry, set_switch_entry)
138                                                 entry (char (*), char (*), char (*), bit (1) aligned, fixed bin (35))
139                   )                             variable;
140 
141           declare fs_util_$suffix_info_for_type entry (char (*), ptr, fixed bin (35));
142           declare fs_util_$get_type             entry (char (*), char (*), char (*), fixed bin (35));
143           declare fs_util_$make_entry_for_type  entry (char (*), char (*), entry, fixed bin (35));
144                                                             /*        declare fs_util_$copy                 entry (pointer, fixed bin (35));
145                                                             */
146           declare sub_err_                      entry options (variable);
147           declare pathname_                     entry (char (*), char (*)) returns (char (168));
148           declare code                          fixed bin (35);
149 
150           declare (addr, fixed, rtrim, string, index, length, pointer, substr)
151                                                 builtin;    /* format: off */
152 
153 %page; %include status_structures;
154 %page; %include status_for_backup;
155 %page; %include suffix_info;
156 %page; %include copy_options;
157 %page; %include copy_flags;
158 %page; %include access_mode_values;
159 %page; %include delete_options;
160 %page; %include nd_handler_options;
161 %page; %include sub_error_info;
162 %page; %include sub_err_flags;
163 %page; %include condition_info_header;
164 %page; %include condition_info;
165 %page; %include copy_error_info;
166 %page; %include file_system_operations;
167 /* format: on */
168 ^L
169 
170 
171           entries = Dummy_Procedure;                        /* aggregately */
172           old_source_dir = "";                              /* No source dir change */
173           copy_options_ptr = P_copy_options_ptr;
174           if copy_options.version ^= COPY_OPTIONS_VERSION_1
175           then call copy_error (error_table_$unimplemented_version, "0"b);
176 
177           if copy_options.extend & copy_options.update
178           then call fatal (0, "contents", "0"b, "The extend and update switches may not both be specified.");
179 
180           source_dir = copy_options.source_dir;
181           source_name = copy_options.source_name;
182           target_dir = copy_options.target_dir;
183           target_name = copy_options.target_name;
184 
185           raw = copy_options.raw;
186           forced_access = "0"b;
187 
188           call hcs_$status_minf (source_dir, source_name, 1 /* chase */, source_hcs_type, (0), code);
189           if code ^= 0
190           then if code ^= error_table_$no_info              /* may not be true for inner-ring entries;
191                                                                fs_util_$get_type will catch this anyway */
192                then call copy_error (code, "0"b);
193 
194           call fs_util_$get_type (source_dir, source_name, source_type, code);
195           if code = 0 & source_type = FS_OBJECT_TYPE_DIRECTORY
196           then code = error_table_$dirseg;
197           if code ^= 0
198           then call copy_error (code, "0"b);
199 
200           call hcs_$status_minf (target_dir, target_name, 0, target_hcs_type, (0), code);
201                                                             /* does target already exist? */
202           if code = error_table_$noentry
203           then /* Has to if updating or extending */
204                if copy_options.extend | copy_options.update
205                then call copy_error (code, "1"b);
206                else ;
207           else do;                                          /* check if source = target */
208                     if code ^= 0
209                     then call copy_error (code, "1"b);
210                     call hcs_$get_uid_file (source_dir, source_name, source_uid, (0));
211                     call hcs_$get_uid_file (target_dir, target_name, target_uid, (0));
212                     if source_uid = target_uid
213                     then if target_hcs_type ^= Link
214                          then call copy_error (error_table_$sameseg, "1"b);
215                          else do;                           /* in case we delete the link, get real source path */
216                                    call hcs_$get_link_target (copy_options.source_dir, copy_options.source_name,
217                                         source_dir, source_name, code);
218                                    if code ^= 0
219                                    then call copy_error (code, "0"b);
220 
221                                    copy_options.source_dir = source_dir;
222                                    copy_options.source_name = source_name;
223                               end;
224 
225                     if ^copy_options.no_name_dup & ^copy_options.extend & ^copy_options.update
226                     then do;
227 
228 /* MF - phx19616 - make sure pathname in source will not change */
229 
230                               call change_source_dir ();
231                               string (nd_handler_options) = ""b;
232                               nd_handler_options.delete_force = copy_options.force;
233                               nd_handler_options.raw = raw;
234                               call nd_handler_$switches (copy_options.caller_name, target_dir, target_name,
235                                    string (nd_handler_options), code);
236                               if code ^= 0
237                               then do;
238                                         if code = error_table_$action_not_performed
239                                         then code = error_table_$namedup;
240                                         call copy_error (code, "1"b);
241                                    end;
242                          end;
243                end;                                         /* name duplication */
244 
245           if raw
246           then /* we could use a GET_REAL_TYPE, ... */
247                if source_hcs_type = Segment
248                then fs_type = FS_OBJECT_TYPE_SEGMENT;
249                else fs_type = FS_OBJECT_TYPE_MSF;
250           else fs_type = source_type;
251 
252           call fs_util_$make_entry_for_type (fs_type, FS_COPY, copy_entry, (0));
253           call fs_util_$make_entry_for_type (fs_type, FS_GET_RING_BRACKETS, get_rb_entry, (0));
254           call fs_util_$make_entry_for_type (fs_type, FS_SET_RING_BRACKETS, set_rb_entry, (0));
255           call fs_util_$make_entry_for_type (fs_type, FS_GET_MAX_LENGTH, get_ml_entry, (0));
256           call fs_util_$make_entry_for_type (fs_type, FS_SET_MAX_LENGTH, set_ml_entry, (0));
257           call fs_util_$make_entry_for_type (fs_type, FS_GET_SWITCH, get_switch_entry, (0));
258           call fs_util_$make_entry_for_type (fs_type, FS_SET_SWITCH, set_switch_entry, (0));
259 
260           si.version = SUFFIX_INFO_VERSION_1;
261           call fs_util_$suffix_info_for_type (fs_type, addr (si), code);
262           if code ^= 0
263           then call copy_error (code, "0"b);
264 
265           if (copy_options.extend & ^si.copy_flags.extend) | (copy_options.update & ^si.copy_flags.update)
266           then call copy_error (error_table_$unsupported_operation, "0"b);
267 
268 /* phx21348 - use original if no source dir change */
269           if (old_source_dir = "") /* No source_dir change */
270                then call copy_entry (copy_options_ptr, code);     /* Grab the contents */
271           else begin; /* pass modified copy of struc that contains a valid source_dir */
272 /* MF - phx19616 - need to use a local version of copy_options so we don't
273    * change the original passed into us when there is a source_dir change */
274           declare 1 co                          aligned like copy_options;
275           declare sub_error_                    condition;
276                co = copy_options;
277                co.source_dir = source_dir;     /* source_dir change */
278 
279 /* phx21348 - If the sub_error_ condition occurs and the error was caused
280  * using the modifed copy of the copy_options struc (co) then we patch
281  * copy_error_info.copy_options_ptr to point back to the original version.
282  * This is necessary because the handler in the 'copy' command uses this
283  * value to determine whether to handle the condition. */
284                on sub_error_  begin;
285                     declare 1 ci                          aligned like condition_info;
286                     declare continue_to_signal_           entry (fixed bin(35));
287                     declare find_condition_info_          entry (ptr, ptr, fixed bin(35));
288                     declare null                          builtin;
289 
290                     ci.version = condition_info_version_1;
291                     call find_condition_info_ (null (), addr (ci), (0));
292                     sub_error_info_ptr = ci.info_ptr;
293                     if sub_error_info.name = "copy_" &
294                        copy_error_info.copy_options_ptr = addr(co) then
295                          copy_error_info.copy_options_ptr = P_copy_options_ptr;
296                     call continue_to_signal_ ((0));
297                end; /* of sub_error_ patch handler */
298 
299                call copy_entry (addr (co), code);       /* Grab the contents */
300           end;
301           if code ^= 0
302           then call copy_error (code, (copy_options.target_err_switch));
303 
304 /* MF - phx21214 - reorganized the characteristic copying section so that
305    * the ACL is last (except for source deletion) and the ring_brackets are
306    * second last. */
307 
308           if copy_options.max_length
309           then if ^si.copy_flags.max_length
310                then call unsup ("max length");
311                else do;
312                          call get_ml_entry (source_dir, source_name, max_length, code);
313                          if code ^= 0
314                          then call error (code, "max length", "0"b, "Getting max length on ^[^s^a^;^a^s^].");
315                          else do;
316                                    call set_ml_entry (target_dir, target_name, max_length, code);
317 
318 /* MF - phx21056 - ignore action_not_performed error code */
319 
320                                    if code ^= 0 & code ^= error_table_$action_not_performed
321                                    then call error (code, "max length", "1"b, "Setting max length on ^[^s^a^;^a^s^].");
322                               end;
323                     end;
324 
325           if copy_options.copy_switch
326           then if ^si.copy_flags.copy_switch
327                then call unsup ("copy switch");
328                else call copy_switch ("copy");
329 
330           if copy_options.safety_switch
331           then if ^si.copy_flags.safety_switch
332                then call unsup ("safety switch");
333                else call copy_switch ("safety");
334 
335           if copy_options.dumper_switches
336           then if ^si.copy_flags.dumper_switches
337                then call unsup ("dumper switches");
338                else do;
339                          call copy_switch ("complete_volume_dump");
340                          call copy_switch ("incremental_volume_dump");
341                     end;
342           if copy_options.entry_bound
343           then do;
344                     if fs_type ^= FS_OBJECT_TYPE_SEGMENT
345                     then goto NOT_GATE;
346                     bks.version = status_for_backup_version_2;
347                     call hcs_$status_for_backup (source_dir, source_name, addr (bks), code);
348                     if code ^= 0
349                     then call error (code, "entry bound", "0"b, "Getting entry bound on ^[^s^a^;^a^s^].");
350                     else if ^bks.entrypt
351                     then
352 NOT_GATE:
353                          call error (error_table_$unsupported_operation, "entry bound", "0"b,
354                               "Entry has no entry bound to copy. ^[^s^a^;^a^s^]");
355                     else do;
356                               call hcs_$set_entry_bound (target_dir, target_name, fixed (bks.entrypt_bound), code);
357                               if code ^= 0
358                               then call error (code, "entry bound", "1"b, "Setting entry bound on ^[^s^a^;^a^s^].");
359                          end;
360                end;
361 
362           if copy_options.ring_brackets
363           then if ^si.copy_flags.ring_brackets
364                then call unsup ("ring brackets");
365                else do;
366                          call get_rb_entry (source_dir, source_name, ring_brackets, code);
367                          if code ^= 0
368                          then call error (code, "ring brackets", "0"b, "Getting ring brackets on ^[^s^a^;^a^s^].");
369                          else do;
370                                    call set_rb_entry (target_dir, target_name, ring_brackets, code);
371                                    if code ^= 0
372                                    then call error (code, "ring brackets", "1"b,
373                                              "Setting ring brackets on ^[^s^a^;^a^s^].");
374                               end;
375                     end;
376 
377 /**** NOTE -- since we don't have copy_XXX_$raw yet, we have to skip these! */
378 
379           if ^raw
380           then do;
381                     if copy_options.acl
382                     then if ^si.copy_flags.acl
383                          then call unsup ("ACL");
384                          else do;
385                                    call copy_acl_ (source_dir, source_name, target_dir, target_name, errsw, code);
386                                    if code ^= 0
387                                    then call error (code, "ACL", errsw, "Copying ACL ^[from ^a^s^;to ^s^a^].");
388                               end;
389 
390                     if copy_options.names
391                     then if ^si.copy_flags.names
392                          then call unsup ("names");
393                          else do;
394                                    same_dir_sw = same_dirp ();
395                                    if same_dir_sw
396                                    then do;                 /* If in same dir, have to move names */
397                                              if ^copy_options.delete
398                                              then call warning (0, "names", "1"b,
399                                                        "Source and target are in the same directory. Names will be moved instead of copied."
400                                                        );
401                                              call move_names_ (source_dir, source_name, target_dir, target_name,
402                                                   copy_options.caller_name, errsw, code);
403                                         end;
404                                    else call copy_names_ (source_dir, source_name, target_dir, target_name,
405                                              copy_options.caller_name, errsw, code);
406 
407                                    if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segnamedup
408                                    then call error (code, "names", errsw, "Copying names ^[from ^a^s^;to ^s^a^].");
409                               end;
410 
411                end;
412 
413           if copy_options.delete
414           then do;
415                     string (delete_options) = ""b;
416                     delete_options.segment, delete_options.link, delete_options.chase, delete_options.question = "1"b;
417                     delete_options.force = copy_options.force;
418                     delete_options.raw = raw;
419                     call delete_$path (source_dir, source_name, string (delete_options), copy_options.caller_name, code);
420                     if code ^= 0
421                     then if code ^= error_table_$action_not_performed
422                          then call error (code, "delete", "0"b, "Deleting ^[^s^a^;^a^s^].");
423 
424                     if copy_options.names & same_dir_sw
425                     then do;
426                               if raw
427                               then call hcs_$chname_file (target_dir, target_name, "", source_name, code);
428                               else call fs_util_$chname_file (target_dir, target_name, "", source_name, code);
429                               if code ^= 0
430                               then call error (code, "names", "1"b, "Copying names to ^[^s^a^;^a^s^].");
431                          end;
432                end;
433 
434 MAIN_RETURN:
435           return;
436 %page;
437 same_dirp:
438      proc returns (bit (1) aligned);
439 
440           declare dir_dir                       char (168),
441                   dir_ent                       char (32);
442 
443           if source_dir = target_dir
444           then return ("1"b);
445 
446           call expand_pathname_ (source_dir, dir_dir, dir_ent, (0));
447           call hcs_$get_uid_file (dir_dir, dir_ent, source_uid, (0));
448 
449           call expand_pathname_ (target_dir, dir_dir, dir_ent, (0));
450           call hcs_$get_uid_file (dir_dir, dir_ent, target_uid, (0));
451 
452           return (source_uid = target_uid);
453      end same_dirp;
454 
455 
456 copy_switch:
457      proc (switch_name);
458 
459           declare switch_name                   char (*),
460                   value                         bit (1) aligned;
461 
462           call get_switch_entry (source_dir, source_name, switch_name, value, code);
463           if code ^= 0
464           then call error (code, rtrim (switch_name) || "switch", "0"b, "Getting switch from ^[^s^a^;^a^s^].");
465           else do;
466                     call set_switch_entry (target_dir, target_name, switch_name, value, code);
467                     if code ^= 0
468                     then call error (code, rtrim (switch_name) || "switch", "1"b, "Setting switch on ^[^s^a^;^a^s^].");
469                end;
470 
471           return;
472      end copy_switch;
473 ^L
474 change_source_dir:
475      proc ();
476 
477 /* FUNCTION
478 
479    phx19616 - Determine whether or not there will be a conflict in names
480    between a target pathname and some component of the source directory.  If
481    there is, then the source dir will be changed so that a new name is inserted
482    where the conflict occurs.  If there are no other names to use, then it will
483    merely return to let nd_handler and the user resolve what to do.
484 */
485 
486 /* MISC VARIABLES */
487           declare short_target_path             char (168) var;
488           declare short_target_dir              char (168) var;
489           declare short_source_dir              char (168) var;
490           declare target_type                   char (32);
491           declare done                          bit (1);
492           declare i                             fixed bin;
493           declare 1 sb                          aligned like status_branch;
494 
495 /* INIT */
496           short_target_dir = rtrim (get_shortest_path_ (target_dir));
497           short_source_dir = rtrim (get_shortest_path_ (source_dir));
498           short_target_path = rtrim (pathname_ (rtrim (short_target_dir), target_name));
499 
500 /* MAIN */
501 
502 /* Find out what type of file we are targetting to */
503 
504           call fs_util_$get_type (target_dir, target_name, target_type, code);
505           if (code ^= 0) then do;
506                call error (code, "copy_", "1"b, "Getting file system type of ^[^s^a^;^a^s^]");
507                return;
508           end;
509 
510 /* A target DIRECTORY contained in the source DIRECTORY is potential */
511 
512           if (target_type = FS_OBJECT_TYPE_DIRECTORY)
513                & (index (short_source_dir, short_target_path) > 0)
514           then do;
515                     status_ptr = addr (sb);
516                     status_area_ptr = get_system_free_area_ ();
517 
518                     call hcs_$status_ (target_dir, target_name, 0, status_ptr, status_area_ptr, code);
519                     if (code ^= 0)
520                     then call error (code, "status", "0"b, "Getting status on ^[^s^a^;^a^s^]");
521 
522                     done = "0"b;                            /* Is there really a contention? */
523                     do i = 1 to status_branch.short.nnames;
524                          if status_entry_names (i) = target_name
525                          then do;                           /* Found, so get out of the loop */
526                                    done = "1"b;
527                                    i = status_branch.short.nnames;
528                               end;
529                     end;
530                     if ^done
531                     then do;                                /* No, then get out */
532                               free status_entry_names;
533                               return;
534                          end;
535 
536                     i = 1;                                  /* Look for another name to use */
537                     done = "0"b;
538                     do while (^done);
539                          if (i > status_branch.short.nnames)
540                          then /* None at all */
541                               done = "1"b;
542                          else if (status_entry_names (i) ^= target_name)
543                          then /* Found */
544                               done = "1"b;
545                          else /* Keep trying */
546                               i = i + 1;
547                     end;
548 
549                     if (i > status_branch.short.nnames)
550                     then do;                                /* Oh-oh, can't continue */
551                               free status_entry_names;
552                               call fatal (error_table_$nonamerr, "copy_", "1"b,
553                                    "^s^s^a. Source will be deleted before copy completed.");
554                               return;
555                          end;
556 
557 /* Rearrange the names so that there will be no contention */
558 
559                     old_source_dir = source_dir;
560                     source_dir = short_target_dir || ">" || rtrim (status_entry_names (i));
561                     if length (short_target_path) < length (short_source_dir)
562                     then source_dir = rtrim (source_dir) || substr (short_source_dir, length (short_target_path) + 1);
563 
564                     free status_entry_names;
565                end;
566 
567      end change_source_dir;
568 ^L
569 
570 
571 copy_error:
572      proc (status, switch);
573 
574           declare status                        fixed bin (35),
575                   switch                        bit (1) aligned;
576 
577           cei.copy_options_ptr = copy_options_ptr;
578           cei.operation = "contents";
579           cei.target_err_switch = switch;
580 
581           do while ("1"b);
582                call sub_err_ (status, "copy_", ACTION_CANT_RESTART, addr (cei), (0), "^[^a^s^;^s^a^]", switch,
583                     pathname_ (target_dir, target_name), pathname_ (source_dir, source_name));
584 
585           end;
586 
587      end copy_error;
588 
589 unsup:
590      proc (op);
591 
592           declare op                            char (32);
593 
594           cei.copy_options_ptr = copy_options_ptr;
595           cei.operation = op;
596           cei.target_err_switch = "0"b;
597 
598           call sub_err_ (error_table_$unsupported_operation, "copy_", ACTION_CAN_RESTART, addr (cei), (0),
599                "The ^a object type does not support the copying of ^a. ^a", si.type_name, op,
600                pathname_ (source_dir, source_name));
601 
602           return;
603      end unsup;
604 
605 
606 error:
607      proc (status, op, switch, message);
608 
609           declare flags                         bit (36) aligned,
610                   status                        fixed bin (35),
611                   op                            char (*),
612                   switch                        bit (1) aligned,
613                   message                       char (*);
614 
615           flags = ACTION_CAN_RESTART;
616           goto COMMON;
617 
618 fatal:
619      entry (status, op, switch, message);
620 
621           flags = ACTION_CANT_RESTART;
622           goto COMMON;
623 
624 warning:
625      entry (status, op, switch, message);
626 
627           flags = ACTION_DEFAULT_RESTART;
628 COMMON:
629           cei.copy_options_ptr = copy_options_ptr;
630           cei.operation = op;
631           cei.target_err_switch = switch;
632 
633           call sub_err_ (status, "copy_", flags, addr (cei), (0), message, switch, pathname_ (source_dir, source_name),
634                pathname_ (target_dir, target_name));
635 
636           return;
637 
638      end error;
639 
640 Dummy_Procedure:
641      procedure options (non_quick);
642 
643           declare cu_$arg_count                 entry (fixed bin, fixed bin (35));
644           declare cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
645           declare last_arg_x                    fixed bin;
646           declare code_ptr                      pointer;
647           declare code                          fixed bin (35) based (code_ptr);
648           declare error_table_$no_operation     fixed bin (35) ext static;
649 
650           call cu_$arg_count (last_arg_x, (0));
651           call cu_$arg_ptr (last_arg_x, code_ptr, (0), (0));
652           code = error_table_$no_operation;
653           return;
654      end Dummy_Procedure;
655 
656      end copy_;