Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/File/Copy.pm |
Statements | Executed 30 statements in 1.16ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 78µs | 111µs | BEGIN@14 | File::Copy::
1 | 1 | 1 | 21µs | 101µs | BEGIN@19 | File::Copy::
1 | 1 | 1 | 11µs | 11µs | BEGIN@10 | File::Copy::
1 | 1 | 1 | 5µs | 6µs | BEGIN@16 | File::Copy::
1 | 1 | 1 | 4µs | 5µs | BEGIN@11 | File::Copy::
1 | 1 | 1 | 3µs | 12µs | BEGIN@12.1 | File::Copy::
1 | 1 | 1 | 3µs | 10µs | BEGIN@15 | File::Copy::
1 | 1 | 1 | 3µs | 8µs | BEGIN@17 | File::Copy::
1 | 1 | 1 | 3µs | 20µs | BEGIN@12 | File::Copy::
1 | 1 | 1 | 3µs | 8µs | BEGIN@13 | File::Copy::
1 | 1 | 1 | 300ns | 300ns | __ANON__ (xsub) | File::Copy::
0 | 0 | 0 | 0s | 0s | __ANON__[:323] | File::Copy::
0 | 0 | 0 | 0s | 0s | _catname | File::Copy::
0 | 0 | 0 | 0s | 0s | _eq | File::Copy::
0 | 0 | 0 | 0s | 0s | _move | File::Copy::
0 | 0 | 0 | 0s | 0s | carp | File::Copy::
0 | 0 | 0 | 0s | 0s | copy | 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 | 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 # 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 # 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 | 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 # 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 # 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 # 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 # 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 # 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 # 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(@_,\©); } | ||||
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 = \© | ||
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 |