Profile of File/Copy.pm

← 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
Statements | Executed 30 statements in 1.16ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 78µs | 111µs | File::Copy::::BEGIN@14File::Copy::BEGIN@14
1 | 1 | 1 | 21µs | 101µs | File::Copy::::BEGIN@19File::Copy::BEGIN@19
1 | 1 | 1 | 11µs | 11µs | File::Copy::::BEGIN@10File::Copy::BEGIN@10
1 | 1 | 1 | 5µs | 6µs | File::Copy::::BEGIN@16File::Copy::BEGIN@16
1 | 1 | 1 | 4µs | 5µs | File::Copy::::BEGIN@11File::Copy::BEGIN@11
1 | 1 | 1 | 3µs | 12µs | File::Copy::::BEGIN@12.1File::Copy::BEGIN@12.1
1 | 1 | 1 | 3µs | 10µs | File::Copy::::BEGIN@15File::Copy::BEGIN@15
1 | 1 | 1 | 3µs | 8µs | File::Copy::::BEGIN@17File::Copy::BEGIN@17
1 | 1 | 1 | 3µs | 20µs | File::Copy::::BEGIN@12File::Copy::BEGIN@12
1 | 1 | 1 | 3µs | 8µs | File::Copy::::BEGIN@13File::Copy::BEGIN@13
1 | 1 | 1 | 300ns | 300ns | File::Copy::::__ANON__File::Copy::__ANON__ (xsub)
0 | 0 | 0 | 0s | 0s | File::Copy::::__ANON__[:323]File::Copy::__ANON__[:323]
0 | 0 | 0 | 0s | 0s | File::Copy::::_catnameFile::Copy::_catname
0 | 0 | 0 | 0s | 0s | File::Copy::::_eqFile::Copy::_eq
0 | 0 | 0 | 0s | 0s | File::Copy::::_moveFile::Copy::_move
0 | 0 | 0 | 0s | 0s | File::Copy::::carpFile::Copy::carp
0 | 0 | 0 | 0s | 0s | File::Copy::::copyFile::Copy::copy
0 | 0 | 0 | 0s | 0s | File::Copy::::cpFile::Copy::cp
0 | 0 | 0 | 0s | 0s | File::Copy::::croakFile::Copy::croak
0 | 0 | 0 | 0s | 0s | File::Copy::::moveFile::Copy::move
0 | 0 | 0 | 0s | 0s | File::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 |  |  |  |  |
8 |  |  |  |  | package File::Copy;
9 |  |  |  |  |
10 | 2 | 23µs | 1 | 11µ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
11 | 2 | 14µs | 2 | 7µ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
12 | 4 | 27µs | 4 | 57µ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
13 | 2 | 11µs | 2 | 14µ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
14 | 2 | 72µs | 2 | 114µ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
15 | 2 | 10µs | 2 | 17µ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
16 | 2 | 14µs | 2 | 6µ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__
17 | 2 | 13µs | 2 | 14µ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
19 | 1 | 958µs | 1 | 101µ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.
20 |  |  |  |  | our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
21 |  |  |  |  | sub copy;
22 |  |  |  |  | sub syscopy;
23 |  |  |  |  | sub cp;
24 |  |  |  |  | sub mv;
25 |  |  |  |  |
26 | 1 | 400ns |  |  | $VERSION = '2.41';
27 |  |  |  |  |
28 | 1 | 400ns |  |  | require Exporter;
29 | 1 | 5µs |  |  | @ISA = qw(Exporter);
30 | 1 | 300ns |  |  | @EXPORT = qw(copy move);
31 | 1 | 200ns |  |  | @EXPORT_OK = qw(cp mv);
32 |  |  |  |  |
33 | 1 | 100ns |  |  | $Too_Big = 1024 * 1024 * 2;
34 |  |  |  |  |
35 |  |  |  |  | sub croak {
36 |  |  |  |  | require Carp;
37 |  |  |  |  | goto &Carp::croak;
38 |  |  |  |  | }
39 |  |  |  |  |
40 |  |  |  |  | sub carp {
41 |  |  |  |  | require Carp;
42 |  |  |  |  | goto &Carp::carp;
43 |  |  |  |  | }
44 |  |  |  |  |
45 |  |  |  |  | sub _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
56 |  |  |  |  | sub _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 |  |  |  |  |
67 |  |  |  |  | sub 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 |  |  |  |  |
208 |  |  |  |  | sub 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 |  |  |  |  |
248 |  |  |  |  | sub _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 |  |  |  |  |
311 |  |  |  |  | sub move { _move(@_,\&copy); }
312 |  |  |  |  | sub mv { _move(@_,\&cp); }
313 |  |  |  |  |
314 |  |  |  |  | # &syscopy is an XSUB under OS/2
315 | 1 | 500ns |  |  | unless (defined &syscopy) {
316 | 1 | 1µ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 {
325 | 1 | 100ns |  |  | $Syscopy_is_copy = 1;
326 | 1 | 1µs |  |  | *syscopy = \&copy;
327 |  |  |  |  | }
328 |  |  |  |  | }
329 |  |  |  |  |
330 | 1 | 6µs |  |  | 1;
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