1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50 copy_:
51 proc (P_copy_options_ptr);
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
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
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;
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
168 ^L
169
170
171 entries = Dummy_Procedure;
172 old_source_dir = "";
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 , source_hcs_type, (0), code);
189 if code ^= 0
190 then if code ^= error_table_$no_info
191
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
202 if code = error_table_$noentry
203 then
204 if copy_options.extend | copy_options.update
205 then call copy_error (code, "1"b);
206 else ;
207 else do;
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;
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
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;
244
245 if raw
246 then
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
269 if (old_source_dir = "")
270 then call copy_entry (copy_options_ptr, code);
271 else begin;
272
273
274 declare 1 co aligned like copy_options;
275 declare sub_error_ condition;
276 co = copy_options;
277 co.source_dir = source_dir;
278
279
280
281
282
283
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;
298
299 call copy_entry (addr (co), code);
300 end;
301 if code ^= 0
302 then call copy_error (code, (copy_options.target_err_switch));
303
304
305
306
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
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
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;
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
478
479
480
481
482
483
484
485
486
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
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
501
502
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
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;
523 do i = 1 to status_branch.short.nnames;
524 if status_entry_names (i) = target_name
525 then do;
526 done = "1"b;
527 i = status_branch.short.nnames;
528 end;
529 end;
530 if ^done
531 then do;
532 free status_entry_names;
533 return;
534 end;
535
536 i = 1;
537 done = "0"b;
538 do while (^done);
539 if (i > status_branch.short.nnames)
540 then
541 done = "1"b;
542 else if (status_entry_names (i) ^= target_name)
543 then
544 done = "1"b;
545 else
546 i = i + 1;
547 end;
548
549 if (i > status_branch.short.nnames)
550 then do;
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
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_;