1 /****^  **************************************************************
  2         *                                                            *
  3         * Copyright, (C) Honeywell Bull Inc., 1989                   *
  4         *                                                            *
  5         * Copyright, (C) Massachusetts Institute of Technology, 1983 *
  6         *                                                            *
  7         * Copyright, (C) Honeywell Information Systems Inc., 1983    *
  8         *                                                            *
  9         ************************************************************** */
 10 
 11 
 12 
 13 
 14 
 15 
 16 /****^  HISTORY COMMENTS:
 17   1) change(87-02-13,TLNguyen), approve(87-02-13,MCR7619),
 18      audit(87-03-20,Gilcrease), install(87-03-24,MR12.1-1011):
 19      - Change "copy" to always display a correct error message when copying
 20        a specified extended entry types into unsuffixed targets.
 21      - Change "move" to always display a correct error message when moving
 22        a specified MSF that has unsufficient ACL requirements in order to move.
 23      - Change "copy" to always display a correct error message when copying
 24        a specified segment or star convention is applied and unsufficient
 25        ACL requirements for directory containing a specified segment.
 26   2) change(88-10-03,Flegel), approve(89-01-09,MCR8020), audit(89-01-16,Lee),
 27      install(89-01-24,MR12.3-1012):
 28      Change sub_err_handler display of an error so that the causing pathname is
 29      properly displayed with the error according to the
 30      copy_error_info.target_err_switch value.  This sort of backs out phx20384
 31      as the solution addressed the wrong source its problem.
 32                                                    END HISTORY COMMENTS */
 33 
 34 
 35 /* format: style2,idind30,indcomtxt */
 36 copy:
 37 cp:
 38      procedure () options (variable);
 39 
 40 
 41 /****
 42       This is the standard service system command to copy a segment or
 43       multi-segment file.  This procedure also includes the move command, which
 44       consists of a copy (with names and ACLs) followed by a delete.
 45       Both commands take multiple arguments and the star convention.
 46       Under control of optional arguments it will also copy extra names
 47       and/or the ACL of the segment.
 48 */
 49 
 50 /* Coded 3 Aug 1969 David Clark */
 51 /* Revised 25 Sept 1969 0935 DDC */
 52 /* Modified by M Weaver 11 April 1970 */
 53 /* Broken into four routines by John Strayhorn. July 1, 1970 */
 54 /* Check for same directory, when copying names, added by T.Casey, Jan 1973 */
 55 /* Modified June 4 1974 by Steve Herbst */
 56 
 57 /* Rewritten: June 1979 by G. Palter, adding -chase in the process */
 58 /* Bugs fixed, check for "copy foo" added 07/14/81 S. Herbst */
 59 /* Changed move to move switches, max length, and ring brackets 11/17/82 S. Herbst */
 60 /* Fixed to move MSF ring brackets correctly 12/15/82 S. Herbst */
 61 /* Modified: 6/2/83 Jay Pattin moved it all to copy_ */
 62 /* 831001 BIM infintessimally cleaned up for installation */
 63 /* 841102 C Spitzer. fixed bug in sub_error_handler, getting null pointer fault if info_ptr not set */
 64 /* 850206 MSharpe.  changed -force_no_type to -inase/-inaee; modified to advise
 65    user that no non-dirs matched the starname */
 66 
 67           dcl     argument                      character (argument_lth) based (argument_ptr);
 68           dcl     argument_lth                  fixed binary (21);
 69           dcl     argument_ptr                  pointer;
 70 
 71           dcl     system_area                   area based (system_area_ptr);
 72 
 73           dcl     system_area_ptr               pointer;
 74 
 75           dcl     (argument_count, arg_idx)     fixed binary;
 76           dcl     arg_list_ptr                  pointer;
 77 
 78           dcl     NAME                          character (32);
 79                                                             /* who I am */
 80 
 81           dcl     code                          fixed binary (35);
 82 
 83           dcl     chase_sw                      bit (2) aligned;
 84                                                             /* either default or one of two given values */
 85           dcl     (brief, copy_command_sw, entry_only_sw, have_paths)
 86                                                 bit (1) aligned;
 87           dcl     (successful_copy,
 88                    inhibit_nomatch_error)       bit (1) aligned;
 89 
 90           dcl     (source_dir, target_dir)      character (168);
 91           dcl     (source_ename, target_eqname, ename)
 92                                                 character (32);
 93           dcl     source_stars                  fixed binary (35);
 94           dcl     source_type                   fixed binary (2);
 95 
 96           dcl     select_sw                     fixed binary (2);
 97           dcl     idx                           fixed binary;
 98 
 99           dcl     DEFAULT_2ND_NAME              character (2) static options (constant) initial ("==");
