← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 03:09:29 2017
Reported on Mon Nov 6 13:20:48 2017

Filename/usr/local/lib/perl5/5.24/File/Copy.pm
StatementsExecuted 24 statements in 3.82ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11154µs54µsFile::Copy::::BEGIN@10File::Copy::BEGIN@10
11128µs70µsFile::Copy::::BEGIN@14File::Copy::BEGIN@14
11122µs61µsFile::Copy::::BEGIN@12File::Copy::BEGIN@12
11121µs74µsFile::Copy::::BEGIN@12.3File::Copy::BEGIN@12.3
11120µs28µsFile::Copy::::BEGIN@11File::Copy::BEGIN@11
11116µs16µsFile::Copy::::BEGIN@13File::Copy::BEGIN@13
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
102110µs154µs
# spent 54µs within File::Copy::BEGIN@10 which was called: # once (54µs+0s) by Razor2::Client::Config::BEGIN@15 at line 10
use 5.006;
# spent 54µs making 1 call to File::Copy::BEGIN@10
11255µs237µs
# spent 28µs (20+8) within File::Copy::BEGIN@11 which was called: # once (20µs+8µs) by Razor2::Client::Config::BEGIN@15 at line 11
use strict;
# spent 28µs making 1 call to File::Copy::BEGIN@11 # spent 8µs making 1 call to strict::import
124111µs4228µs
# spent 61µs (22+39) within File::Copy::BEGIN@12 which was called: # once (22µs+39µs) by Razor2::Client::Config::BEGIN@15 at line 12 # spent 74µs (21+53) within File::Copy::BEGIN@12.3 which was called: # once (21µs+53µs) by Razor2::Client::Config::BEGIN@15 at line 12
use warnings; no warnings 'newline';
# spent 74µs making 1 call to File::Copy::BEGIN@12.3 # spent 61µs making 1 call to File::Copy::BEGIN@12 # spent 53µs making 1 call to warnings::unimport # spent 39µs making 1 call to warnings::import
13253µs116µs
# spent 16µs within File::Copy::BEGIN@13 which was called: # once (16µs+0s) by Razor2::Client::Config::BEGIN@15 at line 13
use File::Spec;
# spent 16µs making 1 call to File::Copy::BEGIN@13
1423.37ms2112µs
# spent 70µs (28+42) within File::Copy::BEGIN@14 which was called: # once (28µs+42µs) by Razor2::Client::Config::BEGIN@15 at line 14
use Config;
# spent 70µs making 1 call to File::Copy::BEGIN@14 # spent 42µ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.
18149µsmy $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
# spent 12µs executing statements in string eval
19our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
20sub copy;
21sub syscopy;
22sub cp;
23sub mv;
24
2512µs$VERSION = '2.31';
26
2713µsrequire Exporter;
28117µs@ISA = qw(Exporter);
2913µs@EXPORT = qw(copy move);
3012µs@EXPORT_OK = qw(cp mv);
31
3211µs$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
31614µsunless (defined &syscopy) {
31716µs 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);
324 };
325 } else {
32612µs $Syscopy_is_copy = 1;
32716µs *syscopy = \&copy;
328 }
329}
330
331126µs1;
332
333__END__
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.