File::Copy fixes for VMS follow-up
[perl.git] / lib / File / Copy.pm
1 # File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
2 # source code has been placed in the public domain by the author.
3 # Please be kind and preserve the documentation.
4 #
5 # Additions copyright 1996 by Charles Bailey.  Permission is granted
6 # to distribute the revised code under the same terms as Perl itself.
7
8 package File::Copy;
9
10 use 5.006;
11 use strict;
12 use warnings;
13 use File::Spec;
14 use Config;
15 # During perl build, we need File::Copy but Fcntl might not be built yet
16 my $Fcntl_loaded = eval q{ use Fcntl qw [O_CREAT O_WRONLY O_TRUNC]; 1 };
17 # Similarly Scalar::Util
18 # And then we need these games to avoid loading overload, as that will
19 # confuse miniperl during the bootstrap of perl.
20 my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
21 our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
22 sub copy;
23 sub syscopy;
24 sub cp;
25 sub mv;
26
27 $VERSION = '2.15';
28
29 require Exporter;
30 @ISA = qw(Exporter);
31 @EXPORT = qw(copy move);
32 @EXPORT_OK = qw(cp mv);
33
34 $Too_Big = 1024 * 1024 * 2;
35
36 sub croak {
37     require Carp;
38     goto &Carp::croak;
39 }
40
41 sub carp {
42     require Carp;
43     goto &Carp::carp;
44 }
45
46 my $macfiles;
47 if ($^O eq 'MacOS') {
48         $macfiles = eval { require Mac::MoreFiles };
49         warn 'Mac::MoreFiles could not be loaded; using non-native syscopy'
50                 if $@ && $^W;
51 }
52
53 # Look up the feature settings on VMS using VMS::Feature when available.
54
55 my $use_vms_feature = 0;
56 BEGIN {
57     if ($^O eq 'VMS') {
58         if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
59             $use_vms_feature = 1;
60         }
61     }
62 }
63
64 # Need to look up the UNIX report mode.  This may become a dynamic mode
65 # in the future.
66 sub _vms_unix_rpt {
67     my $unix_rpt;
68     if ($use_vms_feature) {
69         $unix_rpt = VMS::Feature::current("filename_unix_report");
70     } else {
71         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
72         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
73     }
74     return $unix_rpt;
75 }
76
77 # Need to look up the EFS character set mode.  This may become a dynamic
78 # mode in the future.
79 sub _vms_efs {
80     my $efs;
81     if ($use_vms_feature) {
82         $efs = VMS::Feature::current("efs_charset");
83     } else {
84         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
85         $efs = $env_efs =~ /^[ET1]/i;
86     }
87     return $efs;
88 }
89
90
91 sub _catname {
92     my($from, $to) = @_;
93     if (not defined &basename) {
94         require File::Basename;
95         import  File::Basename 'basename';
96     }
97
98     if ($^O eq 'MacOS') {
99         # a partial dir name that's valid only in the cwd (e.g. 'tmp')
100         $to = ':' . $to if $to !~ /:/;
101     }
102
103     return File::Spec->catfile($to, basename($from));
104 }
105
106 # _eq($from, $to) tells whether $from and $to are identical
107 sub _eq {
108     my ($from, $to) = map {
109         $Scalar_Util_loaded && Scalar::Util::blessed($_)
110             && overload::Method($_, q{""})
111             ? "$_"
112             : $_
113     } (@_);
114     return '' if ( (ref $from) xor (ref $to) );
115     return $from == $to if ref $from;
116     return $from eq $to;
117 }
118
119 sub copy {
120     croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
121       unless(@_ == 2 || @_ == 3);
122
123     my $from = shift;
124     my $to = shift;
125
126     my $size;
127     if (@_) {
128         $size = shift(@_) + 0;
129         croak("Bad buffer size for copy: $size\n") unless ($size > 0);
130     }
131
132     my $from_a_handle = (ref($from)
133                          ? (ref($from) eq 'GLOB'
134                             || UNIVERSAL::isa($from, 'GLOB')
135                             || UNIVERSAL::isa($from, 'IO::Handle'))
136                          : (ref(\$from) eq 'GLOB'));
137     my $to_a_handle =   (ref($to)
138                          ? (ref($to) eq 'GLOB'
139                             || UNIVERSAL::isa($to, 'GLOB')
140                             || UNIVERSAL::isa($to, 'IO::Handle'))
141                          : (ref(\$to) eq 'GLOB'));
142
143     if (_eq($from, $to)) { # works for references, too
144         carp("'$from' and '$to' are identical (not copied)");
145         # The "copy" was a success as the source and destination contain
146         # the same data.
147         return 1;
148     }
149
150     if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
151         !($^O eq 'MSWin32' || $^O eq 'os2')) {
152         my @fs = stat($from);
153         if (@fs) {
154             my @ts = stat($to);
155             if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) {
156                 carp("'$from' and '$to' are identical (not copied)");
157                 return 0;
158             }
159         }
160     }
161
162     if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
163         $to = _catname($from, $to);
164     }
165
166     if (defined &syscopy && !$Syscopy_is_copy
167         && !$to_a_handle
168         && !($from_a_handle && $^O eq 'os2' )   # OS/2 cannot handle handles
169         && !($from_a_handle && $^O eq 'mpeix')  # and neither can MPE/iX.
170         && !($from_a_handle && $^O eq 'MSWin32')
171         && !($from_a_handle && $^O eq 'MacOS')
172         && !($from_a_handle && $^O eq 'NetWare')
173        )
174     {
175         my $copy_to = $to;
176
177         if ($^O eq 'VMS' && -e $from) {
178
179             if (! -d $to && ! -d $from) {
180
181                 my $vms_efs = _vms_efs();
182                 my $unix_rpt = _vms_unix_rpt();
183                 my $unix_mode = 0;
184                 my $from_unix = 0;
185                 $from_unix = 1 if ($from =~ /^\.\.?$/);
186                 my $from_vms = 0;
187                 $from_vms = 1 if ($from =~ m#[\[<\]]#);
188
189                 # Need to know if we are in Unix mode.
190                 if ($from_vms == $from_unix) {
191                     $unix_mode = $unix_rpt;
192                 } else {
193                     $unix_mode = $from_unix;
194                 }
195
196                 # VMS has sticky defaults on extensions, which means that
197                 # if there is a null extension on the destination file, it
198                 # will inherit the extension of the source file
199                 # So add a '.' for a null extension.
200
201                 # In unix_rpt mode, the trailing dot should not be added.
202
203                 if ($vms_efs) {
204                     $copy_to = $to;
205                 } else {
206                     $copy_to = VMS::Filespec::vmsify($to);
207                 }
208                 my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
209                 $file = $file . '.'
210                     unless (($file =~ /(?<!\^)\./) || $unix_rpt);
211                 $copy_to = File::Spec->catpath($vol, $dirs, $file);
212
213                 # Get rid of the old versions to be like UNIX
214                 1 while unlink $copy_to;
215             }
216         }
217
218         return syscopy($from, $copy_to);
219     }
220
221     my $closefrom = 0;
222     my $closeto = 0;
223     my ($status, $r, $buf);
224     local($\) = '';
225
226     my $from_h;
227     if ($from_a_handle) {
228        $from_h = $from;
229     } else {
230        open $from_h, "<", $from or goto fail_open1;
231        binmode $from_h or die "($!,$^E)";
232         $closefrom = 1;
233     }
234
235     # Seems most logical to do this here, in case future changes would want to
236     # make this croak for some reason.
237     unless (defined $size) {
238         $size = tied(*$from_h) ? 0 : -s $from_h || 0;
239         $size = 1024 if ($size < 512);
240         $size = $Too_Big if ($size > $Too_Big);
241     }
242
243     my $to_h;
244     if ($to_a_handle) {
245        $to_h = $to;
246     } else {
247         $to = _protect($to) if $to =~ /^\s/s;
248         if ($Fcntl_loaded) {
249             my $perm = (stat $from_h) [2] & 0xFFF;
250             sysopen $to_h, $to, O_CREAT() | O_TRUNC() | O_WRONLY(), $perm
251                 or goto fail_open2;
252         }
253         else {
254             $to_h = \do { local *FH };
255             open $to_h, ">", $to or goto fail_open2;
256         }
257         binmode $to_h or die "($!,$^E)";
258         $closeto = 1;
259     }
260
261     $! = 0;
262     for (;;) {
263         my ($r, $w, $t);
264        defined($r = sysread($from_h, $buf, $size))
265             or goto fail_inner;
266         last unless $r;
267         for ($w = 0; $w < $r; $w += $t) {
268            $t = syswrite($to_h, $buf, $r - $w, $w)
269                 or goto fail_inner;
270         }
271     }
272
273     close($to_h) || goto fail_open2 if $closeto;
274     close($from_h) || goto fail_open1 if $closefrom;
275
276     # Use this idiom to avoid uninitialized value warning.
277     return 1;
278
279     # All of these contortions try to preserve error messages...
280   fail_inner:
281     if ($closeto) {
282         $status = $!;
283         $! = 0;
284        close $to_h;
285         $! = $status unless $!;
286     }
287   fail_open2:
288     if ($closefrom) {
289         $status = $!;
290         $! = 0;
291        close $from_h;
292         $! = $status unless $!;
293     }
294   fail_open1:
295     return 0;
296 }
297
298 sub move {
299     croak("Usage: move(FROM, TO) ") unless @_ == 2;
300
301     my($from,$to) = @_;
302
303     my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
304
305     if (-d $to && ! -d $from) {
306         $to = _catname($from, $to);
307     }
308
309     ($tosz1,$tomt1) = (stat($to))[7,9];
310     $fromsz = -s $from;
311     if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
312       # will not rename with overwrite
313       unlink $to;
314     }
315
316     my $rename_to = $to;
317     if (-$^O eq 'VMS' && -e $from) {
318
319         if (! -d $to && ! -d $from) {
320
321             my $vms_efs = _vms_efs();
322             my $unix_rpt = _vms_unix_rpt();
323             my $unix_mode = 0;
324             my $from_unix = 0;
325             $from_unix = 1 if ($from =~ /^\.\.?$/);
326             my $from_vms = 0;
327             $from_vms = 1 if ($from =~ m#[\[<\]]#);
328
329             # Need to know if we are in Unix mode.
330             if ($from_vms == $from_unix) {
331                 $unix_mode = $unix_rpt;
332             } else {
333                 $unix_mode = $from_unix;
334             }
335
336             # VMS has sticky defaults on extensions, which means that
337             # if there is a null extension on the destination file, it
338             # will inherit the extension of the source file
339             # So add a '.' for a null extension.
340
341             # In unix_rpt mode, the trailing dot should not be added.
342
343             if ($vms_efs) {
344                 $rename_to = $to;
345             } else {
346                 $rename_to = VMS::Filespec::vmsify($to);
347             }
348             my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
349             $file = $file . '.'
350                 unless (($file =~ /(?<!\^)\./) || $unix_rpt);
351             $rename_to = File::Spec->catpath($vol, $dirs, $file);
352
353             # Get rid of the old versions to be like UNIX
354             1 while unlink $rename_to;
355         }
356     }
357
358     return 1 if rename $from, $rename_to;
359
360     # Did rename return an error even though it succeeded, because $to
361     # is on a remote NFS file system, and NFS lost the server's ack?
362     return 1 if defined($fromsz) && !-e $from &&           # $from disappeared
363                 (($tosz2,$tomt2) = (stat($to))[7,9]) &&    # $to's there
364                   ((!defined $tosz1) ||                    #  not before or
365                    ($tosz1 != $tosz2 or $tomt1 != $tomt2)) &&  #   was changed
366                 $tosz2 == $fromsz;                         # it's all there
367
368     ($tosz1,$tomt1) = (stat($to))[7,9];  # just in case rename did something
369
370     {
371         local $@;
372         eval {
373             local $SIG{__DIE__};
374             copy($from,$to) or die;
375             my($atime, $mtime) = (stat($from))[8,9];
376             utime($atime, $mtime, $to);
377             unlink($from)   or die;
378         };
379         return 1 unless $@;
380     }
381     ($sts,$ossts) = ($! + 0, $^E + 0);
382
383     ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
384     unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
385     ($!,$^E) = ($sts,$ossts);
386     return 0;
387 }
388
389 *cp = \&copy;
390 *mv = \&move;
391
392 # &syscopy is an XSUB under OS/2
393 unless (defined &syscopy) {
394     if ($^O eq 'VMS') {
395         *syscopy = \&rmscopy;
396     } elsif ($^O eq 'mpeix') {
397         *syscopy = sub {
398             return 0 unless @_ == 2;
399             # Use the MPE cp program in order to
400             # preserve MPE file attributes.
401             return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
402         };
403     } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
404         # Win32::CopyFile() fill only work if we can load Win32.xs
405         *syscopy = sub {
406             return 0 unless @_ == 2;
407             return Win32::CopyFile(@_, 1);
408         };
409     } elsif ($macfiles) {
410         *syscopy = sub {
411             my($from, $to) = @_;
412             my($dir, $toname);
413
414             return 0 unless -e $from;
415
416             if ($to =~ /(.*:)([^:]+):?$/) {
417                 ($dir, $toname) = ($1, $2);
418             } else {
419                 ($dir, $toname) = (":", $to);
420             }
421
422             unlink($to);
423             Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1);
424         };
425     } else {
426         $Syscopy_is_copy = 1;
427         *syscopy = \&copy;
428     }
429 }
430
431 1;
432
433 __END__
434
435 =head1 NAME
436
437 File::Copy - Copy files or filehandles
438
439 =head1 SYNOPSIS
440
441         use File::Copy;
442
443         copy("file1","file2") or die "Copy failed: $!";
444         copy("Copy.pm",\*STDOUT);
445         move("/dev1/fileA","/dev2/fileB");
446
447         use File::Copy "cp";
448
449         $n = FileHandle->new("/a/file","r");
450         cp($n,"x");
451
452 =head1 DESCRIPTION
453
454 The File::Copy module provides two basic functions, C<copy> and
455 C<move>, which are useful for getting the contents of a file from
456 one place to another.
457
458 =over 4
459
460 =item copy
461 X<copy> X<cp>
462
463 The C<copy> function takes two
464 parameters: a file to copy from and a file to copy to. Either
465 argument may be a string, a FileHandle reference or a FileHandle
466 glob. Obviously, if the first argument is a filehandle of some
467 sort, it will be read from, and if it is a file I<name> it will
468 be opened for reading. Likewise, the second argument will be
469 written to (and created if need be).  Trying to copy a file on top
470 of itself is a fatal error.
471
472 B<Note that passing in
473 files as handles instead of names may lead to loss of information
474 on some operating systems; it is recommended that you use file
475 names whenever possible.>  Files are opened in binary mode where
476 applicable.  To get a consistent behaviour when copying from a
477 filehandle to a file, use C<binmode> on the filehandle.
478
479 An optional third parameter can be used to specify the buffer
480 size used for copying. This is the number of bytes from the
481 first file, that will be held in memory at any given time, before
482 being written to the second file. The default buffer size depends
483 upon the file, but will generally be the whole file (up to 2MB), or
484 1k for filehandles that do not reference files (eg. sockets).
485
486 You may use the syntax C<use File::Copy "cp"> to get at the
487 "cp" alias for this function. The syntax is I<exactly> the same.
488
489 As of version 2.14, on UNIX systems, "copy" will preserve permission
490 bits like the shell utility C<cp> would do.
491
492 =item move
493 X<move> X<mv> X<rename>
494
495 The C<move> function also takes two parameters: the current name
496 and the intended name of the file to be moved.  If the destination
497 already exists and is a directory, and the source is not a
498 directory, then the source file will be renamed into the directory
499 specified by the destination.
500
501 If possible, move() will simply rename the file.  Otherwise, it copies
502 the file to the new location and deletes the original.  If an error occurs
503 during this copy-and-delete process, you may be left with a (possibly partial)
504 copy of the file under the destination name.
505
506 You may use the "mv" alias for this function in the same way that
507 you may use the "cp" alias for C<copy>.
508
509 =item syscopy
510 X<syscopy>
511
512 File::Copy also provides the C<syscopy> routine, which copies the
513 file specified in the first parameter to the file specified in the
514 second parameter, preserving OS-specific attributes and file
515 structure.  For Unix systems, this is equivalent to the simple
516 C<copy> routine, which doesn't preserve OS-specific attributes.  For
517 VMS systems, this calls the C<rmscopy> routine (see below).  For OS/2
518 systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
519 this calls C<Win32::CopyFile>.
520
521 On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
522 if available.
523
524 B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
525
526 If both arguments to C<copy> are not file handles,
527 then C<copy> will perform a "system copy" of
528 the input file to a new output file, in order to preserve file
529 attributes, indexed file structure, I<etc.>  The buffer size
530 parameter is ignored.  If either argument to C<copy> is a
531 handle to an opened file, then data is copied using Perl
532 operators, and no effort is made to preserve file attributes
533 or record structure.
534
535 The system copy routine may also be called directly under VMS and OS/2
536 as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
537 is the routine that does the actual work for syscopy).
538
539 =item rmscopy($from,$to[,$date_flag])
540 X<rmscopy>
541
542 The first and second arguments may be strings, typeglobs, typeglob
543 references, or objects inheriting from IO::Handle;
544 they are used in all cases to obtain the
545 I<filespec> of the input and output files, respectively.  The
546 name and type of the input file are used as defaults for the
547 output file, if necessary.
548
549 A new version of the output file is always created, which
550 inherits the structure and RMS attributes of the input file,
551 except for owner and protections (and possibly timestamps;
552 see below).  All data from the input file is copied to the
553 output file; if either of the first two parameters to C<rmscopy>
554 is a file handle, its position is unchanged.  (Note that this
555 means a file handle pointing to the output file will be
556 associated with an old version of that file after C<rmscopy>
557 returns, not the newly created version.)
558
559 The third parameter is an integer flag, which tells C<rmscopy>
560 how to handle timestamps.  If it is E<lt> 0, none of the input file's
561 timestamps are propagated to the output file.  If it is E<gt> 0, then
562 it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
563 timestamps other than the revision date are propagated; if bit 1
564 is set, the revision date is propagated.  If the third parameter
565 to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
566 if the name or type of the output file was explicitly specified,
567 then no timestamps are propagated, but if they were taken implicitly
568 from the input filespec, then all timestamps other than the
569 revision date are propagated.  If this parameter is not supplied,
570 it defaults to 0.
571
572 Like C<copy>, C<rmscopy> returns 1 on success.  If an error occurs,
573 it sets C<$!>, deletes the output file, and returns 0.
574
575 =back
576
577 =head1 RETURN
578
579 All functions return 1 on success, 0 on failure.
580 $! will be set if an error was encountered.
581
582 =head1 NOTES
583
584 =over 4
585
586 =item *
587
588 On Mac OS (Classic), the path separator is ':', not '/', and the 
589 current directory is denoted as ':', not '.'. You should be careful 
590 about specifying relative pathnames. While a full path always begins 
591 with a volume name, a relative pathname should always begin with a 
592 ':'.  If specifying a volume name only, a trailing ':' is required.
593
594 E.g.
595
596   copy("file1", "tmp");        # creates the file 'tmp' in the current directory
597   copy("file1", ":tmp:");      # creates :tmp:file1
598   copy("file1", ":tmp");       # same as above
599   copy("file1", "tmp");        # same as above, if 'tmp' is a directory (but don't do
600                                # that, since it may cause confusion, see example #1)
601   copy("file1", "tmp:file1");  # error, since 'tmp:' is not a volume
602   copy("file1", ":tmp:file1"); # ok, partial path
603   copy("file1", "DataHD:");    # creates DataHD:file1
604
605   move("MacintoshHD:fileA", "DataHD:fileB"); # moves (doesn't copy) files from one
606                                              # volume to another
607
608 =back
609
610 =head1 AUTHOR
611
612 File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
613 and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
614
615 =cut
616