← Index
NYTProf Performance Profile   « line view »
For Makefile.PL
  Run on Sun Mar 1 16:04:44 2015
Reported on Sun Mar 1 16:09:02 2015

FilenameC:/tmp64ng/perl/lib/File/Copy.pm
StatementsExecuted 24 statements in 0s
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1110s0sFile::Copy::::BEGIN@10File::Copy::BEGIN@10
1110s0sFile::Copy::::BEGIN@11File::Copy::BEGIN@11
1110s0sFile::Copy::::BEGIN@12File::Copy::BEGIN@12
1110s0sFile::Copy::::BEGIN@12.1File::Copy::BEGIN@12.1
1110s0sFile::Copy::::BEGIN@13File::Copy::BEGIN@13
1110s0sFile::Copy::::BEGIN@14File::Copy::BEGIN@14
0000s0sFile::Copy::::__ANON__[:324]File::Copy::__ANON__[:324]
0000s0sFile::Copy::::_catnameFile::Copy::_catname
0000s0sFile::Copy::::_eqFile::Copy::_eq
0000s0sFile::Copy::::_moveFile::Copy::_move
0000s0sFile::Copy::::carpFile::Copy::carp
0000s0sFile::Copy::::copyFile::Copy::copy
0000s0sFile::Copy::::cpFile::Copy::cp
0000s0sFile::Copy::::croakFile::Copy::croak
0000s0sFile::Copy::::moveFile::Copy::move
0000s0sFile::Copy::::mvFile::Copy::mv
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 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
1020s10s
# spent 0s within File::Copy::BEGIN@10 which was called: # once (0s+0s) by ExtUtils::Manifest::BEGIN@6 at line 10
use 5.006;
# spent 0s making 1 call to File::Copy::BEGIN@10
1120s20s
# spent 0s within File::Copy::BEGIN@11 which was called: # once (0s+0s) by ExtUtils::Manifest::BEGIN@6 at line 11
use strict;
# spent 0s making 1 call to File::Copy::BEGIN@11 # spent 0s making 1 call to strict::import
1240s40s
# spent 0s within File::Copy::BEGIN@12.1 which was called: # once (0s+0s) by ExtUtils::Manifest::BEGIN@6 at line 12 # spent 0s within File::Copy::BEGIN@12 which was called: # once (0s+0s) by ExtUtils::Manifest::BEGIN@6 at line 12
use warnings; no warnings 'newline';
# spent 0s making 1 call to File::Copy::BEGIN@12 # spent 0s making 1 call to File::Copy::BEGIN@12.1 # spent 0s making 1 call to warnings::import # spent 0s making 1 call to warnings::unimport
1320s10s
# spent 0s within File::Copy::BEGIN@13 which was called: # once (0s+0s) by ExtUtils::Manifest::BEGIN@6 at line 13
use File::Spec;
# spent 0s making 1 call to File::Copy::BEGIN@13
1420s20s
# spent 0s within File::Copy::BEGIN@14 which was called: # once (0s+0s) by ExtUtils::Manifest::BEGIN@6 at line 14
use Config;
# spent 0s making 1 call to Config::import # spent 0s making 1 call to File::Copy::BEGIN@14
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.
1810smy $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
# spent 0s executing statements in string eval
1910sour(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
20sub copy;
21sub syscopy;
22sub cp;
23sub mv;
24
2510s$VERSION = '2.30';
26
2710srequire Exporter;
2810s@ISA = qw(Exporter);
2910s@EXPORT = qw(copy move);
3010s@EXPORT_OK = qw(cp mv);
31
3210s$Too_Big = 1024 * 1024 * 2;
33
34sub croak {
35 require Carp;
36 goto &Carp::croak;
37}
38
39sub carp {
40 require Carp;
41 goto &Carp::carp;
42}
43
44sub _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
55sub _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
67sub 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
209sub 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
249sub _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
312sub move { _move(@_,\&copy); }
313sub mv { _move(@_,\&cp); }
314
315# &syscopy is an XSUB under OS/2
31610sunless (defined &syscopy) {
31710s 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);
32410s };
325 } else {
326 $Syscopy_is_copy = 1;
327 *syscopy = \&copy;
328 }
329}
330
33110s1;
332
333__END__
Report produced by the NYTProf 5.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.