100 
101           dcl     (
102                   error_table_$argerr,
103                   error_table_$badopt,
104                   error_table_$badstar,
105                   error_table_$dirseg,
106                   error_table_$incorrect_access,
107                   error_table_$moderr,
108                   error_table_$namedup,
109                   error_table_$noarg,
110                   error_table_$noentry,
111                   error_table_$no_info,
112                   error_table_$not_seg_type,
113                   error_table_$sameseg,
114                   error_table_$inconsistent,
115                   error_table_$root,
116                   error_table_$unsupported_operation
117                   )                             fixed binary (35) external;
118 
119           dcl     (cleanup, sub_error_)         condition;
120 
121           dcl     (
122                   com_err_,
123                   com_err_$suppress_name
124                   )                             entry () options (variable);
125           dcl     check_star_name_$entry        entry (character (*), fixed binary (35));
126           dcl     continue_to_signal_           entry (fixed bin (35));
127           dcl     copy_                         entry (ptr);
128           dcl     cu_$arg_count                 entry (fixed bin, fixed bin (35));
129           dcl     cu_$arg_list_ptr              entry () returns (pointer);
130           dcl     cu_$arg_ptr                   entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
131           dcl     cu_$arg_ptr_rel               entry (fixed binary, pointer, fixed binary (21), fixed binary (35),
132                                                 pointer);
133           dcl     expand_pathname_              entry (character (*), character (*), character (*), fixed binary (35));
134           dcl     find_condition_info_          entry (ptr, ptr, fixed bin (35));
135           dcl     get_equal_name_               entry (character (*), character (*), character (*), fixed binary (35));
136           dcl     get_system_free_area_         entry () returns (pointer);
137           dcl     hcs_$star_                    entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
138                                                 fixed bin (35));
139           dcl     hcs_$status_minf              entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
140                                                 fixed bin (35));
141           dcl     pathname_                     entry (char (*), char (*)) returns (char (168));
142 
143           dcl     (addr, length, index, null, rtrim, search, string, substr, sum)
144                                                 builtin;
145 %page;
146 %include star_structures;
147 %page;
148 %include copy_options;
149 %page;
150 %include copy_flags;
151 
152           dcl     1 cpo                         aligned like copy_options;
153           dcl     1 explicit                    aligned like copy_flags;
154 %page;
155 %include sub_error_info;
156 
157 %include condition_info_header;
158 %page;
159 %include condition_info;
160 
161 %include copy_error_info;
162 %page;
163 /* copy: cp: entry () options (variable); */
164 
165           NAME = "copy";
166 
167           copy_command_sw = "1"b;
168           string (cpo.copy_items) = ""b;                    /* default options */
169 
170           go to COMMON;
171 
172 
173 
174 /* This is the move command */
175 
176 move:
177 mv:
178      entry () options (variable);
179 
180           NAME = "move";
181 
182           copy_command_sw = "0"b;
183 
184           string (cpo.copy_items) = ""b;
185           cpo.copy_items.acl, cpo.copy_items.names, cpo.copy_items.ring_brackets, cpo.copy_items.max_length,
186                cpo.copy_items.copy_switch, cpo.copy_items.safety_switch, cpo.copy_items.dumper_switches = "1"b;
187 
188 
189 
190 /* Actual work starts here */
191 
192 COMMON:
193           chase_sw = "00"b;                                 /* none supplied */
194           cpo.version = COPY_OPTIONS_VERSION_1;
195           cpo.caller_name = NAME;
196 
197           cpo.copy_items.entry_bound = "1"b;                /* always copy */
198           string (cpo.flags) = ""b;
199           cpo.flags.delete = ^copy_command_sw;
200 
201           string (explicit) = ""b;
202 
203           call cu_$arg_count (argument_count, code);
204           if code ^= 0
205           then do;
206                     call com_err_ (code, NAME);
207                     return;
208                end;
209 
210           if argument_count = 0
211           then do;
212 USAGE:
213                     call com_err_ (error_table_$noarg, NAME, "^/^6xUsage: ^a path1 {equal_name1 ...} {-control_args}",
214                          NAME);
215                     return;
216                end;
217 
218 
219 /* Scan for control arguments */
220 
221           have_paths = "0"b;                                /* haven't found any yet */
222 
223           do arg_idx = 1 to argument_count;
224 
225                call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, code);
226                if code ^= 0
227                then do;
228                          call com_err_ (code, NAME, "Fetching argument #^d.", arg_idx);
229                          return;
230                     end;
231 
232                if substr (argument, 1, 1) ^= "-"
233                then have_paths = "1"b;                      /* found some pathnames */
234 
235                else if (argument = "-brief") | (argument = "-bf")
236                then brief = "1"b;
237 
238                else if (argument = "-long") | (argument = "-lg")
239                then brief = "0"b;
240 
241                else if (argument = "-all") | (argument = "-a")
242                then cpo.copy_items.acl, cpo.copy_items.names, cpo.copy_items.ring_brackets, cpo.copy_items.max_length,
243                          cpo.copy_items.copy_switch, cpo.copy_items.safety_switch, cpo.copy_items.dumper_switches = "1"b;
244 
245                else if (argument = "-acl")
246                then cpo.copy_items.acl, explicit.acl = "1"b;
247 
248                else if (argument = "-no_acl")
249                then cpo.copy_items.acl, explicit.acl = "0"b;
250 
251                else if (argument = "-name") | (argument = "-nm")
252                then cpo.copy_items.names, explicit.names = "1"b;
253 
254                else if (argument = "-no_name") | (argument = "-nnm")
255                then cpo.copy_items.names, explicit.names = "0"b;
256 
257                else if (argument = "-chase")
258                then chase_sw = "11"b;                       /* explicit request to do chasing */
259 
260                else if (argument = "-no_chase")
261                then chase_sw = "10"b;
262 
263                else if argument = "-force" | argument = "-fc"
264                then cpo.flags.force = "1"b;
265 
266                else if argument = "-no_force" | argument = "-nfc"
267                then cpo.flags.force = "0"b;
268 
269                else if argument = "-max_length" | argument = "-ml"
270                then cpo.copy_items.max_length, explicit.max_length = "1"b;
271 
272                else if argument = "-no_max_length" | argument = "-nml"
273                then cpo.copy_items.max_length, explicit.max_length = "0"b;
274 
275                else if argument = "-ring_brackets" | argument = "-rb"
276                then cpo.copy_items.ring_brackets, explicit.ring_brackets = "1"b;
277 
278                else if argument = "-no_ring_brackets" | argument = "-nrb"
279                then cpo.copy_items.ring_brackets, explicit.ring_brackets = "0"b;
280 
281                else if argument = "-copy_switch" | argument = "-csw"
282                then cpo.copy_items.copy_switch, explicit.copy_switch = "1"b;
283 
284                else if argument = "-no_copy_switch" | argument = "-ncsw"
285                then cpo.copy_items.copy_switch, explicit.copy_switch = "0"b;
286 
287                else if argument = "-safety_switch" | argument = "-ssw"
288                then cpo.copy_items.safety_switch, explicit.safety_switch = "1"b;
289 
290                else if argument = "-no_safety_switch" | argument = "-nssw"
291                then cpo.copy_items.safety_switch, explicit.safety_switch = "0"b;
292 
293                else if argument = "-volume_dumper_switches" | argument = "-vdsw"
294                then cpo.copy_items.dumper_switches, explicit.dumper_switches = "1"b;
295 
296                else if argument = "-no_volume_dumper_switches" | argument = "-nvdsw"
297                then cpo.copy_items.dumper_switches, explicit.dumper_switches = "0"b;
298 
299                else if argument = "-entry_bound" | argument = "-eb"
300                then cpo.copy_items.entry_bound, explicit.entry_bound = "1"b;
301 
302                else if argument = "-no_entry_bound" | argument = "-neb"
303                then cpo.copy_items.entry_bound, explicit.entry_bound = "0"b;
304 
305                else if argument = "-extend"
306                then do;
307                          cpo.copy_items.extend = "1"b;
308                          cpo.copy_items.update = "0"b;
309                     end;
310 
311                else if ^copy_command_sw
312                then goto BADOPT;
313 
314                else if argument = "-replace" | argument = "-rp"
315                then cpo.copy_items.extend, cpo.copy_items.update = "0"b;
316 
317                else if argument = "-update" | argument = "-ud"
318                then do;
319                          cpo.copy_items.update = "1"b;
320                          cpo.copy_items.extend = "0"b;
321                     end;
322 
323                else if argument = "-interpret_as_standard_entry" | argument = "-inase"
324                then cpo.flags.raw = "1"b;
325 
326                else if argument = "-interpret_as_extended_entry" | argument = "-inaee"
327                then cpo.flags.raw = "0"b;
328 
329                else do;
330 BADOPT:
331                          call com_err_ (error_table_$badopt, NAME, """^a""", argument);
332                          return;
333                     end;
334           end;
335 
336           if ^have_paths
337           then /* nothing to work on */
338                go to USAGE;
339 
340           if (cpo.copy_items.extend | cpo.copy_items.update)
341                & (cpo.copy_items.acl | cpo.copy_items.names | cpo.copy_items.ring_brackets | cpo.copy_items.max_length
342                | cpo.copy_items.copy_switch | cpo.copy_items.safety_switch | cpo.copy_items.dumper_switches)
343           then do;
344                     call com_err_ (error_table_$inconsistent, NAME,
345                          "Attributes may not be copied when -^[extend^;update^] is used.", cpo.copy_items.extend);
346                     return;
347                end;                                         /*^L                                                        */
348 
349           system_area_ptr = get_system_free_area_ ();
350 
351           star_entry_ptr,                                   /* so cleanup will work */
352                star_names_ptr = null ();
353 
354           on condition (cleanup) call clean_up ();
355 
356 
357 /* Process the pairs of pathnames supplied */
358 
359           arg_list_ptr = cu_$arg_list_ptr ();
360 
361           do arg_idx = 1 to argument_count;
362 
363                call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, (0));
364                                                             /* known to work from above */
365 
366                if substr (argument, 1, 1) ^= "-"
367                then do;                                     /* ignore control args */
368 
369                          entry_only_sw = (search (argument, "<>") = 0);
370 
371                          call expand_pathname_ (argument, source_dir, source_ename, code);
372                          if code ^= 0
373                          then do;
374                                    call com_err_ (code, NAME, "^a", argument);
375                                    call find_second_arg ();
376                                    go to NEXT_PAIR;
377                               end;
378 
379                          call check_star_name_$entry (source_ename, source_stars);
380                          if (source_stars ^= 0) & (source_stars ^= 1) & (source_stars ^= 2)
381                          then do;
382                                    call com_err_ (source_stars, NAME, "^a", pathname_ (source_dir, source_ename));
383                                    call find_second_arg ();
384                                    go to NEXT_PAIR;
385                               end;
386 
387                          call find_second_arg ();           /* move on to second pair (if any) */
388 
389                          if arg_idx > argument_count
390                          then do;                           /* none, use === */
391                                    if entry_only_sw
392                                    then do;
393                                              call com_err_ (0, NAME, "No target pathname specified.");
394                                              return;
395                                         end;
396                                    argument_ptr = addr (DEFAULT_2ND_NAME);
397                                    argument_lth = length (DEFAULT_2ND_NAME);
398                               end;
399 
400                          call expand_pathname_ (argument, target_dir, target_eqname, code);
401                          if code ^= 0
402                          then do;
403                                    call com_err_ (code, NAME, "^a", argument);
404                                    go to NEXT_PAIR;
405                               end;
406 
407                          call check_star_name_$entry (target_eqname, code);
408                          if code ^= 0
409                          then do;
410                                    if code > 2 then  /* code = error_table_$badstar  */
411 /* fix an incorrect error message, for example ! copy foo >  */
412                                         if argument = ">" then do;
413                                               call com_err_ (error_table_$root, NAME,
414                                                              "^a.  Your request has been aborted.", argument);
415                                               go to NEXT_PAIR;
416                                         end;
417 /* end of bug fix */
418                                         else call com_err_ (code, NAME, "^a", pathname_ (target_dir, target_eqname));
419                                    else call com_err_ (0, NAME, "Star convention not allowed in second argument.  ^a",
420                                              pathname_ (target_dir, target_eqname));
421                                    go to NEXT_PAIR;
422                               end;
423 
424 
425 /* Preliminary checks OK for this pair; now do the work */
426 
427                          if source_stars = 0
428                          then do;                           /* source name is a single entry */
429                                    if chase_sw = "10"b
430                                    then do;                 /* user doesn't want links chased */
431                                              call hcs_$status_minf (source_dir, source_ename, 0b, source_type, (0), code);
432                                              if code ^= 0
433                                              then do;
434                                                        call com_err_ (code, NAME, "^a",
435                                                             pathname_ (source_dir, source_ename));
436                                                        go to NEXT_PAIR;
437                                                   end;
438                                              if source_type = star_LINK
439                                              then do;
440                                                        call com_err_ (0, NAME,
441                                                             "^a is a link and ""-no_chase"" was specified.",
442                                                             pathname_ (source_dir, source_ename));
443                                                        go to NEXT_PAIR;
444                                                   end;
445                                         end;
446 
447                                    call process_entry (source_ename, "1"b, ("0"b));
448                                                             /* ignore the successful_copy bit */
449                               end;                          /* do the work */
450 
451 
452                          else do;                           /* source name is a star name */
453                                    if chase_sw = "11"b
454                                    then select_sw = star_ALL_ENTRIES;
455                                                             /* request -chase */
456                                    else select_sw = star_BRANCHES_ONLY;
457 
458                                    call hcs_$star_ (source_dir, source_ename, select_sw, system_area_ptr,
459                                         star_entry_count, star_entry_ptr, star_names_ptr, code);
460                                    if code ^= 0 then
461 /* fix bug for TR number 19526 */
462                                         if code = error_table_$moderr then do;
463                                              call com_err_ (error_table_$incorrect_access, NAME, "^a",
464                                                             pathname_ (source_dir, source_ename));
465                                              go to NEXT_PAIR;
466                                         end;
467 /* end of bug fix */
468                                         else do;
469                                              call com_err_ (code, NAME, "^a", pathname_ (source_dir, source_ename));
470                                              go to NEXT_PAIR;
471                                         end;
472 
473                                    inhibit_nomatch_error,
474                                    successful_copy = "0"b;  /* If still OFF after the loop, there were no
475                                                                non-dirs that matched the starname */
476                                    do idx = 1 to star_entry_count;
477 
478                                         ename = star_names (star_entries (idx).nindex);
479                                         call process_entry (ename, "0"b, successful_copy);
480                                    end;                     /* ignore directories */
481                                    if ^successful_copy
482                                         & ^inhibit_nomatch_error
483                                         then call com_err_ (0, NAME,
484                                              "No entries of appropriate type matched the starname ^a",
485                                              pathname_ (source_dir, source_ename));
486                               end;
487 
488 NEXT_PAIR:
489                          call clean_up ();                  /* free up anything still around */
490                     end;                                    /* of non-control argument */
491           end;
492 
493 /*^L*/
494 
495 /* This internal procedure cleans up after an argument pair */
496 
497 clean_up:
498      procedure ();
499 
500 
501           if star_names_ptr ^= null ()
502           then do;
503                     free star_names in (system_area);
504                     star_names_ptr = null ();
505                end;
506 
507           if star_entry_ptr ^= null ()
508           then do;
509                     free star_entries in (system_area);
510                     star_entry_ptr = null ();
511                end;
512 
513           return;
514 
515      end clean_up;                                          /*^L                                                        */
516 find_second_arg:
517      procedure ();
518 
519 /* This internal procedure scans the argument list looking for the second pathname
520    of the current pair (if any) */
521 
522           do arg_idx = (arg_idx + 1) to argument_count;
523 
524                call cu_$arg_ptr_rel (arg_idx, argument_ptr, argument_lth, (0), arg_list_ptr);
525 
526                if substr (argument, 1, 1) ^= "-"
527                then /* found it */
528                     return;
529           end;
530 
531           arg_idx = argument_count + 1;                     /* none found */
532 
533           return;
534 
535      end find_second_arg;
536 %page;
537 process_entry:                                              /* copy one segment */
538      procedure (P_ename, P_report_dirseg, P_successful_copy);
539 
540           dcl     P_ename                       character (32) parameter;
541                                                             /* source entry name */
542           dcl     P_report_dirseg               bit (1) aligned parameter;
543                                                             /* ON => e_t_$dirseg on source */
544 
545           dcl     P_successful_copy             bit (1) aligned parameter;
546                                                             /* OUTPUT: ON => entry successfully copied */
547 
548           dcl     bit_count                     fixed binary (24); /* bit count returned by hcs_$status_minf. */
549           dcl     (source_ename, target_ename)  character (32);
550           dcl     code                          fixed binary (35);
551           dcl     target_type                   fixed binary (2); /* type of a target entryname returned by hcs_$status_minf. */
552 
553           source_ename = P_ename;
554           bit_count = -0;                                   /* initialized */
555           target_type = -0;                                 /* initialized */
556 
557           call get_equal_name_ (source_ename, target_eqname, target_ename, code);
558           if code ^= 0
559           then do;
560                     call com_err_ (code, NAME, "^a for ^a", pathname_ (target_dir, target_eqname), source_ename);
561                     return;
562                end;
563 
564           cpo.source_dir = source_dir;
565           cpo.source_name = source_ename;
566           cpo.target_dir = target_dir;
567           cpo.target_name = target_ename;
568 
569           on sub_error_ call sub_err_handler ();            /* copy_ reports erors with sub_err_ */
570 
571           call copy_ (addr (cpo));                          /* go to it */
572           P_successful_copy = "1"b;
573 
574 COPY_LOST:
575           return;
576 %page;
577 sub_err_handler:
578      proc ();
579 
580           declare 1 ci                          aligned like condition_info;
581           declare reverse                       builtin;
582           declare suffix_name                   char (8) varying init ("");
583           declare temp_source_ename             char (32) varying init ("");
584 
585           ci.version = condition_info_version_1;
586           call find_condition_info_ (null (), addr (ci), (0));
587           sub_error_info_ptr = ci.info_ptr;
588 
589           if sub_error_info.name ^= "copy_"
590           then do;
591 CONTINUE_TO_SIGNAL:
592                call continue_to_signal_ ((0));
593                     goto END_HANDLER;
594                end;
595           else if sub_error_info.info_ptr = null
596                then goto CONTINUE_TO_SIGNAL;
597           else if copy_error_info.copy_options_ptr ^= addr (cpo)
598                then goto CONTINUE_TO_SIGNAL;
599 
600           code = sub_error_info.status_code;
601 
602           if sub_error_info.cant_restart
603           then do;                                          /* copy failed */
604                     if ^copy_error_info.target_err_switch
605                     then if code = error_table_$dirseg
606                          then /* source is a directory */
607                               if ^P_report_dirseg
608                               then /* but that's OK for starnames */
609                                    goto COPY_LOST;
610 
611                     inhibit_nomatch_error = "1"b;           /* found an appropriate entry that matched the starname,
612                                                                but still didn't get it copied --
613                                                                Don't report a nomatch for this starname */
614 
615                     if code ^= error_table_$namedup then /* already reported */
616 /* fix bug for TR number phx20617 */
617                          if (code = error_table_$badstar) | (code = error_table_$argerr) then do;
618                               temp_source_ename = reverse (rtrim (source_ename));
619 
620                               suffix_name = substr (temp_source_ename, 1, (index (temp_source_ename, ".") - 1));
621                               suffix_name = reverse (suffix_name);
622                               call com_err_ (error_table_$not_seg_type, NAME,  "The .^a suffix was missing from  ^a",
623                                         suffix_name, pathname_ (target_dir, target_ename));
624                          end;
625 /* fix bug for TR number phx19526 */
626                          else if code = error_table_$no_info then
627                                call com_err_ (error_table_$incorrect_access, NAME, sub_error_info.info_string);
628 /* end of bug fixes */
629                          else call com_err_ (code, NAME, sub_error_info.info_string);
630                     else;
631                     if ^copy_command_sw
632                     then if (code ^= error_table_$noentry) & (code ^= error_table_$dirseg)
633                               & (code ^= error_table_$moderr) & (code ^= error_table_$sameseg)
634                               & (code ^= error_table_$namedup)
635                          then call com_err_$suppress_name (0, NAME, "Segment ^a not deleted.",
636                                    pathname_ (source_dir, source_ename));
637                     goto COPY_LOST;
638                end;                                         /* fatal error */
639 
640           else if sub_error_info.default_restart
641           then if ^brief
642                then call com_err_ (code, NAME, sub_error_info.info_string);
643                else ;
644 
645           else do;
646                     if code = error_table_$unsupported_operation
647                     then if badop ()
648                          then call com_err_ (0, NAME, sub_error_info.info_string);
649                          else ;
650 /* fix an incorrect error message for TR number phx20384, this is backed out
651  * with phx20481 as the original repair was incorrect */
652                     else do;
653                          call com_err_ (code, NAME, sub_error_info.info_string);
654                          goto COPY_LOST;
655                     end;
656 /* end of fixing */
657                end;
658 END_HANDLER:
659           return;
660 
661      end sub_err_handler;
662 %page;
663 badop:                                                      /* returns true iff operation specifically requested */
664      proc returns (bit (1) aligned);
665 
666           declare op                            char (32);
667 
668           op = copy_error_info.operation;
669           if op = "names"
670           then return (explicit.names | ^copy_command_sw);
671           if op = "ACL"
672           then return (explicit.acl | ^copy_command_sw);
673           if op = "ring brackets"
674           then return (explicit.ring_brackets);
675           if op = "max length"
676           then return (explicit.max_length);
677           if op = "copy switch"
678           then return (explicit.copy_switch);
679           if op = "safety switch"
680           then return (explicit.safety_switch);
681           if op = "dumper switches"
682           then return (explicit.dumper_switches);
683           if op = "entry bound"
684           then return (explicit.entry_bound);
685 
686           return ("1"b);                                    /* if we don't recognize it, print it. */
687      end badop;
688      end process_entry;
689 
690      end copy;