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.
5 # Additions copyright 1996 by Charles Bailey. Permission is granted
6 # to distribute the revised code under the same terms as Perl itself.
12 use warnings
; no warnings
'newline';
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);
29 @EXPORT = qw(copy move);
30 @EXPORT_OK = qw(cp mv);
32 $Too_Big = 1024 * 1024 * 2;
44 # Look up the feature settings on VMS using VMS::Feature when available.
46 my $use_vms_feature = 0;
49 if (eval { local $SIG{__DIE__
}; require VMS
::Feature
; }) {
55 # Need to look up the UNIX report mode. This may become a dynamic mode
59 if ($use_vms_feature) {
60 $unix_rpt = VMS
::Feature
::current
("filename_unix_report");
62 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
63 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
68 # Need to look up the EFS character set mode. This may become a dynamic
72 if ($use_vms_feature) {
73 $efs = VMS
::Feature
::current
("efs_charset");
75 my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
76 $efs = $env_efs =~ /^[ET1]/i;
84 if (not defined &basename
) {
85 require File
::Basename
;
86 import File
::Basename
'basename';
89 return File
::Spec
->catfile($to, basename
($from));
92 # _eq($from, $to) tells whether $from and $to are identical
94 my ($from, $to) = map {
95 $Scalar_Util_loaded && Scalar
::Util
::blessed
($_)
96 && overload
::Method
($_, q{""})
100 return '' if ( (ref $from) xor (ref $to) );
101 return $from == $to if ref $from;
106 croak
("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
107 unless(@_ == 2 || @_ == 3);
114 $size = shift(@_) + 0;
115 croak
("Bad buffer size for copy: $size\n") unless ($size > 0);
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'));
129 if (_eq
($from, $to)) { # works for references, too
130 carp
("'$from' and '$to' are identical (not copied)");
131 # The "copy" was a success as the source and destination contain
136 if ((($Config{d_symlink
} && $Config{d_readlink
}) || $Config{d_link
}) &&
137 !($^O
eq 'MSWin32' || $^O
eq 'os2')) {
138 my @fs = stat($from);
141 if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p
$from) {
142 carp
("'$from' and '$to' are identical (not copied)");
148 if (!$from_a_handle && !$to_a_handle && -d
$to && ! -d
$from) {
149 $to = _catname
($from, $to);
152 if (defined &syscopy
&& !$Syscopy_is_copy
154 && !($from_a_handle && $^O
eq 'os2' ) # OS/2 cannot handle handles
155 && !($from_a_handle && $^O
eq 'mpeix') # and neither can MPE/iX.
156 && !($from_a_handle && $^O
eq 'MSWin32')
157 && !($from_a_handle && $^O
eq 'NetWare')
162 if ($^O
eq 'VMS' && -e
$from) {
164 if (! -d
$to && ! -d
$from) {
166 my $vms_efs = _vms_efs
();
167 my $unix_rpt = _vms_unix_rpt
();
170 $from_unix = 1 if ($from =~ /^\.\.?$/);
172 $from_vms = 1 if ($from =~ m
#[\[<\]]#);
174 # Need to know if we are in Unix mode.
175 if ($from_vms == $from_unix) {
176 $unix_mode = $unix_rpt;
178 $unix_mode = $from_unix;
181 # VMS has sticky defaults on extensions, which means that
182 # if there is a null extension on the destination file, it
183 # will inherit the extension of the source file
184 # So add a '.' for a null extension.
186 # In unix_rpt mode, the trailing dot should not be added.
191 $copy_to = VMS
::Filespec
::vmsify
($to);
193 my ($vol, $dirs, $file) = File
::Spec
->splitpath($copy_to);
195 unless (($file =~ /(?<!\^)\./) || $unix_rpt);
196 $copy_to = File
::Spec
->catpath($vol, $dirs, $file);
198 # Get rid of the old versions to be like UNIX
199 1 while unlink $copy_to;
203 return syscopy
($from, $copy_to) || 0;
208 my ($status, $r, $buf);
212 if ($from_a_handle) {
215 open $from_h, "<", $from or goto fail_open1
;
216 binmode $from_h or die "($!,$^E)";
220 # Seems most logical to do this here, in case future changes would want to
221 # make this croak for some reason.
222 unless (defined $size) {
223 $size = tied(*$from_h) ?
0 : -s
$from_h || 0;
224 $size = 1024 if ($size < 512);
225 $size = $Too_Big if ($size > $Too_Big);
232 $to_h = \
do { local *FH
}; # XXX is this line obsolete?
233 open $to_h, ">", $to or goto fail_open2
;
234 binmode $to_h or die "($!,$^E)";
241 defined($r = sysread($from_h, $buf, $size))
244 for ($w = 0; $w < $r; $w += $t) {
245 $t = syswrite($to_h, $buf, $r - $w, $w)
250 close($to_h) || goto fail_open2
if $closeto;
251 close($from_h) || goto fail_open1
if $closefrom;
253 # Use this idiom to avoid uninitialized value warning.
256 # All of these contortions try to preserve error messages...
262 $! = $status unless $!;
269 $! = $status unless $!;
277 my(@fromstat) = stat $from;
278 my(@tostat) = stat $to;
281 return 0 unless copy
(@_) and @fromstat;
286 $perm = $fromstat[2] & ~(umask || 0);
289 # Might be more robust to look for S_I* in Fcntl, but we're
290 # trying to avoid dependence on any XS-containing modules,
291 # since File::Copy is used during the Perl build.
294 croak
("Unable to check setuid/setgid permissions for $to: $!")
297 if ($perm & 04000 and # setuid
298 $fromstat[4] != $tostat[4]) { # owner must match
302 if ($perm & 02000 && $> != 0) { # if not root, setgid
303 my $ok = $fromstat[5] == $tostat[5]; # group must match
304 if ($ok) { # and we must be in group
305 $ok = grep { $_ == $fromstat[5] } split /\s+/, $)
307 $perm &= ~06000 unless $ok;
310 return 0 unless @tostat;
311 return 1 if $perm == ($tostat[2] & 07777);
312 return eval { chmod $perm, $to; } ?
1 : 0;
316 croak
("Usage: move(FROM, TO) ") unless @_ == 3;
318 my($from,$to,$fallback) = @_;
320 my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
322 if (-d
$to && ! -d
$from) {
323 $to = _catname
($from, $to);
326 ($tosz1,$tomt1) = (stat($to))[7,9];
328 if ($^O
eq 'os2' and defined $tosz1 and defined $fromsz) {
329 # will not rename with overwrite
334 if (-$^O
eq 'VMS' && -e
$from) {
336 if (! -d
$to && ! -d
$from) {
338 my $vms_efs = _vms_efs
();
339 my $unix_rpt = _vms_unix_rpt
();
342 $from_unix = 1 if ($from =~ /^\.\.?$/);
344 $from_vms = 1 if ($from =~ m
#[\[<\]]#);
346 # Need to know if we are in Unix mode.
347 if ($from_vms == $from_unix) {
348 $unix_mode = $unix_rpt;
350 $unix_mode = $from_unix;
353 # VMS has sticky defaults on extensions, which means that
354 # if there is a null extension on the destination file, it
355 # will inherit the extension of the source file
356 # So add a '.' for a null extension.
358 # In unix_rpt mode, the trailing dot should not be added.
363 $rename_to = VMS
::Filespec
::vmsify
($to);
365 my ($vol, $dirs, $file) = File
::Spec
->splitpath($rename_to);
367 unless (($file =~ /(?<!\^)\./) || $unix_rpt);
368 $rename_to = File
::Spec
->catpath($vol, $dirs, $file);
370 # Get rid of the old versions to be like UNIX
371 1 while unlink $rename_to;
375 return 1 if rename $from, $rename_to;
377 # Did rename return an error even though it succeeded, because $to
378 # is on a remote NFS file system, and NFS lost the server's ack?
379 return 1 if defined($fromsz) && !-e
$from && # $from disappeared
380 (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
381 ((!defined $tosz1) || # not before or
382 ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
383 $tosz2 == $fromsz; # it's all there
385 ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
391 $fallback->($from,$to) or die;
392 my($atime, $mtime) = (stat($from))[8,9];
393 utime($atime, $mtime, $to);
394 unlink($from) or die;
398 ($sts,$ossts) = ($! + 0, $^E
+ 0);
400 ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
401 unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
402 ($!,$^E
) = ($sts,$ossts);
406 sub move
{ _move
(@_,\
©
); }
407 sub mv
{ _move
(@_,\
&cp
); }
409 # &syscopy is an XSUB under OS/2
410 unless (defined &syscopy
) {
412 *syscopy
= \
&rmscopy
;
413 } elsif ($^O
eq 'mpeix') {
415 return 0 unless @_ == 2;
416 # Use the MPE cp program in order to
417 # preserve MPE file attributes.
418 return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
420 } elsif ($^O
eq 'MSWin32' && defined &DynaLoader
::boot_DynaLoader
) {
421 # Win32::CopyFile() fill only work if we can load Win32.xs
423 return 0 unless @_ == 2;
424 return Win32
::CopyFile
(@_, 1);
427 $Syscopy_is_copy = 1;
438 File::Copy - Copy files or filehandles
444 copy("file1","file2") or die "Copy failed: $!";
445 copy("Copy.pm",\*STDOUT);
446 move("/dev1/fileA","/dev2/fileB");
450 $n = FileHandle->new("/a/file","r");
455 The File::Copy module provides two basic functions, C<copy> and
456 C<move>, which are useful for getting the contents of a file from
457 one place to another.
464 The C<copy> function takes two
465 parameters: a file to copy from and a file to copy to. Either
466 argument may be a string, a FileHandle reference or a FileHandle
467 glob. Obviously, if the first argument is a filehandle of some
468 sort, it will be read from, and if it is a file I<name> it will
469 be opened for reading. Likewise, the second argument will be
470 written to (and created if need be). Trying to copy a file on top
471 of itself is a fatal error.
473 If the destination (second argument) already exists and is a directory,
474 and the source (first argument) is not a filehandle, then the source
475 file will be copied into the directory specified by the destination,
476 using the same base name as the source file. It's a failure to have a
477 filehandle as the source when the destination is a directory.
479 B<Note that passing in
480 files as handles instead of names may lead to loss of information
481 on some operating systems; it is recommended that you use file
482 names whenever possible.> Files are opened in binary mode where
483 applicable. To get a consistent behaviour when copying from a
484 filehandle to a file, use C<binmode> on the filehandle.
486 An optional third parameter can be used to specify the buffer
487 size used for copying. This is the number of bytes from the
488 first file, that will be held in memory at any given time, before
489 being written to the second file. The default buffer size depends
490 upon the file, but will generally be the whole file (up to 2MB), or
491 1k for filehandles that do not reference files (eg. sockets).
493 You may use the syntax C<use File::Copy "cp"> to get at the C<cp>
494 alias for this function. The syntax is I<exactly> the same. The
495 behavior is nearly the same as well: as of version 2.15, <cp> will
496 preserve the source file's permission bits like the shell utility
497 C<cp(1)> would do, while C<copy> uses the default permissions for the
498 target file (which may depend on the process' C<umask>, file
499 ownership, inherited ACLs, etc.). If an error occurs in setting
500 permissions, C<cp> will return 0, regardless of whether the file was
504 X<move> X<mv> X<rename>
506 The C<move> function also takes two parameters: the current name
507 and the intended name of the file to be moved. If the destination
508 already exists and is a directory, and the source is not a
509 directory, then the source file will be renamed into the directory
510 specified by the destination.
512 If possible, move() will simply rename the file. Otherwise, it copies
513 the file to the new location and deletes the original. If an error occurs
514 during this copy-and-delete process, you may be left with a (possibly partial)
515 copy of the file under the destination name.
517 You may use the C<mv> alias for this function in the same way that
518 you may use the <cp> alias for C<copy>.
523 File::Copy also provides the C<syscopy> routine, which copies the
524 file specified in the first parameter to the file specified in the
525 second parameter, preserving OS-specific attributes and file
526 structure. For Unix systems, this is equivalent to the simple
527 C<copy> routine, which doesn't preserve OS-specific attributes. For
528 VMS systems, this calls the C<rmscopy> routine (see below). For OS/2
529 systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
530 this calls C<Win32::CopyFile>.
532 B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
534 If both arguments to C<copy> are not file handles,
535 then C<copy> will perform a "system copy" of
536 the input file to a new output file, in order to preserve file
537 attributes, indexed file structure, I<etc.> The buffer size
538 parameter is ignored. If either argument to C<copy> is a
539 handle to an opened file, then data is copied using Perl
540 operators, and no effort is made to preserve file attributes
543 The system copy routine may also be called directly under VMS and OS/2
544 as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
545 is the routine that does the actual work for syscopy).
547 =item rmscopy($from,$to[,$date_flag])
550 The first and second arguments may be strings, typeglobs, typeglob
551 references, or objects inheriting from IO::Handle;
552 they are used in all cases to obtain the
553 I<filespec> of the input and output files, respectively. The
554 name and type of the input file are used as defaults for the
555 output file, if necessary.
557 A new version of the output file is always created, which
558 inherits the structure and RMS attributes of the input file,
559 except for owner and protections (and possibly timestamps;
560 see below). All data from the input file is copied to the
561 output file; if either of the first two parameters to C<rmscopy>
562 is a file handle, its position is unchanged. (Note that this
563 means a file handle pointing to the output file will be
564 associated with an old version of that file after C<rmscopy>
565 returns, not the newly created version.)
567 The third parameter is an integer flag, which tells C<rmscopy>
568 how to handle timestamps. If it is E<lt> 0, none of the input file's
569 timestamps are propagated to the output file. If it is E<gt> 0, then
570 it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
571 timestamps other than the revision date are propagated; if bit 1
572 is set, the revision date is propagated. If the third parameter
573 to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
574 if the name or type of the output file was explicitly specified,
575 then no timestamps are propagated, but if they were taken implicitly
576 from the input filespec, then all timestamps other than the
577 revision date are propagated. If this parameter is not supplied,
580 Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
581 it sets C<$!>, deletes the output file, and returns 0.
587 All functions return 1 on success, 0 on failure.
588 $! will be set if an error was encountered.
592 File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
593 and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.