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