Remove MacOS classic support from File::{Copy,DosGlob,Find,Glob,stat}.
[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 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.19';
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         # The "copy" was a success as the source and destination contain
132         # the same data.
133         return 1;
134     }
135
136     if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
137         !($^O eq 'MSWin32' || $^O eq 'os2')) {
138         my @fs = stat($from);
139         if (@fs) {
140             my @ts = stat($to);
141             if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p $from) {
142                 carp("'$from' and '$to' are identical (not copied)");
143                 return 0;
144             }
145         }
146     }
147
148     if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
149         $to = _catname($from, $to);
150     }
151
152     if (defined &syscopy && !$Syscopy_is_copy
153         && !$to_a_handle
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')
158        )
159     {
160         my $copy_to = $to;
161
162         if ($^O eq 'VMS' && -e $from) {
163
164             if (! -d $to && ! -d $from) {
165
166                 my $vms_efs = _vms_efs();
167                 my $unix_rpt = _vms_unix_rpt();
168                 my $unix_mode = 0;
169                 my $from_unix = 0;
170                 $from_unix = 1 if ($from =~ /^\.\.?$/);
171                 my $from_vms = 0;
172                 $from_vms = 1 if ($from =~ m#[\[<\]]#);
173
174                 # Need to know if we are in Unix mode.
175                 if ($from_vms == $from_unix) {
176                     $unix_mode = $unix_rpt;
177                 } else {
178                     $unix_mode = $from_unix;
179                 }
180
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.
185
186                 # In unix_rpt mode, the trailing dot should not be added.
187
188                 if ($vms_efs) {
189                     $copy_to = $to;
190                 } else {
191                     $copy_to = VMS::Filespec::vmsify($to);
192                 }
193                 my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
194                 $file = $file . '.'
195                     unless (($file =~ /(?<!\^)\./) || $unix_rpt);
196                 $copy_to = File::Spec->catpath($vol, $dirs, $file);
197
198                 # Get rid of the old versions to be like UNIX
199                 1 while unlink $copy_to;
200             }
201         }
202
203         return syscopy($from, $copy_to) || 0;
204     }
205
206     my $closefrom = 0;
207     my $closeto = 0;
208     my ($status, $r, $buf);
209     local($\) = '';
210
211     my $from_h;
212     if ($from_a_handle) {
213        $from_h = $from;
214     } else {
215        open $from_h, "<", $from or goto fail_open1;
216        binmode $from_h or die "($!,$^E)";
217        $closefrom = 1;
218     }
219
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);
226     }
227
228     my $to_h;
229     if ($to_a_handle) {
230        $to_h = $to;
231     } else {
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)";
235         $closeto = 1;
236     }
237
238     $! = 0;
239     for (;;) {
240         my ($r, $w, $t);
241        defined($r = sysread($from_h, $buf, $size))
242             or goto fail_inner;
243         last unless $r;
244         for ($w = 0; $w < $r; $w += $t) {
245            $t = syswrite($to_h, $buf, $r - $w, $w)
246                 or goto fail_inner;
247         }
248     }
249
250     close($to_h) || goto fail_open2 if $closeto;
251     close($from_h) || goto fail_open1 if $closefrom;
252
253     # Use this idiom to avoid uninitialized value warning.
254     return 1;
255
256     # All of these contortions try to preserve error messages...
257   fail_inner:
258     if ($closeto) {
259         $status = $!;
260         $! = 0;
261        close $to_h;
262         $! = $status unless $!;
263     }
264   fail_open2:
265     if ($closefrom) {
266         $status = $!;
267         $! = 0;
268        close $from_h;
269         $! = $status unless $!;
270     }
271   fail_open1:
272     return 0;
273 }
274
275 sub cp {
276     my($from,$to) = @_;
277     my(@fromstat) = stat $from;
278     my(@tostat) = stat $to;
279     my $perm;
280
281     return 0 unless copy(@_) and @fromstat;
282
283     if (@tostat) {
284         $perm = $tostat[2];
285     } else {
286         $perm = $fromstat[2] & ~(umask || 0);
287         @tostat = stat $to;
288     }
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.
292     $perm &= 07777;
293     if ($perm & 06000) {
294         croak("Unable to check setuid/setgid permissions for $to: $!")
295             unless @tostat;
296
297         if ($perm & 04000 and                     # setuid
298             $fromstat[4] != $tostat[4]) {         # owner must match
299             $perm &= ~06000;
300         }
301
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+/, $)
306             }
307             $perm &= ~06000 unless $ok;
308         }
309     }
310     return 0 unless @tostat;
311     return 1 if $perm == ($tostat[2] & 07777);
312     return eval { chmod $perm, $to; } ? 1 : 0;
313 }
314
315 sub _move {
316     croak("Usage: move(FROM, TO) ") unless @_ == 3;
317
318     my($from,$to,$fallback) = @_;
319
320     my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
321
322     if (-d $to && ! -d $from) {
323         $to = _catname($from, $to);
324     }
325
326     ($tosz1,$tomt1) = (stat($to))[7,9];
327     $fromsz = -s $from;
328     if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
329       # will not rename with overwrite
330       unlink $to;
331     }
332
333     my $rename_to = $to;
334     if (-$^O eq 'VMS' && -e $from) {
335
336         if (! -d $to && ! -d $from) {
337
338             my $vms_efs = _vms_efs();
339             my $unix_rpt = _vms_unix_rpt();
340             my $unix_mode = 0;
341             my $from_unix = 0;
342             $from_unix = 1 if ($from =~ /^\.\.?$/);
343             my $from_vms = 0;
344             $from_vms = 1 if ($from =~ m#[\[<\]]#);
345
346             # Need to know if we are in Unix mode.
347             if ($from_vms == $from_unix) {
348                 $unix_mode = $unix_rpt;
349             } else {
350                 $unix_mode = $from_unix;
351             }
352
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.
357
358             # In unix_rpt mode, the trailing dot should not be added.
359
360             if ($vms_efs) {
361                 $rename_to = $to;
362             } else {
363                 $rename_to = VMS::Filespec::vmsify($to);
364             }
365             my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
366             $file = $file . '.'
367                 unless (($file =~ /(?<!\^)\./) || $unix_rpt);
368             $rename_to = File::Spec->catpath($vol, $dirs, $file);
369
370             # Get rid of the old versions to be like UNIX
371             1 while unlink $rename_to;
372         }
373     }
374
375     return 1 if rename $from, $rename_to;
376
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
384
385     ($tosz1,$tomt1) = (stat($to))[7,9];  # just in case rename did something
386
387     {
388         local $@;
389         eval {
390             local $SIG{__DIE__};
391             $fallback->($from,$to) or die;
392             my($atime, $mtime) = (stat($from))[8,9];
393             utime($atime, $mtime, $to);
394             unlink($from)   or die;
395         };
396         return 1 unless $@;
397     }
398     ($sts,$ossts) = ($! + 0, $^E + 0);
399
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);
403     return 0;
404 }
405
406 sub move { _move(@_,\&copy); }
407 sub mv   { _move(@_,\&cp);   }
408
409 # &syscopy is an XSUB under OS/2
410 unless (defined &syscopy) {
411     if ($^O eq 'VMS') {
412         *syscopy = \&rmscopy;
413     } elsif ($^O eq 'mpeix') {
414         *syscopy = sub {
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;
419         };
420     } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
421         # Win32::CopyFile() fill only work if we can load Win32.xs
422         *syscopy = sub {
423             return 0 unless @_ == 2;
424             return Win32::CopyFile(@_, 1);
425         };
426     } else {
427         $Syscopy_is_copy = 1;
428         *syscopy = \&copy;
429     }
430 }
431
432 1;
433
434 __END__
435
436 =head1 NAME
437
438 File::Copy - Copy files or filehandles
439
440 =head1 SYNOPSIS
441
442         use File::Copy;
443
444         copy("file1","file2") or die "Copy failed: $!";
445         copy("Copy.pm",\*STDOUT);
446         move("/dev1/fileA","/dev2/fileB");
447
448         use File::Copy "cp";
449
450         $n = FileHandle->new("/a/file","r");
451         cp($n,"x");
452
453 =head1 DESCRIPTION
454
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.
458
459 =over 4
460
461 =item copy
462 X<copy> X<cp>
463
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.
472
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.
478
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.
485
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).
492
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
501 successfully copied.
502
503 =item move
504 X<move> X<mv> X<rename>
505
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.
511
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.
516
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>.
519
520 =item syscopy
521 X<syscopy>
522
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>.
531
532 On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
533 if available.
534
535 B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
536
537 If both arguments to C<copy> are not file handles,
538 then C<copy> will perform a "system copy" of
539 the input file to a new output file, in order to preserve file
540 attributes, indexed file structure, I<etc.>  The buffer size
541 parameter is ignored.  If either argument to C<copy> is a
542 handle to an opened file, then data is copied using Perl
543 operators, and no effort is made to preserve file attributes
544 or record structure.
545
546 The system copy routine may also be called directly under VMS and OS/2
547 as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
548 is the routine that does the actual work for syscopy).
549
550 =item rmscopy($from,$to[,$date_flag])
551 X<rmscopy>
552
553 The first and second arguments may be strings, typeglobs, typeglob
554 references, or objects inheriting from IO::Handle;
555 they are used in all cases to obtain the
556 I<filespec> of the input and output files, respectively.  The
557 name and type of the input file are used as defaults for the
558 output file, if necessary.
559
560 A new version of the output file is always created, which
561 inherits the structure and RMS attributes of the input file,
562 except for owner and protections (and possibly timestamps;
563 see below).  All data from the input file is copied to the
564 output file; if either of the first two parameters to C<rmscopy>
565 is a file handle, its position is unchanged.  (Note that this
566 means a file handle pointing to the output file will be
567 associated with an old version of that file after C<rmscopy>
568 returns, not the newly created version.)
569
570 The third parameter is an integer flag, which tells C<rmscopy>
571 how to handle timestamps.  If it is E<lt> 0, none of the input file's
572 timestamps are propagated to the output file.  If it is E<gt> 0, then
573 it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
574 timestamps other than the revision date are propagated; if bit 1
575 is set, the revision date is propagated.  If the third parameter
576 to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
577 if the name or type of the output file was explicitly specified,
578 then no timestamps are propagated, but if they were taken implicitly
579 from the input filespec, then all timestamps other than the
580 revision date are propagated.  If this parameter is not supplied,
581 it defaults to 0.
582
583 Like C<copy>, C<rmscopy> returns 1 on success.  If an error occurs,
584 it sets C<$!>, deletes the output file, and returns 0.
585
586 =back
587
588 =head1 RETURN
589
590 All functions return 1 on success, 0 on failure.
591 $! will be set if an error was encountered.
592
593 =head1 NOTES
594
595 =over 4
596
597 =item *
598
599 On Mac OS (Classic), the path separator is ':', not '/', and the 
600 current directory is denoted as ':', not '.'. You should be careful 
601 about specifying relative pathnames. While a full path always begins 
602 with a volume name, a relative pathname should always begin with a 
603 ':'.  If specifying a volume name only, a trailing ':' is required.
604
605 E.g.
606
607   copy("file1", "tmp");        # creates the file 'tmp' in the current directory
608   copy("file1", ":tmp:");      # creates :tmp:file1
609   copy("file1", ":tmp");       # same as above
610   copy("file1", "tmp");        # same as above, if 'tmp' is a directory (but don't do
611                                # that, since it may cause confusion, see example #1)
612   copy("file1", "tmp:file1");  # error, since 'tmp:' is not a volume
613   copy("file1", ":tmp:file1"); # ok, partial path
614   copy("file1", "DataHD:");    # creates DataHD:file1
615
616   move("MacintoshHD:fileA", "DataHD:fileB"); # moves (doesn't copy) files from one
617                                              # volume to another
618
619 =back
620
621 =head1 AUTHOR
622
623 File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
624 and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
625
626 =cut
627