← Index
NYTProf Performance Profile   « line view »
For /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/bin/perlcritic
  Run on Sat Mar 19 22:12:22 2016
Reported on Sat Mar 19 22:14:13 2016

Filename/Users/timbo/perl5/perlbrew/perls/perl-5.18.2/lib/5.18.2/File/Copy.pm
StatementsExecuted 27 statements in 1.78ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11115µs15µsFile::Copy::::BEGIN@10File::Copy::BEGIN@10
11110µs21µsFile::Copy::::BEGIN@11File::Copy::BEGIN@11
1119µs20µsFile::Copy::::BEGIN@14File::Copy::BEGIN@14
1117µs16µsFile::Copy::::BEGIN@12.105File::Copy::BEGIN@12.105
1117µs12µsFile::Copy::::BEGIN@12File::Copy::BEGIN@12
1114µs4µsFile::Copy::::BEGIN@13File::Copy::BEGIN@13
1114µs4µsFile::Copy::::BEGIN@47File::Copy::BEGIN@47
0000s0sFile::Copy::::__ANON__[:419]File::Copy::__ANON__[:419]
0000s0sFile::Copy::::_catnameFile::Copy::_catname
0000s0sFile::Copy::::_eqFile::Copy::_eq
0000s0sFile::Copy::::_moveFile::Copy::_move
0000s0sFile::Copy::::_vms_efsFile::Copy::_vms_efs
0000s0sFile::Copy::::_vms_unix_rptFile::Copy::_vms_unix_rpt
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
10236µs115µs
# spent 15µs within File::Copy::BEGIN@10 which was called: # once (15µs+0s) by Perl::Tidy::BEGIN@78 at line 10
use 5.006;
# spent 15µs making 1 call to File::Copy::BEGIN@10
11218µs232µs
# spent 21µs (10+11) within File::Copy::BEGIN@11 which was called: # once (10µs+11µs) by Perl::Tidy::BEGIN@78 at line 11
use strict;
# spent 21µs making 1 call to File::Copy::BEGIN@11 # spent 11µs making 1 call to strict::import
12436µs443µs
# spent 12µs (7+6) within File::Copy::BEGIN@12 which was called: # once (7µs+6µs) by Perl::Tidy::BEGIN@78 at line 12 # spent 16µs (7+9) within File::Copy::BEGIN@12.105 which was called: # once (7µs+9µs) by Perl::Tidy::BEGIN@78 at line 12
use warnings; no warnings 'newline';
# spent 16µs making 1 call to File::Copy::BEGIN@12.105 # spent 12µs making 1 call to File::Copy::BEGIN@12 # spent 9µs making 1 call to warnings::unimport # spent 6µs making 1 call to warnings::import
13216µs14µs
# spent 4µs within File::Copy::BEGIN@13 which was called: # once (4µs+0s) by Perl::Tidy::BEGIN@78 at line 13
use File::Spec;
# spent 4µs making 1 call to File::Copy::BEGIN@13
142160µs231µs
# spent 20µs (9+11) within File::Copy::BEGIN@14 which was called: # once (9µs+11µs) by Perl::Tidy::BEGIN@78 at line 14
use Config;
# spent 20µs making 1 call to File::Copy::BEGIN@14 # spent 11µs making 1 call to Config::import
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.
18116µsmy $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
# spent 3µs executing statements in string eval
191400nsour(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
20sub copy;
21sub syscopy;
22sub cp;
23sub mv;
24
251400ns$VERSION = '2.26';
26
271200nsrequire Exporter;
2815µs@ISA = qw(Exporter);
291700ns@EXPORT = qw(copy move);
301400ns@EXPORT_OK = qw(cp mv);
31
321100ns$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
44# Look up the feature settings on VMS using VMS::Feature when available.
45
461100nsmy $use_vms_feature = 0;
47
# spent 4µs within File::Copy::BEGIN@47 which was called: # once (4µs+0s) by Perl::Tidy::BEGIN@78 at line 53
BEGIN {
4815µs if ($^O eq 'VMS') {
49 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
50 $use_vms_feature = 1;
51 }
52 }
5311.47ms14µs}
# spent 4µs making 1 call to File::Copy::BEGIN@47
54
55# Need to look up the UNIX report mode. This may become a dynamic mode
56# in the future.
57sub _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.
70sub _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
82sub _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
93sub _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
105sub 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 return 0;
132 }
133
134 if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
135 $to = _catname($from, $to);
136 }
137
138 if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
139 !($^O eq 'MSWin32' || $^O eq 'os2')) {
140 my @fs = stat($from);
141 if (@fs) {
142 my @ts = stat($to);
143 if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p $from) {
144 carp("'$from' and '$to' are identical (not copied)");
145 return 0;
146 }
147 }
148 }
149 elsif (_eq($from, $to)) {
150 carp("'$from' and '$to' are identical (not copied)");
151 return 0;
152 }
153
154 if (defined &syscopy && !$Syscopy_is_copy
155 && !$to_a_handle
156 && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles
157 && !($from_a_handle && $^O eq 'MSWin32')
158 && !($from_a_handle && $^O eq 'NetWare')
159 )
160 {
161 my $copy_to = $to;
162
163 if ($^O eq 'VMS' && -e $from) {
164
165 if (! -d $to && ! -d $from) {
166
167 my $vms_efs = _vms_efs();
168 my $unix_rpt = _vms_unix_rpt();
169 my $unix_mode = 0;
170 my $from_unix = 0;
171 $from_unix = 1 if ($from =~ /^\.\.?$/);
172 my $from_vms = 0;
173 $from_vms = 1 if ($from =~ m#[\[<\]]#);
174
175 # Need to know if we are in Unix mode.
176 if ($from_vms == $from_unix) {
177 $unix_mode = $unix_rpt;
178 } else {
179 $unix_mode = $from_unix;
180 }
181
182 # VMS has sticky defaults on extensions, which means that
183 # if there is a null extension on the destination file, it
184 # will inherit the extension of the source file
185 # So add a '.' for a null extension.
186
187 # In unix_rpt mode, the trailing dot should not be added.
188
189 if ($vms_efs) {
190 $copy_to = $to;
191 } else {
192 $copy_to = VMS::Filespec::vmsify($to);
193 }
194 my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
195 $file = $file . '.'
196 unless (($file =~ /(?<!\^)\./) || $unix_rpt);
197 $copy_to = File::Spec->catpath($vol, $dirs, $file);
198
199 # Get rid of the old versions to be like UNIX
200 1 while unlink $copy_to;
201 }
202 }
203
204 return syscopy($from, $copy_to) || 0;
205 }
206
207 my $closefrom = 0;
208 my $closeto = 0;
209 my ($status, $r, $buf);
210 local($\) = '';
211
212 my $from_h;
213 if ($from_a_handle) {
214 $from_h = $from;
215 } else {
216 open $from_h, "<", $from or goto fail_open1;
217 binmode $from_h or die "($!,$^E)";
218 $closefrom = 1;
219 }
220
221 # Seems most logical to do this here, in case future changes would want to
222 # make this croak for some reason.
223 unless (defined $size) {
224 $size = tied(*$from_h) ? 0 : -s $from_h || 0;
225 $size = 1024 if ($size < 512);
226 $size = $Too_Big if ($size > $Too_Big);
227 }
228
229 my $to_h;
230 if ($to_a_handle) {
231 $to_h = $to;
232 } else {
233 $to_h = \do { local *FH }; # XXX is this line obsolete?
234 open $to_h, ">", $to or goto fail_open2;
235 binmode $to_h or die "($!,$^E)";
236 $closeto = 1;
237 }
238
239 $! = 0;
240 for (;;) {
241 my ($r, $w, $t);
242 defined($r = sysread($from_h, $buf, $size))
243 or goto fail_inner;
244 last unless $r;
245 for ($w = 0; $w < $r; $w += $t) {
246 $t = syswrite($to_h, $buf, $r - $w, $w)
247 or goto fail_inner;
248 }
249 }
250
251 close($to_h) || goto fail_open2 if $closeto;
252 close($from_h) || goto fail_open1 if $closefrom;
253
254 # Use this idiom to avoid uninitialized value warning.
255 return 1;
256
257 # All of these contortions try to preserve error messages...
258 fail_inner:
259 if ($closeto) {
260 $status = $!;
261 $! = 0;
262 close $to_h;
263 $! = $status unless $!;
264 }
265 fail_open2:
266 if ($closefrom) {
267 $status = $!;
268 $! = 0;
269 close $from_h;
270 $! = $status unless $!;
271 }
272 fail_open1:
273 return 0;
274}
275
276sub cp {
277 my($from,$to) = @_;
278 my(@fromstat) = stat $from;
279 my(@tostat) = stat $to;
280 my $perm;
281
282 return 0 unless copy(@_) and @fromstat;
283
284 if (@tostat) {
285 $perm = $tostat[2];
286 } else {
287 $perm = $fromstat[2] & ~(umask || 0);
288 @tostat = stat $to;
289 }
290 # Might be more robust to look for S_I* in Fcntl, but we're
291 # trying to avoid dependence on any XS-containing modules,
292 # since File::Copy is used during the Perl build.
293 $perm &= 07777;
294 if ($perm & 06000) {
295 croak("Unable to check setuid/setgid permissions for $to: $!")
296 unless @tostat;
297
298 if ($perm & 04000 and # setuid
299 $fromstat[4] != $tostat[4]) { # owner must match
300 $perm &= ~06000;
301 }
302
303 if ($perm & 02000 && $> != 0) { # if not root, setgid
304 my $ok = $fromstat[5] == $tostat[5]; # group must match
305 if ($ok) { # and we must be in group
306 $ok = grep { $_ == $fromstat[5] } split /\s+/, $)
307 }
308 $perm &= ~06000 unless $ok;
309 }
310 }
311 return 0 unless @tostat;
312 return 1 if $perm == ($tostat[2] & 07777);
313 return eval { chmod $perm, $to; } ? 1 : 0;
314}
315
316sub _move {
317 croak("Usage: move(FROM, TO) ") unless @_ == 3;
318
319 my($from,$to,$fallback) = @_;
320
321 my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
322
323 if (-d $to && ! -d $from) {
324 $to = _catname($from, $to);
325 }
326
327 ($tosz1,$tomt1) = (stat($to))[7,9];
328 $fromsz = -s $from;
329 if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
330 # will not rename with overwrite
331 unlink $to;
332 }
333
334 my $rename_to = $to;
335 if (-$^O eq 'VMS' && -e $from) {
336
337 if (! -d $to && ! -d $from) {
338
339 my $vms_efs = _vms_efs();
340 my $unix_rpt = _vms_unix_rpt();
341 my $unix_mode = 0;
342 my $from_unix = 0;
343 $from_unix = 1 if ($from =~ /^\.\.?$/);
344 my $from_vms = 0;
345 $from_vms = 1 if ($from =~ m#[\[<\]]#);
346
347 # Need to know if we are in Unix mode.
348 if ($from_vms == $from_unix) {
349 $unix_mode = $unix_rpt;
350 } else {
351 $unix_mode = $from_unix;
352 }
353
354 # VMS has sticky defaults on extensions, which means that
355 # if there is a null extension on the destination file, it
356 # will inherit the extension of the source file
357 # So add a '.' for a null extension.
358
359 # In unix_rpt mode, the trailing dot should not be added.
360
361 if ($vms_efs) {
362 $rename_to = $to;
363 } else {
364 $rename_to = VMS::Filespec::vmsify($to);
365 }
366 my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
367 $file = $file . '.'
368 unless (($file =~ /(?<!\^)\./) || $unix_rpt);
369 $rename_to = File::Spec->catpath($vol, $dirs, $file);
370
371 # Get rid of the old versions to be like UNIX
372 1 while unlink $rename_to;
373 }
374 }
375
376 return 1 if rename $from, $rename_to;
377
378 # Did rename return an error even though it succeeded, because $to
379 # is on a remote NFS file system, and NFS lost the server's ack?
380 return 1 if defined($fromsz) && !-e $from && # $from disappeared
381 (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
382 ((!defined $tosz1) || # not before or
383 ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
384 $tosz2 == $fromsz; # it's all there
385
386 ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
387
388 {
389 local $@;
390 eval {
391 local $SIG{__DIE__};
392 $fallback->($from,$to) or die;
393 my($atime, $mtime) = (stat($from))[8,9];
394 utime($atime, $mtime, $to);
395 unlink($from) or die;
396 };
397 return 1 unless $@;
398 }
399 ($sts,$ossts) = ($! + 0, $^E + 0);
400
401 ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
402 unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
403 ($!,$^E) = ($sts,$ossts);
404 return 0;
405}
406
407sub move { _move(@_,\&copy); }
408sub mv { _move(@_,\&cp); }
409
410# &syscopy is an XSUB under OS/2
4111500nsunless (defined &syscopy) {
41211µs if ($^O eq 'VMS') {
413 *syscopy = \&rmscopy;
414 } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
415 # Win32::CopyFile() fill only work if we can load Win32.xs
416 *syscopy = sub {
417 return 0 unless @_ == 2;
418 return Win32::CopyFile(@_, 1);
419 };
420 } else {
4211100ns $Syscopy_is_copy = 1;
42212µs *syscopy = \&copy;
423 }
424}
425
42619µs1;
427
428__END__
Report produced by the NYTProf 6.01 Perl profiler, developed by Tim Bunce and Adam Kaplan.