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.005_64;
  11 use strict;
  12 use Carp;
  13 our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
  14 sub copy;
  15 sub syscopy;
  16 sub cp;
  17 sub mv;
  18
  19 # Note that this module implements only *part* of the API defined by
  20 # the File/Copy.pm module of the File-Tools-2.0 package.  However, that
  21 # package has not yet been updated to work with Perl 5.004, and so it
  22 # would be a Bad Thing for the CPAN module to grab it and replace this
  23 # module.  Therefore, we set this module's version higher than 2.0.
  24 $VERSION = '2.03';
  25
  26 require Exporter;
  27 @ISA = qw(Exporter);
  28 @EXPORT = qw(copy move);
  29 @EXPORT_OK = qw(cp mv);
  30
  31 $Too_Big = 1024 * 1024 * 2;
  32
  33 sub _catname { #  Will be replaced by File::Spec when it arrives
  34     my($from, $to) = @_;
  35     if (not defined &basename) {
  36         require File::Basename;
  37         import  File::Basename 'basename';
  38     }
  39     if ($^O eq 'VMS')  { $to = VMS::Filespec::vmspath($to) . basename($from); }
  40     elsif ($^O eq 'MacOS') { $to .= ':' . basename($from); }
  41     elsif ($to =~ m|\\|)   { $to .= '\\' . basename($from); }
  42     else                   { $to .= '/' . basename($from); }
  43 }
  44
  45 sub copy {
  46     croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
  47       unless(@_ == 2 || @_ == 3);
  48
  49     my $from = shift;
  50     my $to = shift;
  51
  52     my $from_a_handle = (ref($from)
  53                          ? (ref($from) eq 'GLOB'
  54                             || UNIVERSAL::isa($from, 'GLOB')
  55                             || UNIVERSAL::isa($from, 'IO::Handle'))
  56                          : (ref(\$from) eq 'GLOB'));
  57     my $to_a_handle =   (ref($to)
  58                          ? (ref($to) eq 'GLOB'
  59                             || UNIVERSAL::isa($to, 'GLOB')
  60                             || UNIVERSAL::isa($to, 'IO::Handle'))
  61                          : (ref(\$to) eq 'GLOB'));
  62
  63     if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
  64         $to = _catname($from, $to);
  65     }
  66
  67     if (defined &syscopy && !$Syscopy_is_copy
  68         && !$to_a_handle
  69         && !($from_a_handle && $^O eq 'os2' )   # OS/2 cannot handle handles
  70         && !($from_a_handle && $^O eq 'mpeix')  # and neither can MPE/iX.
  71         && !($from_a_handle && $^O eq 'MSWin32')
  72        )
  73     {
  74         return syscopy($from, $to);
  75     }
  76
  77     my $closefrom = 0;
  78     my $closeto = 0;
  79     my ($size, $status, $r, $buf);
  80     local(*FROM, *TO);
  81     local($\) = '';
  82
  83     if ($from_a_handle) {
  84         *FROM = *$from{FILEHANDLE};
  85     } else {
  86         $from = "./$from" if $from =~ /^\s/s;
  87         open(FROM, "< $from\0") or goto fail_open1;
  88         binmode FROM or die "($!,$^E)";
  89         $closefrom = 1;
  90     }
  91
  92     if ($to_a_handle) {
  93         *TO = *$to{FILEHANDLE};
  94     } else {
  95         $to = "./$to" if $to =~ /^\s/s;
  96         open(TO,"> $to\0") or goto fail_open2;
  97         binmode TO or die "($!,$^E)";
  98         $closeto = 1;
  99     }
 100
 101     if (@_) {
 102         $size = shift(@_) + 0;
 103         croak("Bad buffer size for copy: $size\n") unless ($size > 0);
 104     } else {
 105         $size = -s FROM;
 106         $size = 1024 if ($size < 512);
 107         $size = $Too_Big if ($size > $Too_Big);
 108     }
 109
 110     $! = 0;
 111     for (;;) {
 112         my ($r, $w, $t);
 113         defined($r = sysread(FROM, $buf, $size))
 114             or goto fail_inner;
 115         last unless $r;
 116         for ($w = 0; $w < $r; $w += $t) {
 117             $t = syswrite(TO, $buf, $r - $w, $w)
 118                 or goto fail_inner;
 119         }
 120     }
 121
 122     close(TO) || goto fail_open2 if $closeto;
 123     close(FROM) || goto fail_open1 if $closefrom;
 124
 125     # Use this idiom to avoid uninitialized value warning.
 126     return 1;
 127
 128     # All of these contortions try to preserve error messages...
 129   fail_inner:
 130     if ($closeto) {
 131         $status = $!;
 132         $! = 0;
 133         close TO;
 134         $! = $status unless $!;
 135     }
 136   fail_open2:
 137     if ($closefrom) {
 138         $status = $!;
 139         $! = 0;
 140         close FROM;
 141         $! = $status unless $!;
 142     }
 143   fail_open1:
 144     return 0;
 145 }
 146
 147 sub move {
 148     my($from,$to) = @_;
 149     my($copied,$fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
 150
 151     if (-d $to && ! -d $from) {
 152         $to = _catname($from, $to);
 153     }
 154
 155     ($tosz1,$tomt1) = (stat($to))[7,9];
 156     $fromsz = -s $from;
 157     if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
 158       # will not rename with overwrite
 159       unlink $to;
 160     }
 161     return 1 if rename $from, $to;
 162
 163     ($sts,$ossts) = ($! + 0, $^E + 0);
 164     # Did rename return an error even though it succeeded, because $to
 165     # is on a remote NFS file system, and NFS lost the server's ack?
 166     return 1 if defined($fromsz) && !-e $from &&           # $from disappeared
 167                 (($tosz2,$tomt2) = (stat($to))[7,9]) &&    # $to's there
 168                 ($tosz1 != $tosz2 or $tomt1 != $tomt2) &&  #   and changed
 169                 $tosz2 == $fromsz;                         # it's all there
 170
 171     ($tosz1,$tomt1) = (stat($to))[7,9];  # just in case rename did something
 172     return 1 if ($copied = copy($from,$to)) && unlink($from);
 173
 174     ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
 175     unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
 176     ($!,$^E) = ($sts,$ossts);
 177     return 0;
 178 }
 179
 180 *cp = \&copy;
 181 *mv = \&move;
 182
 183 # &syscopy is an XSUB under OS/2
 184 unless (defined &syscopy) {
 185     if ($^O eq 'VMS') {
 186         *syscopy = \&rmscopy;
 187     } elsif ($^O eq 'mpeix') {
 188         *syscopy = sub {
 189             return 0 unless @_ == 2;
 190             # Use the MPE cp program in order to
 191             # preserve MPE file attributes.
 192             return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
 193         };
 194     } elsif ($^O eq 'MSWin32') {
 195         *syscopy = sub {
 196             return 0 unless @_ == 2;
 197             return Win32::CopyFile(@_, 1);
 198         };
 199     } else {
 200         $Syscopy_is_copy = 1;
 201         *syscopy = \&copy;
 202     }
 203 }
 204
 205 1;
 206
 207 __END__
 208
 209 =head1 NAME
 210
 211 File::Copy - Copy files or filehandles
 212
 213 =head1 SYNOPSIS
 214
 215         use File::Copy;
 216
 217         copy("file1","file2");
 218         copy("Copy.pm",\*STDOUT);'
 219         move("/dev1/fileA","/dev2/fileB");
 220
 221         use POSIX;
 222         use File::Copy cp;
 223
 224         $n = FileHandle->new("/a/file","r");
 225         cp($n,"x");'
 226
 227 =head1 DESCRIPTION
 228
 229 The File::Copy module provides two basic functions, C<copy> and
 230 C<move>, which are useful for getting the contents of a file from
 231 one place to another.
 232
 233 =over 4
 234
 235 =item *
 236
 237 The C<copy> function takes two
 238 parameters: a file to copy from and a file to copy to. Either
 239 argument may be a string, a FileHandle reference or a FileHandle
 240 glob. Obviously, if the first argument is a filehandle of some
 241 sort, it will be read from, and if it is a file I<name> it will
 242 be opened for reading. Likewise, the second argument will be
 243 written to (and created if need be).
 244
 245 B<Note that passing in
 246 files as handles instead of names may lead to loss of information
 247 on some operating systems; it is recommended that you use file
 248 names whenever possible.>  Files are opened in binary mode where
 249 applicable.  To get a consistent behaviour when copying from a
 250 filehandle to a file, use C<binmode> on the filehandle.
 251
 252 An optional third parameter can be used to specify the buffer
 253 size used for copying. This is the number of bytes from the
 254 first file, that wil be held in memory at any given time, before
 255 being written to the second file. The default buffer size depends
 256 upon the file, but will generally be the whole file (up to 2Mb), or
 257 1k for filehandles that do not reference files (eg. sockets).
 258
 259 You may use the syntax C<use File::Copy "cp"> to get at the
 260 "cp" alias for this function. The syntax is I<exactly> the same.
 261
 262 =item *
 263
 264 The C<move> function also takes two parameters: the current name
 265 and the intended name of the file to be moved.  If the destination
 266 already exists and is a directory, and the source is not a
 267 directory, then the source file will be renamed into the directory
 268 specified by the destination.
 269
 270 If possible, move() will simply rename the file.  Otherwise, it copies
 271 the file to the new location and deletes the original.  If an error occurs
 272 during this copy-and-delete process, you may be left with a (possibly partial)
 273 copy of the file under the destination name.
 274
 275 You may use the "mv" alias for this function in the same way that
 276 you may use the "cp" alias for C<copy>.
 277
 278 =back
 279
 280 File::Copy also provides the C<syscopy> routine, which copies the
 281 file specified in the first parameter to the file specified in the
 282 second parameter, preserving OS-specific attributes and file
 283 structure.  For Unix systems, this is equivalent to the simple
 284 C<copy> routine.  For VMS systems, this calls the C<rmscopy>
 285 routine (see below).  For OS/2 systems, this calls the C<syscopy>
 286 XSUB directly. For Win32 systems, this calls C<Win32::CopyFile>.
 287
 288 =head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)
 289
 290 If both arguments to C<copy> are not file handles,
 291 then C<copy> will perform a "system copy" of
 292 the input file to a new output file, in order to preserve file
 293 attributes, indexed file structure, I<etc.>  The buffer size
 294 parameter is ignored.  If either argument to C<copy> is a
 295 handle to an opened file, then data is copied using Perl
 296 operators, and no effort is made to preserve file attributes
 297 or record structure.
 298
 299 The system copy routine may also be called directly under VMS and OS/2
 300 as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
 301 is the routine that does the actual work for syscopy).
 302
 303 =over 4
 304
 305 =item rmscopy($from,$to[,$date_flag])
 306
 307 The first and second arguments may be strings, typeglobs, typeglob
 308 references, or objects inheriting from IO::Handle;
 309 they are used in all cases to obtain the
 310 I<filespec> of the input and output files, respectively.  The
 311 name and type of the input file are used as defaults for the
 312 output file, if necessary.
 313
 314 A new version of the output file is always created, which
 315 inherits the structure and RMS attributes of the input file,
 316 except for owner and protections (and possibly timestamps;
 317 see below).  All data from the input file is copied to the
 318 output file; if either of the first two parameters to C<rmscopy>
 319 is a file handle, its position is unchanged.  (Note that this
 320 means a file handle pointing to the output file will be
 321 associated with an old version of that file after C<rmscopy>
 322 returns, not the newly created version.)
 323
 324 The third parameter is an integer flag, which tells C<rmscopy>
 325 how to handle timestamps.  If it is E<lt> 0, none of the input file's
 326 timestamps are propagated to the output file.  If it is E<gt> 0, then
 327 it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
 328 timestamps other than the revision date are propagated; if bit 1
 329 is set, the revision date is propagated.  If the third parameter
 330 to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
 331 if the name or type of the output file was explicitly specified,
 332 then no timestamps are propagated, but if they were taken implicitly
 333 from the input filespec, then all timestamps other than the
 334 revision date are propagated.  If this parameter is not supplied,
 335 it defaults to 0.
 336
 337 Like C<copy>, C<rmscopy> returns 1 on success.  If an error occurs,
 338 it sets C<$!>, deletes the output file, and returns 0.
 339
 340 =back
 341
 342 =head1 RETURN
 343
 344 All functions return 1 on success, 0 on failure.
 345 $! will be set if an error was encountered.
 346
 347 =head1 AUTHOR
 348
 349 File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
 350 and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
 351
 352 =cut
 353