← Index
NYTProf Performance Profile   « block view • line view • sub view »
For bin/pan_genome_post_analysis
  Run on Fri Mar 27 11:43:32 2015
Reported on Fri Mar 27 11:45:41 2015

Filename/Users/ap13/perl5/perlbrew/perls/perl-5.16.2/lib/5.16.2/File/Copy.pm
StatementsExecuted 27 statements in 2.39ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1112.40ms3.17msFile::Copy::::BEGIN@13File::Copy::BEGIN@13
11130µs30µsFile::Copy::::BEGIN@10File::Copy::BEGIN@10
11117µs38µsFile::Copy::::BEGIN@12.1File::Copy::BEGIN@12.1
11114µs41µsFile::Copy::::BEGIN@11File::Copy::BEGIN@11
11114µs35µsFile::Copy::::BEGIN@12File::Copy::BEGIN@12
11112µs25µsFile::Copy::::BEGIN@14File::Copy::BEGIN@14
1114µs4µsFile::Copy::::BEGIN@47File::Copy::BEGIN@47
0000s0sFile::Copy::::__ANON__[:419]File::Copy::__ANON__[:419]
0000s0sFile::Copy::::__ANON__[:425]File::Copy::__ANON__[:425]
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
10274µs130µs
# spent 30µs within File::Copy::BEGIN@10 which was called: # once (30µs+0s) by Bio::Roary::PostAnalysis::BEGIN@12 at line 10
use 5.006;
# spent 30µs making 1 call to File::Copy::BEGIN@10
11242µs267µs
# spent 41µs (14+26) within File::Copy::BEGIN@11 which was called: # once (14µs+26µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 11
use strict;
# spent 41µs making 1 call to File::Copy::BEGIN@11 # spent 26µs making 1 call to strict::import
124107µs4112µs
# spent 35µs (14+20) within File::Copy::BEGIN@12 which was called: # once (14µs+20µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 12 # spent 38µs (17+20) within File::Copy::BEGIN@12.1 which was called: # once (17µs+20µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 12
use warnings; no warnings 'newline';
# spent 38µs making 1 call to File::Copy::BEGIN@12.1 # spent 35µs making 1 call to File::Copy::BEGIN@12 # spent 20µs making 1 call to warnings::unimport # spent 20µs making 1 call to warnings::import
132163µs13.17ms
# spent 3.17ms (2.40+776µs) within File::Copy::BEGIN@13 which was called: # once (2.40ms+776µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 13
use File::Spec;
# spent 3.17ms making 1 call to File::Copy::BEGIN@13
142173µs238µs
# spent 25µs (12+13) within File::Copy::BEGIN@14 which was called: # once (12µs+13µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 14
use Config;
# spent 25µs making 1 call to File::Copy::BEGIN@14 # spent 13µ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.
18120µsmy $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
# spent 5µs executing statements in string eval
191600nsour(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
20sub copy;
21sub syscopy;
22sub cp;
23sub mv;
24
251500ns$VERSION = '2.23';
26
271800nsrequire Exporter;
2818µs@ISA = qw(Exporter);
291800ns@EXPORT = qw(copy move);
301500ns@EXPORT_OK = qw(cp mv);
31
321200ns$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 Bio::Roary::PostAnalysis::BEGIN@12 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.77ms14µ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 # 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
275sub 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
315sub _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
406sub move { _move(@_,\&copy); }
407sub mv { _move(@_,\&cp); }
408
409# &syscopy is an XSUB under OS/2
41022µsunless (defined &syscopy) {
41122µs 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
432126µs1;
433
434__END__