← Index
NYTProf Performance Profile   « line view »
For t/bug-md-11.t
  Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename/home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/File/Copy.pm
StatementsExecuted 30 statements in 1.16ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11178µs111µsFile::Copy::::BEGIN@14File::Copy::BEGIN@14
11121µs101µsFile::Copy::::BEGIN@19File::Copy::BEGIN@19
11111µs11µsFile::Copy::::BEGIN@10File::Copy::BEGIN@10
1115µs6µsFile::Copy::::BEGIN@16File::Copy::BEGIN@16
1114µs5µsFile::Copy::::BEGIN@11File::Copy::BEGIN@11
1113µs12µsFile::Copy::::BEGIN@12.1File::Copy::BEGIN@12.1
1113µs10µsFile::Copy::::BEGIN@15File::Copy::BEGIN@15
1113µs8µsFile::Copy::::BEGIN@17File::Copy::BEGIN@17
1113µs20µsFile::Copy::::BEGIN@12File::Copy::BEGIN@12
1113µs8µsFile::Copy::::BEGIN@13File::Copy::BEGIN@13
111300ns300nsFile::Copy::::__ANON__File::Copy::__ANON__ (xsub)
0000s0sFile::Copy::::__ANON__[:323]File::Copy::__ANON__[:323]
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
10223µs111µs
# spent 11µs within File::Copy::BEGIN@10 which was called: # once (11µs+0s) by Archive::Zip::Archive::BEGIN@9 at line 10
use 5.035007;
# spent 11µs making 1 call to File::Copy::BEGIN@10
11214µs27µs
# spent 5µs (4+2) within File::Copy::BEGIN@11 which was called: # once (4µs+2µs) by Archive::Zip::Archive::BEGIN@9 at line 11
use strict;
# spent 5µs making 1 call to File::Copy::BEGIN@11 # spent 2µs making 1 call to strict::import
12427µs457µs
# spent 12µs (3+9) within File::Copy::BEGIN@12.1 which was called: # once (3µs+9µs) by Archive::Zip::Archive::BEGIN@9 at line 12 # spent 20µs (3+17) within File::Copy::BEGIN@12 which was called: # once (3µs+17µs) by Archive::Zip::Archive::BEGIN@9 at line 12
use warnings; no warnings 'newline';
# spent 20µs making 1 call to File::Copy::BEGIN@12 # spent 17µs making 1 call to warnings::import # spent 12µs making 1 call to File::Copy::BEGIN@12.1 # spent 9µs making 1 call to warnings::unimport
13211µs214µs
# spent 8µs (3+5) within File::Copy::BEGIN@13 which was called: # once (3µs+5µs) by Archive::Zip::Archive::BEGIN@9 at line 13
no warnings 'experimental::builtin';
# spent 8µs making 1 call to File::Copy::BEGIN@13 # spent 5µs making 1 call to warnings::unimport
14272µs2114µs
# spent 111µs (78+33) within File::Copy::BEGIN@14 which was called: # once (78µs+33µs) by Archive::Zip::Archive::BEGIN@9 at line 14
use builtin 'blessed';
# spent 111µs making 1 call to File::Copy::BEGIN@14 # spent 3µs making 1 call to builtin::import
15210µs217µs
# spent 10µs (3+7) within File::Copy::BEGIN@15 which was called: # once (3µs+7µs) by Archive::Zip::Archive::BEGIN@9 at line 15
use overload;
# spent 10µs making 1 call to File::Copy::BEGIN@15 # spent 7µs making 1 call to overload::import
16214µs26µs
# spent 6µs (5+300ns) within File::Copy::BEGIN@16 which was called: # once (5µs+300ns) by Archive::Zip::Archive::BEGIN@9 at line 16
use File::Spec;
# spent 6µs making 1 call to File::Copy::BEGIN@16 # spent 300ns making 1 call to File::Copy::__ANON__
17213µs214µs
# spent 8µs (3+5) within File::Copy::BEGIN@17 which was called: # once (3µs+5µs) by Archive::Zip::Archive::BEGIN@9 at line 17
use Config;
# spent 8µs making 1 call to File::Copy::BEGIN@17 # spent 5µs making 1 call to Config::import
18# We want HiRes stat and utime if available
191958µs1101µs
# spent 101µs (21+80) within File::Copy::BEGIN@19 which was called: # once (21µs+80µs) by Archive::Zip::Archive::BEGIN@9 at line 19
BEGIN { eval q{ use Time::HiRes qw( stat utime ) } };
# spent 101µs making 1 call to File::Copy::BEGIN@19
# spent 10µs executing statements in string eval
# includes 5µs spent executing 1 call to 1 sub defined therein.
20our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
21sub copy;
22sub syscopy;
23sub cp;
24sub mv;
25
261400ns$VERSION = '2.41';
27
281400nsrequire Exporter;
2915µs@ISA = qw(Exporter);
301300ns@EXPORT = qw(copy move);
311200ns@EXPORT_OK = qw(cp mv);
32
331100ns$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
45sub _catname {
46 my($from, $to) = @_;
47 if (not defined &basename) {
48 require File::Basename;
49 File::Basename->import( 'basename' );
50 }
51
52 return File::Spec->catfile($to, basename($from));
53}
54
55# _eq($from, $to) tells whether $from and $to are identical
56sub _eq {
57 my ($from, $to) = map {
58 blessed($_) && 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 'os2')) {
102 my @fs = stat($from);
103 if (@fs) {
104 my @ts = stat($to);
105 if (@ts && $fs[0] == $ts[0] && $fs[1] eq $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 )
121 {
122 if ($^O eq 'VMS' && -e $from
123 && ! -d $to && ! -d $from) {
124
125 # VMS natively inherits path components from the source of a
126 # copy, but we want the Unixy behavior of inheriting from
127 # the current working directory. Also, default in a trailing
128 # dot for null file types.
129
130 $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
131
132 # Get rid of the old versions to be like UNIX
133 1 while unlink $to;
134 }
135
136 return syscopy($from, $to) || 0;
137 }
138
139 my $closefrom = 0;
140 my $closeto = 0;
141 my ($status, $r, $buf);
142 local($\) = '';
143
144 my $from_h;
145 if ($from_a_handle) {
146 $from_h = $from;
147 } else {
148 open $from_h, "<", $from or goto fail_open1;
149 binmode $from_h or die "($!,$^E)";
150 $closefrom = 1;
151 }
152
153 # Seems most logical to do this here, in case future changes would want to
154 # make this croak for some reason.
155 unless (defined $size) {
156 $size = tied(*$from_h) ? 0 : -s $from_h || 0;
157 $size = 1024 if ($size < 512);
158 $size = $Too_Big if ($size > $Too_Big);
159 }
160
161 my $to_h;
162 if ($to_a_handle) {
163 $to_h = $to;
164 } else {
165 $to_h = \do { local *FH }; # XXX is this line obsolete?
166 open $to_h, ">", $to or goto fail_open2;
167 binmode $to_h or die "($!,$^E)";
168 $closeto = 1;
169 }
170
171 $! = 0;
172 for (;;) {
173 my ($r, $w, $t);
174 defined($r = sysread($from_h, $buf, $size))
175 or goto fail_inner;
176 last unless $r;
177 for ($w = 0; $w < $r; $w += $t) {
178 $t = syswrite($to_h, $buf, $r - $w, $w)
179 or goto fail_inner;
180 }
181 }
182
183 close($to_h) || goto fail_open2 if $closeto;
184 close($from_h) || goto fail_open1 if $closefrom;
185
186 # Use this idiom to avoid uninitialized value warning.
187 return 1;
188
189 # All of these contortions try to preserve error messages...
190 fail_inner:
191 if ($closeto) {
192 $status = $!;
193 $! = 0;
194 close $to_h;
195 $! = $status unless $!;
196 }
197 fail_open2:
198 if ($closefrom) {
199 $status = $!;
200 $! = 0;
201 close $from_h;
202 $! = $status unless $!;
203 }
204 fail_open1:
205 return 0;
206}
207
208sub cp {
209 my($from,$to) = @_;
210 my(@fromstat) = stat $from;
211 my(@tostat) = stat $to;
212 my $perm;
213
214 return 0 unless copy(@_) and @fromstat;
215
216 if (@tostat) {
217 $perm = $tostat[2];
218 } else {
219 $perm = $fromstat[2] & ~(umask || 0);
220 @tostat = stat $to;
221 }
222 # Might be more robust to look for S_I* in Fcntl, but we're
223 # trying to avoid dependence on any XS-containing modules,
224 # since File::Copy is used during the Perl build.
225 $perm &= 07777;
226 if ($perm & 06000) {
227 croak("Unable to check setuid/setgid permissions for $to: $!")
228 unless @tostat;
229
230 if ($perm & 04000 and # setuid
231 $fromstat[4] != $tostat[4]) { # owner must match
232 $perm &= ~06000;
233 }
234
235 if ($perm & 02000 && $> != 0) { # if not root, setgid
236 my $ok = $fromstat[5] == $tostat[5]; # group must match
237 if ($ok) { # and we must be in group
238 $ok = grep { $_ == $fromstat[5] } split /\s+/, $)
239 }
240 $perm &= ~06000 unless $ok;
241 }
242 }
243 return 0 unless @tostat;
244 return 1 if $perm == ($tostat[2] & 07777);
245 return eval { chmod $perm, $to; } ? 1 : 0;
246}
247
248sub _move {
249 croak("Usage: move(FROM, TO) ") unless @_ == 3;
250
251 my($from,$to,$fallback) = @_;
252
253 my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
254
255 if (-d $to && ! -d $from) {
256 $to = _catname($from, $to);
257 }
258
259 ($tosz1,$tomt1) = (stat($to))[7,9];
260 $fromsz = -s $from;
261 if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
262 # will not rename with overwrite
263 unlink $to;
264 }
265
266 if ($^O eq 'VMS' && -e $from
267 && ! -d $to && ! -d $from) {
268
269 # VMS natively inherits path components from the source of a
270 # copy, but we want the Unixy behavior of inheriting from
271 # the current working directory. Also, default in a trailing
272 # dot for null file types.
273
274 $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
275
276 # Get rid of the old versions to be like UNIX
277 1 while unlink $to;
278 }
279
280 return 1 if rename $from, $to;
281
282 # Did rename return an error even though it succeeded, because $to
283 # is on a remote NFS file system, and NFS lost the server's ack?
284 return 1 if defined($fromsz) && !-e $from && # $from disappeared
285 (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
286 ((!defined $tosz1) || # not before or
287 ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
288 $tosz2 == $fromsz; # it's all there
289
290 ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
291
292 {
293 local $@;
294 eval {
295 local $SIG{__DIE__};
296 $fallback->($from,$to) or die;
297 my($atime, $mtime) = (stat($from))[8,9];
298 utime($atime, $mtime, $to);
299 unlink($from) or die;
300 };
301 return 1 unless $@;
302 }
303 ($sts,$ossts) = ($! + 0, $^E + 0);
304
305 ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
306 unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
307 ($!,$^E) = ($sts,$ossts);
308 return 0;
309}
310
311sub move { _move(@_,\&copy); }
312sub mv { _move(@_,\&cp); }
313
314# &syscopy is an XSUB under OS/2
3151500nsunless (defined &syscopy) {
31611µs if ($^O eq 'VMS') {
317 *syscopy = \&rmscopy;
318 } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
319 # Win32::CopyFile() fill only work if we can load Win32.xs
320 *syscopy = sub {
321 return 0 unless @_ == 2;
322 return Win32::CopyFile(@_, 1);
323 };
324 } else {
3251100ns $Syscopy_is_copy = 1;
32611µs *syscopy = \&copy;
327 }
328}
329
33016µs1;
331
332__END__
 
# spent 300ns within File::Copy::__ANON__ which was called: # once (300ns+0s) by File::Copy::BEGIN@16 at line 16
sub File::Copy::__ANON__; # xsub