Filename | /usr/share/perl/5.28/File/Copy.pm |
Statements | Executed 1789 statements in 607ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
294 | 1 | 1 | 377ms | 377ms | CORE:syswrite (opcode) | File::Copy::
300 | 1 | 1 | 222ms | 222ms | CORE:sysread (opcode) | File::Copy::
6 | 1 | 1 | 5.29ms | 605ms | copy | File::Copy::
12 | 2 | 1 | 454µs | 454µs | CORE:open (opcode) | File::Copy::
6 | 1 | 1 | 138µs | 151µs | _eq | File::Copy::
12 | 2 | 1 | 88µs | 88µs | CORE:close (opcode) | File::Copy::
1 | 1 | 1 | 44µs | 3.06ms | BEGIN@20 | File::Copy::
1 | 1 | 1 | 42µs | 42µs | BEGIN@10 | File::Copy::
12 | 2 | 1 | 23µs | 23µs | CORE:stat (opcode) | File::Copy::
1 | 1 | 1 | 21µs | 26µs | BEGIN@11 | File::Copy::
6 | 1 | 1 | 12µs | 12µs | CORE:ftsize (opcode) | File::Copy::
1 | 1 | 1 | 12µs | 13µs | BEGIN@13 | File::Copy::
6 | 1 | 1 | 11µs | 11µs | CORE:ftdir (opcode) | File::Copy::
1 | 1 | 1 | 10µs | 25µs | BEGIN@14 | File::Copy::
1 | 1 | 1 | 8µs | 41µs | BEGIN@12 | File::Copy::
12 | 2 | 1 | 7µs | 7µs | CORE:binmode (opcode) | File::Copy::
1 | 1 | 1 | 7µs | 29µs | BEGIN@12.6 | File::Copy::
1 | 1 | 1 | 700ns | 700ns | __ANON__ (xsub) | File::Copy::
0 | 0 | 0 | 0s | 0s | __ANON__[:326] | File::Copy::
0 | 0 | 0 | 0s | 0s | _catname | File::Copy::
0 | 0 | 0 | 0s | 0s | _move | File::Copy::
0 | 0 | 0 | 0s | 0s | carp | File::Copy::
0 | 0 | 0 | 0s | 0s | cp | File::Copy::
0 | 0 | 0 | 0s | 0s | croak | File::Copy::
0 | 0 | 0 | 0s | 0s | move | File::Copy::
0 | 0 | 0 | 0s | 0s | mv | File::Copy::
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 | 59µs | 1 | 42µs | # spent 42µs within File::Copy::BEGIN@10 which was called:
# once (42µs+0s) by RBM::BEGIN@14 at line 10 # spent 42µs making 1 call to File::Copy::BEGIN@10 |
11 | 2 | 22µs | 2 | 32µs | # spent 26µs (21+6) within File::Copy::BEGIN@11 which was called:
# once (21µs+6µs) by RBM::BEGIN@14 at line 11 # spent 26µs making 1 call to File::Copy::BEGIN@11
# spent 6µs making 1 call to strict::import |
12 | 4 | 48µs | 4 | 125µs | use warnings; no warnings 'newline'; # spent 41µs making 1 call to File::Copy::BEGIN@12
# spent 33µs making 1 call to warnings::import
# spent 29µs making 1 call to File::Copy::BEGIN@12.6
# spent 22µs making 1 call to warnings::unimport |
13 | 2 | 28µs | 2 | 13µs | # spent 13µs (12+700ns) within File::Copy::BEGIN@13 which was called:
# once (12µs+700ns) by RBM::BEGIN@14 at line 13 # spent 13µs making 1 call to File::Copy::BEGIN@13
# spent 700ns making 1 call to File::Copy::__ANON__ |
14 | 2 | 42µs | 2 | 40µs | # spent 25µs (10+15) within File::Copy::BEGIN@14 which was called:
# once (10µs+15µs) by RBM::BEGIN@14 at line 14 # spent 25µs making 1 call to File::Copy::BEGIN@14
# spent 15µ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. | ||||
18 | 1 | 24µs | my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 }; # spent 4µs executing statements in string eval | ||
19 | # We want HiRes stat and utime if available | ||||
20 | 1 | 1.85ms | 1 | 3.06ms | # spent 3.06ms (44µs+3.02) within File::Copy::BEGIN@20 which was called:
# once (44µs+3.02ms) by RBM::BEGIN@14 at line 20 # spent 3.06ms making 1 call to File::Copy::BEGIN@20 # spent 1.27ms executing statements in string eval # includes 1.87ms spent executing 1 call to 1 sub defined therein. |
21 | our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); | ||||
22 | sub copy; | ||||
23 | sub syscopy; | ||||
24 | sub cp; | ||||
25 | sub mv; | ||||
26 | |||||
27 | 1 | 200ns | $VERSION = '2.33'; | ||
28 | |||||
29 | 1 | 600ns | require Exporter; | ||
30 | 1 | 7µs | @ISA = qw(Exporter); | ||
31 | 1 | 500ns | @EXPORT = qw(copy move); | ||
32 | 1 | 300ns | @EXPORT_OK = qw(cp mv); | ||
33 | |||||
34 | 1 | 100ns | $Too_Big = 1024 * 1024 * 2; | ||
35 | |||||
36 | sub croak { | ||||
37 | require Carp; | ||||
38 | goto &Carp::croak; | ||||
39 | } | ||||
40 | |||||
41 | sub carp { | ||||
42 | require Carp; | ||||
43 | goto &Carp::carp; | ||||
44 | } | ||||
45 | |||||
46 | sub _catname { | ||||
47 | my($from, $to) = @_; | ||||
48 | if (not defined &basename) { | ||||
49 | require File::Basename; | ||||
50 | import File::Basename 'basename'; | ||||
51 | } | ||||
52 | |||||
53 | return File::Spec->catfile($to, basename($from)); | ||||
54 | } | ||||
55 | |||||
56 | # _eq($from, $to) tells whether $from and $to are identical | ||||
57 | # spent 151µs (138+13) within File::Copy::_eq which was called 6 times, avg 25µs/call:
# 6 times (138µs+13µs) by File::Copy::copy at line 93, avg 25µs/call | ||||
58 | my ($from, $to) = map { | ||||
59 | 18 | 59µs | 12 | 13µs | $Scalar_Util_loaded && Scalar::Util::blessed($_) # spent 13µs making 12 calls to Scalar::Util::blessed, avg 1µs/call |
60 | && overload::Method($_, q{""}) | ||||
61 | ? "$_" | ||||
62 | : $_ | ||||
63 | } (@_); | ||||
64 | 6 | 6µs | return '' if ( (ref $from) xor (ref $to) ); | ||
65 | 6 | 3µs | return $from == $to if ref $from; | ||
66 | 6 | 29µs | return $from eq $to; | ||
67 | } | ||||
68 | |||||
69 | # spent 605ms (5.29+600) within File::Copy::copy which was called 6 times, avg 101ms/call:
# 6 times (5.29ms+600ms) by File::Copy::Recursive::fcopy at line 175 of File/Copy/Recursive.pm, avg 101ms/call | ||||
70 | 6 | 7µs | croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") | ||
71 | unless(@_ == 2 || @_ == 3); | ||||
72 | |||||
73 | 6 | 6µs | my $from = shift; | ||
74 | 6 | 6µs | my $to = shift; | ||
75 | |||||
76 | 6 | 3µs | my $size; | ||
77 | 6 | 4µs | if (@_) { | ||
78 | $size = shift(@_) + 0; | ||||
79 | croak("Bad buffer size for copy: $size\n") unless ($size > 0); | ||||
80 | } | ||||
81 | |||||
82 | 6 | 20µs | my $from_a_handle = (ref($from) | ||
83 | ? (ref($from) eq 'GLOB' | ||||
84 | || UNIVERSAL::isa($from, 'GLOB') | ||||
85 | || UNIVERSAL::isa($from, 'IO::Handle')) | ||||
86 | : (ref(\$from) eq 'GLOB')); | ||||
87 | 6 | 19µs | my $to_a_handle = (ref($to) | ||
88 | ? (ref($to) eq 'GLOB' | ||||
89 | || UNIVERSAL::isa($to, 'GLOB') | ||||
90 | || UNIVERSAL::isa($to, 'IO::Handle')) | ||||
91 | : (ref(\$to) eq 'GLOB')); | ||||
92 | |||||
93 | 6 | 86µs | 6 | 151µs | if (_eq($from, $to)) { # works for references, too # spent 151µs making 6 calls to File::Copy::_eq, avg 25µs/call |
94 | carp("'$from' and '$to' are identical (not copied)"); | ||||
95 | return 0; | ||||
96 | } | ||||
97 | |||||
98 | 6 | 37µs | 6 | 11µs | if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { # spent 11µs making 6 calls to File::Copy::CORE:ftdir, avg 2µs/call |
99 | $to = _catname($from, $to); | ||||
100 | } | ||||
101 | |||||
102 | 6 | 100µs | 12 | 46µs | if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && # spent 46µs making 12 calls to Config::FETCH, avg 4µs/call |
103 | !($^O eq 'MSWin32' || $^O eq 'os2')) { | ||||
104 | 6 | 120µs | 12 | 99µs | my @fs = stat($from); # spent 83µs making 6 calls to Time::HiRes::stat, avg 14µs/call
# spent 15µs making 6 calls to File::Copy::CORE:stat, avg 3µs/call |
105 | 6 | 8µs | if (@fs) { | ||
106 | 6 | 43µs | 12 | 31µs | my @ts = stat($to); # spent 24µs making 6 calls to Time::HiRes::stat, avg 4µs/call
# spent 8µs making 6 calls to File::Copy::CORE:stat, avg 1µs/call |
107 | 6 | 3µs | if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p $from) { | ||
108 | carp("'$from' and '$to' are identical (not copied)"); | ||||
109 | return 0; | ||||
110 | } | ||||
111 | } | ||||
112 | } | ||||
113 | elsif (_eq($from, $to)) { | ||||
114 | carp("'$from' and '$to' are identical (not copied)"); | ||||
115 | return 0; | ||||
116 | } | ||||
117 | |||||
118 | 6 | 10µs | if (defined &syscopy && !$Syscopy_is_copy | ||
119 | && !$to_a_handle | ||||
120 | && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles | ||||
121 | && !($from_a_handle && $^O eq 'MSWin32') | ||||
122 | && !($from_a_handle && $^O eq 'NetWare') | ||||
123 | ) | ||||
124 | { | ||||
125 | if ($^O eq 'VMS' && -e $from | ||||
126 | && ! -d $to && ! -d $from) { | ||||
127 | |||||
128 | # VMS natively inherits path components from the source of a | ||||
129 | # copy, but we want the Unixy behavior of inheriting from | ||||
130 | # the current working directory. Also, default in a trailing | ||||
131 | # dot for null file types. | ||||
132 | |||||
133 | $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.'); | ||||
134 | |||||
135 | # Get rid of the old versions to be like UNIX | ||||
136 | 1 while unlink $to; | ||||
137 | } | ||||
138 | |||||
139 | return syscopy($from, $to) || 0; | ||||
140 | } | ||||
141 | |||||
142 | 6 | 7µs | my $closefrom = 0; | ||
143 | 6 | 2µs | my $closeto = 0; | ||
144 | 6 | 2µs | my ($status, $r, $buf); | ||
145 | 6 | 31µs | local($\) = ''; | ||
146 | |||||
147 | 6 | 2µs | my $from_h; | ||
148 | 6 | 6µs | if ($from_a_handle) { | ||
149 | $from_h = $from; | ||||
150 | } else { | ||||
151 | 6 | 268µs | 6 | 201µs | open $from_h, "<", $from or goto fail_open1; # spent 201µs making 6 calls to File::Copy::CORE:open, avg 34µs/call |
152 | 6 | 33µs | 6 | 5µs | binmode $from_h or die "($!,$^E)"; # spent 5µs making 6 calls to File::Copy::CORE:binmode, avg 800ns/call |
153 | 6 | 4µs | $closefrom = 1; | ||
154 | } | ||||
155 | |||||
156 | # Seems most logical to do this here, in case future changes would want to | ||||
157 | # make this croak for some reason. | ||||
158 | 6 | 6µs | unless (defined $size) { | ||
159 | 6 | 42µs | 6 | 12µs | $size = tied(*$from_h) ? 0 : -s $from_h || 0; # spent 12µs making 6 calls to File::Copy::CORE:ftsize, avg 2µs/call |
160 | 6 | 2µs | $size = 1024 if ($size < 512); | ||
161 | 6 | 6µs | $size = $Too_Big if ($size > $Too_Big); | ||
162 | } | ||||
163 | |||||
164 | 6 | 2µs | my $to_h; | ||
165 | 6 | 5µs | if ($to_a_handle) { | ||
166 | $to_h = $to; | ||||
167 | } else { | ||||
168 | 12 | 24µs | $to_h = \do { local *FH }; # XXX is this line obsolete? | ||
169 | 6 | 278µs | 6 | 253µs | open $to_h, ">", $to or goto fail_open2; # spent 253µs making 6 calls to File::Copy::CORE:open, avg 42µs/call |
170 | 6 | 20µs | 6 | 2µs | binmode $to_h or die "($!,$^E)"; # spent 2µs making 6 calls to File::Copy::CORE:binmode, avg 417ns/call |
171 | 6 | 3µs | $closeto = 1; | ||
172 | } | ||||
173 | |||||
174 | 6 | 17µs | $! = 0; | ||
175 | 6 | 2µs | for (;;) { | ||
176 | 300 | 72µs | my ($r, $w, $t); | ||
177 | 300 | 223ms | 300 | 222ms | defined($r = sysread($from_h, $buf, $size)) # spent 222ms making 300 calls to File::Copy::CORE:sysread, avg 739µs/call |
178 | or goto fail_inner; | ||||
179 | 300 | 61µs | last unless $r; | ||
180 | 294 | 747µs | for ($w = 0; $w < $r; $w += $t) { | ||
181 | 294 | 379ms | 294 | 377ms | $t = syswrite($to_h, $buf, $r - $w, $w) # spent 377ms making 294 calls to File::Copy::CORE:syswrite, avg 1.28ms/call |
182 | or goto fail_inner; | ||||
183 | } | ||||
184 | } | ||||
185 | |||||
186 | 6 | 139µs | 6 | 82µs | close($to_h) || goto fail_open2 if $closeto; # spent 82µs making 6 calls to File::Copy::CORE:close, avg 14µs/call |
187 | 6 | 21µs | 6 | 6µs | close($from_h) || goto fail_open1 if $closefrom; # spent 6µs making 6 calls to File::Copy::CORE:close, avg 1µs/call |
188 | |||||
189 | # Use this idiom to avoid uninitialized value warning. | ||||
190 | 6 | 114µs | return 1; | ||
191 | |||||
192 | # All of these contortions try to preserve error messages... | ||||
193 | fail_inner: | ||||
194 | if ($closeto) { | ||||
195 | $status = $!; | ||||
196 | $! = 0; | ||||
197 | close $to_h; | ||||
198 | $! = $status unless $!; | ||||
199 | } | ||||
200 | fail_open2: | ||||
201 | if ($closefrom) { | ||||
202 | $status = $!; | ||||
203 | $! = 0; | ||||
204 | close $from_h; | ||||
205 | $! = $status unless $!; | ||||
206 | } | ||||
207 | fail_open1: | ||||
208 | return 0; | ||||
209 | } | ||||
210 | |||||
211 | sub cp { | ||||
212 | my($from,$to) = @_; | ||||
213 | my(@fromstat) = stat $from; | ||||
214 | my(@tostat) = stat $to; | ||||
215 | my $perm; | ||||
216 | |||||
217 | return 0 unless copy(@_) and @fromstat; | ||||
218 | |||||
219 | if (@tostat) { | ||||
220 | $perm = $tostat[2]; | ||||
221 | } else { | ||||
222 | $perm = $fromstat[2] & ~(umask || 0); | ||||
223 | @tostat = stat $to; | ||||
224 | } | ||||
225 | # Might be more robust to look for S_I* in Fcntl, but we're | ||||
226 | # trying to avoid dependence on any XS-containing modules, | ||||
227 | # since File::Copy is used during the Perl build. | ||||
228 | $perm &= 07777; | ||||
229 | if ($perm & 06000) { | ||||
230 | croak("Unable to check setuid/setgid permissions for $to: $!") | ||||
231 | unless @tostat; | ||||
232 | |||||
233 | if ($perm & 04000 and # setuid | ||||
234 | $fromstat[4] != $tostat[4]) { # owner must match | ||||
235 | $perm &= ~06000; | ||||
236 | } | ||||
237 | |||||
238 | if ($perm & 02000 && $> != 0) { # if not root, setgid | ||||
239 | my $ok = $fromstat[5] == $tostat[5]; # group must match | ||||
240 | if ($ok) { # and we must be in group | ||||
241 | $ok = grep { $_ == $fromstat[5] } split /\s+/, $) | ||||
242 | } | ||||
243 | $perm &= ~06000 unless $ok; | ||||
244 | } | ||||
245 | } | ||||
246 | return 0 unless @tostat; | ||||
247 | return 1 if $perm == ($tostat[2] & 07777); | ||||
248 | return eval { chmod $perm, $to; } ? 1 : 0; | ||||
249 | } | ||||
250 | |||||
251 | sub _move { | ||||
252 | croak("Usage: move(FROM, TO) ") unless @_ == 3; | ||||
253 | |||||
254 | my($from,$to,$fallback) = @_; | ||||
255 | |||||
256 | my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts); | ||||
257 | |||||
258 | if (-d $to && ! -d $from) { | ||||
259 | $to = _catname($from, $to); | ||||
260 | } | ||||
261 | |||||
262 | ($tosz1,$tomt1) = (stat($to))[7,9]; | ||||
263 | $fromsz = -s $from; | ||||
264 | if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) { | ||||
265 | # will not rename with overwrite | ||||
266 | unlink $to; | ||||
267 | } | ||||
268 | |||||
269 | if ($^O eq 'VMS' && -e $from | ||||
270 | && ! -d $to && ! -d $from) { | ||||
271 | |||||
272 | # VMS natively inherits path components from the source of a | ||||
273 | # copy, but we want the Unixy behavior of inheriting from | ||||
274 | # the current working directory. Also, default in a trailing | ||||
275 | # dot for null file types. | ||||
276 | |||||
277 | $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.'); | ||||
278 | |||||
279 | # Get rid of the old versions to be like UNIX | ||||
280 | 1 while unlink $to; | ||||
281 | } | ||||
282 | |||||
283 | return 1 if rename $from, $to; | ||||
284 | |||||
285 | # Did rename return an error even though it succeeded, because $to | ||||
286 | # is on a remote NFS file system, and NFS lost the server's ack? | ||||
287 | return 1 if defined($fromsz) && !-e $from && # $from disappeared | ||||
288 | (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there | ||||
289 | ((!defined $tosz1) || # not before or | ||||
290 | ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed | ||||
291 | $tosz2 == $fromsz; # it's all there | ||||
292 | |||||
293 | ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something | ||||
294 | |||||
295 | { | ||||
296 | local $@; | ||||
297 | eval { | ||||
298 | local $SIG{__DIE__}; | ||||
299 | $fallback->($from,$to) or die; | ||||
300 | my($atime, $mtime) = (stat($from))[8,9]; | ||||
301 | utime($atime, $mtime, $to); | ||||
302 | unlink($from) or die; | ||||
303 | }; | ||||
304 | return 1 unless $@; | ||||
305 | } | ||||
306 | ($sts,$ossts) = ($! + 0, $^E + 0); | ||||
307 | |||||
308 | ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; | ||||
309 | unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; | ||||
310 | ($!,$^E) = ($sts,$ossts); | ||||
311 | return 0; | ||||
312 | } | ||||
313 | |||||
314 | sub move { _move(@_,\©); } | ||||
315 | sub mv { _move(@_,\&cp); } | ||||
316 | |||||
317 | # &syscopy is an XSUB under OS/2 | ||||
318 | 1 | 500ns | unless (defined &syscopy) { | ||
319 | 1 | 2µs | if ($^O eq 'VMS') { | ||
320 | *syscopy = \&rmscopy; | ||||
321 | } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) { | ||||
322 | # Win32::CopyFile() fill only work if we can load Win32.xs | ||||
323 | *syscopy = sub { | ||||
324 | return 0 unless @_ == 2; | ||||
325 | return Win32::CopyFile(@_, 1); | ||||
326 | }; | ||||
327 | } else { | ||||
328 | 1 | 200ns | $Syscopy_is_copy = 1; | ||
329 | 1 | 2µs | *syscopy = \© | ||
330 | } | ||||
331 | } | ||||
332 | |||||
333 | 1 | 13µs | 1; | ||
334 | |||||
335 | __END__ | ||||
sub File::Copy::CORE:binmode; # opcode | |||||
sub File::Copy::CORE:close; # opcode | |||||
# spent 11µs within File::Copy::CORE:ftdir which was called 6 times, avg 2µs/call:
# 6 times (11µs+0s) by File::Copy::copy at line 98, avg 2µs/call | |||||
# spent 12µs within File::Copy::CORE:ftsize which was called 6 times, avg 2µs/call:
# 6 times (12µs+0s) by File::Copy::copy at line 159, avg 2µs/call | |||||
sub File::Copy::CORE:open; # opcode | |||||
sub File::Copy::CORE:stat; # opcode | |||||
# spent 222ms within File::Copy::CORE:sysread which was called 300 times, avg 739µs/call:
# 300 times (222ms+0s) by File::Copy::copy at line 177, avg 739µs/call | |||||
# spent 377ms within File::Copy::CORE:syswrite which was called 294 times, avg 1.28ms/call:
# 294 times (377ms+0s) by File::Copy::copy at line 181, avg 1.28ms/call | |||||
# spent 700ns within File::Copy::__ANON__ which was called:
# once (700ns+0s) by File::Copy::BEGIN@13 at line 13 |