← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:28 2010

File/opt/wise/lib/perl5/5.10.0/File/Copy.pm
Statements Executed33
Total Time0.00259 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
00000File::Copy::BEGIN
00000File::Copy::__ANON__[:295]
00000File::Copy::__ANON__[:297]
00000File::Copy::__ANON__[:310]
00000File::Copy::__ANON__[:316]
00000File::Copy::__ANON__[:332]
00000File::Copy::_catname
00000File::Copy::_eq
00000File::Copy::carp
00000File::Copy::copy
00000File::Copy::croak
00000File::Copy::move

LineStmts.Exclusive
Time
Avg.Code
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
8package File::Copy;
9
1036.0e-52.0e-5use 5.006;
1132.6e-58.7e-6use strict;
# spent 8µs making 1 call to strict::import
1232.7e-59.0e-6use warnings;
# spent 19µs making 1 call to warnings::import
1332.8e-59.3e-6use File::Spec;
# spent 4µs making 1 call to import
1430.002390.00080use Config;
# spent 28µs making 1 call to Config::import
1511.0e-61.0e-6our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
16sub copy;
17sub syscopy;
18sub cp;
19sub mv;
20
21# Note that this module implements only *part* of the API defined by
22# the File/Copy.pm module of the File-Tools-2.0 package. However, that
23# package has not yet been updated to work with Perl 5.004, and so it
24# would be a Bad Thing for the CPAN module to grab it and replace this
25# module. Therefore, we set this module's version higher than 2.0.
2611.0e-61.0e-6$VERSION = '2.11';
27
2811.0e-61.0e-6require Exporter;
2918.0e-68.0e-6@ISA = qw(Exporter);
3011.0e-61.0e-6@EXPORT = qw(copy move);
3111.0e-61.0e-6@EXPORT_OK = qw(cp mv);
32
33100$Too_Big = 1024 * 1024 * 2;
34
35sub croak {
36 require Carp;
37 goto &Carp::croak;
38}
39
40sub carp {
41 require Carp;
42 goto &Carp::carp;
43}
44
4511.0e-61.0e-6my $macfiles;
4611.0e-61.0e-6if ($^O eq 'MacOS') {
47 $macfiles = eval { require Mac::MoreFiles };
48 warn 'Mac::MoreFiles could not be loaded; using non-native syscopy'
49 if $@ && $^W;
50}
51
52sub _catname {
53 my($from, $to) = @_;
54 if (not defined &basename) {
55 require File::Basename;
56 import File::Basename 'basename';
57 }
58
59 if ($^O eq 'MacOS') {
60 # a partial dir name that's valid only in the cwd (e.g. 'tmp')
61 $to = ':' . $to if $to !~ /:/;
62 }
63
64 return File::Spec->catfile($to, basename($from));
65}
66
67# _eq($from, $to) tells whether $from and $to are identical
68# works for strings and references
69sub _eq {
70 return $_[0] == $_[1] if ref $_[0] && ref $_[1];
71 return $_[0] eq $_[1] if !ref $_[0] && !ref $_[1];
72 return "";
73}
74
75sub copy {
76 croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
77 unless(@_ == 2 || @_ == 3);
78
79 my $from = shift;
80 my $to = shift;
81
82 my $from_a_handle = (ref($from)
83 ? (ref($from) eq 'GLOB'
84 || UNIVERSAL::isa($from, 'GLOB')
85 || UNIVERSAL::isa($from, 'IO::Handle'))
86 : (ref(\$from) eq 'GLOB'));
87 my $to_a_handle = (ref($to)
88 ? (ref($to) eq 'GLOB'
89 || UNIVERSAL::isa($to, 'GLOB')
90 || UNIVERSAL::isa($to, 'IO::Handle'))
91 : (ref(\$to) eq 'GLOB'));
92
93 if (_eq($from, $to)) { # works for references, too
94 carp("'$from' and '$to' are identical (not copied)");
95 # The "copy" was a success as the source and destination contain
96 # the same data.
97 return 1;
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]) {
106 carp("'$from' and '$to' are identical (not copied)");
107 return 0;
108 }
109 }
110 }
111
112 if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
113 $to = _catname($from, $to);
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 'mpeix') # and neither can MPE/iX.
120 && !($from_a_handle && $^O eq 'MSWin32')
121 && !($from_a_handle && $^O eq 'MacOS')
122 && !($from_a_handle && $^O eq 'NetWare')
123 )
124 {
125 my $copy_to = $to;
126
127 if ($^O eq 'VMS' && -e $from) {
128
129 if (! -d $to && ! -d $from) {
130
131 # VMS has sticky defaults on extensions, which means that
132 # if there is a null extension on the destination file, it
133 # will inherit the extension of the source file
134 # So add a '.' for a null extension.
135
136 $copy_to = VMS::Filespec::vmsify($to);
137 my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
138 $file = $file . '.' unless ($file =~ /(?<!\^)\./);
139 $copy_to = File::Spec->catpath($vol, $dirs, $file);
140
141 # Get rid of the old versions to be like UNIX
142 1 while unlink $copy_to;
143 }
144 }
145
146 return syscopy($from, $copy_to);
147 }
148
149 my $closefrom = 0;
150 my $closeto = 0;
151 my ($size, $status, $r, $buf);
152 local($\) = '';
153
154 my $from_h;
155 if ($from_a_handle) {
156 $from_h = $from;
157 } else {
158 $from = _protect($from) if $from =~ /^\s/s;
159 $from_h = \do { local *FH };
160 open($from_h, "< $from\0") or goto fail_open1;
161 binmode $from_h or die "($!,$^E)";
162 $closefrom = 1;
163 }
164
165 my $to_h;
166 if ($to_a_handle) {
167 $to_h = $to;
168 } else {
169 $to = _protect($to) if $to =~ /^\s/s;
170 $to_h = \do { local *FH };
171 open($to_h,"> $to\0") or goto fail_open2;
172 binmode $to_h or die "($!,$^E)";
173 $closeto = 1;
174 }
175
176 if (@_) {
177 $size = shift(@_) + 0;
178 croak("Bad buffer size for copy: $size\n") unless ($size > 0);
179 } else {
180 $size = tied(*$from_h) ? 0 : -s $from_h || 0;
181 $size = 1024 if ($size < 512);
182 $size = $Too_Big if ($size > $Too_Big);
183 }
184
185 $! = 0;
186 for (;;) {
187 my ($r, $w, $t);
188 defined($r = sysread($from_h, $buf, $size))
189 or goto fail_inner;
190 last unless $r;
191 for ($w = 0; $w < $r; $w += $t) {
192 $t = syswrite($to_h, $buf, $r - $w, $w)
193 or goto fail_inner;
194 }
195 }
196
197 close($to_h) || goto fail_open2 if $closeto;
198 close($from_h) || goto fail_open1 if $closefrom;
199
200 # Use this idiom to avoid uninitialized value warning.
201 return 1;
202
203 # All of these contortions try to preserve error messages...
204 fail_inner:
205 if ($closeto) {
206 $status = $!;
207 $! = 0;
208 close $to_h;
209 $! = $status unless $!;
210 }
211 fail_open2:
212 if ($closefrom) {
213 $status = $!;
214 $! = 0;
215 close $from_h;
216 $! = $status unless $!;
217 }
218 fail_open1:
219 return 0;
220}
221
222sub move {
223 croak("Usage: move(FROM, TO) ") unless @_ == 2;
224
225 my($from,$to) = @_;
226
227 my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
228
229 if (-d $to && ! -d $from) {
230 $to = _catname($from, $to);
231 }
232
233 ($tosz1,$tomt1) = (stat($to))[7,9];
234 $fromsz = -s $from;
235 if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
236 # will not rename with overwrite
237 unlink $to;
238 }
239
240 my $rename_to = $to;
241 if (-$^O eq 'VMS' && -e $from) {
242
243 if (! -d $to && ! -d $from) {
244 # VMS has sticky defaults on extensions, which means that
245 # if there is a null extension on the destination file, it
246 # will inherit the extension of the source file
247 # So add a '.' for a null extension.
248
249 $rename_to = VMS::Filespec::vmsify($to);
250 my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
251 $file = $file . '.' unless ($file =~ /(?<!\^)\./);
252 $rename_to = File::Spec->catpath($vol, $dirs, $file);
253
254 # Get rid of the old versions to be like UNIX
255 1 while unlink $rename_to;
256 }
257 }
258
259 return 1 if rename $from, $rename_to;
260
261 # Did rename return an error even though it succeeded, because $to
262 # is on a remote NFS file system, and NFS lost the server's ack?
263 return 1 if defined($fromsz) && !-e $from && # $from disappeared
264 (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
265 ((!defined $tosz1) || # not before or
266 ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
267 $tosz2 == $fromsz; # it's all there
268
269 ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
270
271 {
272 local $@;
273 eval {
274 local $SIG{__DIE__};
275 copy($from,$to) or die;
276 my($atime, $mtime) = (stat($from))[8,9];
277 utime($atime, $mtime, $to);
278 unlink($from) or die;
279 };
280 return 1 unless $@;
281 }
282 ($sts,$ossts) = ($! + 0, $^E + 0);
283
284 ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
285 unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
286 ($!,$^E) = ($sts,$ossts);
287 return 0;
288}
289
29013.0e-63.0e-6*cp = \&copy;
29112.0e-62.0e-6*mv = \&move;
292
293
29411.0e-61.0e-6if ($^O eq 'MacOS') {
295 *_protect = sub { MacPerl::MakeFSSpec($_[0]) };
296} else {
29714.0e-64.0e-6 *_protect = sub { "./$_[0]" };
298}
299
300# &syscopy is an XSUB under OS/2
30112.0e-62.0e-6unless (defined &syscopy) {
30211.0e-61.0e-6 if ($^O eq 'VMS') {
303 *syscopy = \&rmscopy;
304 } elsif ($^O eq 'mpeix') {
305 *syscopy = sub {
306 return 0 unless @_ == 2;
307 # Use the MPE cp program in order to
308 # preserve MPE file attributes.
309 return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
310 };
311 } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
312 # Win32::CopyFile() fill only work if we can load Win32.xs
313 *syscopy = sub {
314 return 0 unless @_ == 2;
315 return Win32::CopyFile(@_, 1);
316 };
317 } elsif ($macfiles) {
318 *syscopy = sub {
319 my($from, $to) = @_;
320 my($dir, $toname);
321
322 return 0 unless -e $from;
323
324 if ($to =~ /(.*:)([^:]+):?$/) {
325 ($dir, $toname) = ($1, $2);
326 } else {
327 ($dir, $toname) = (":", $to);
328 }
329
330 unlink($to);
331 Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1);
332 };
333 } else {
33411.0e-61.0e-6 $Syscopy_is_copy = 1;
33511.0e-61.0e-6 *syscopy = \&copy;
336 }
337}
338
33913.1e-53.1e-51;
340
341__END__
342
343=head1 NAME
344
345File::Copy - Copy files or filehandles
346
347=head1 SYNOPSIS
348
349 use File::Copy;
350
351 copy("file1","file2") or die "Copy failed: $!";
352 copy("Copy.pm",\*STDOUT);
353 move("/dev1/fileA","/dev2/fileB");
354
355 use File::Copy "cp";
356
357 $n = FileHandle->new("/a/file","r");
358 cp($n,"x");
359
360=head1 DESCRIPTION
361
362The File::Copy module provides two basic functions, C<copy> and
363C<move>, which are useful for getting the contents of a file from
364one place to another.
365
366=over 4
367
368=item copy
369X<copy> X<cp>
370
371The C<copy> function takes two
372parameters: a file to copy from and a file to copy to. Either
373argument may be a string, a FileHandle reference or a FileHandle
374glob. Obviously, if the first argument is a filehandle of some
375sort, it will be read from, and if it is a file I<name> it will
376be opened for reading. Likewise, the second argument will be
377written to (and created if need be). Trying to copy a file on top
378of itself is a fatal error.
379
380B<Note that passing in
381files as handles instead of names may lead to loss of information
382on some operating systems; it is recommended that you use file
383names whenever possible.> Files are opened in binary mode where
384applicable. To get a consistent behaviour when copying from a
385filehandle to a file, use C<binmode> on the filehandle.
386
387An optional third parameter can be used to specify the buffer
388size used for copying. This is the number of bytes from the
389first file, that will be held in memory at any given time, before
390being written to the second file. The default buffer size depends
391upon the file, but will generally be the whole file (up to 2MB), or
3921k for filehandles that do not reference files (eg. sockets).
393
394You may use the syntax C<use File::Copy "cp"> to get at the
395"cp" alias for this function. The syntax is I<exactly> the same.
396
397=item move
398X<move> X<mv> X<rename>
399
400The C<move> function also takes two parameters: the current name
401and the intended name of the file to be moved. If the destination
402already exists and is a directory, and the source is not a
403directory, then the source file will be renamed into the directory
404specified by the destination.
405
406If possible, move() will simply rename the file. Otherwise, it copies
407the file to the new location and deletes the original. If an error occurs
408during this copy-and-delete process, you may be left with a (possibly partial)
409copy of the file under the destination name.
410
411You may use the "mv" alias for this function in the same way that
412you may use the "cp" alias for C<copy>.
413
414=item syscopy
415X<syscopy>
416
417File::Copy also provides the C<syscopy> routine, which copies the
418file specified in the first parameter to the file specified in the
419second parameter, preserving OS-specific attributes and file
420structure. For Unix systems, this is equivalent to the simple
421C<copy> routine, which doesn't preserve OS-specific attributes. For
422VMS systems, this calls the C<rmscopy> routine (see below). For OS/2
423systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
424this calls C<Win32::CopyFile>.
425
426On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
427if available.
428
429B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
430
431If both arguments to C<copy> are not file handles,
432then C<copy> will perform a "system copy" of
433the input file to a new output file, in order to preserve file
434attributes, indexed file structure, I<etc.> The buffer size
435parameter is ignored. If either argument to C<copy> is a
436handle to an opened file, then data is copied using Perl
437operators, and no effort is made to preserve file attributes
438or record structure.
439
440The system copy routine may also be called directly under VMS and OS/2
441as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
442is the routine that does the actual work for syscopy).
443
444=item rmscopy($from,$to[,$date_flag])
445X<rmscopy>
446
447The first and second arguments may be strings, typeglobs, typeglob
448references, or objects inheriting from IO::Handle;
449they are used in all cases to obtain the
450I<filespec> of the input and output files, respectively. The
451name and type of the input file are used as defaults for the
452output file, if necessary.
453
454A new version of the output file is always created, which
455inherits the structure and RMS attributes of the input file,
456except for owner and protections (and possibly timestamps;
457see below). All data from the input file is copied to the
458output file; if either of the first two parameters to C<rmscopy>
459is a file handle, its position is unchanged. (Note that this
460means a file handle pointing to the output file will be
461associated with an old version of that file after C<rmscopy>
462returns, not the newly created version.)
463
464The third parameter is an integer flag, which tells C<rmscopy>
465how to handle timestamps. If it is E<lt> 0, none of the input file's
466timestamps are propagated to the output file. If it is E<gt> 0, then
467it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
468timestamps other than the revision date are propagated; if bit 1
469is set, the revision date is propagated. If the third parameter
470to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
471if the name or type of the output file was explicitly specified,
472then no timestamps are propagated, but if they were taken implicitly
473from the input filespec, then all timestamps other than the
474revision date are propagated. If this parameter is not supplied,
475it defaults to 0.
476
477Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
478it sets C<$!>, deletes the output file, and returns 0.
479
480=back
481
482=head1 RETURN
483
484All functions return 1 on success, 0 on failure.
485$! will be set if an error was encountered.
486
487=head1 NOTES
488
489=over 4
490
491=item *
492
493On Mac OS (Classic), the path separator is ':', not '/', and the
494current directory is denoted as ':', not '.'. You should be careful
495about specifying relative pathnames. While a full path always begins
496with a volume name, a relative pathname should always begin with a
497':'. If specifying a volume name only, a trailing ':' is required.
498
499E.g.
500
501 copy("file1", "tmp"); # creates the file 'tmp' in the current directory
502 copy("file1", ":tmp:"); # creates :tmp:file1
503 copy("file1", ":tmp"); # same as above
504 copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do
505 # that, since it may cause confusion, see example #1)
506 copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume
507 copy("file1", ":tmp:file1"); # ok, partial path
508 copy("file1", "DataHD:"); # creates DataHD:file1
509
510 move("MacintoshHD:fileA", "DataHD:fileB"); # moves (doesn't copy) files from one
511 # volume to another
512
513=back
514
515=head1 AUTHOR
516
517File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
518and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
519
520=cut
521