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