Filename | /Users/ap13/perl5/perlbrew/perls/perl-5.16.2/lib/5.16.2/File/Copy.pm |
Statements | Executed 27 statements in 2.39ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 2.40ms | 3.17ms | BEGIN@13 | File::Copy::
1 | 1 | 1 | 30µs | 30µs | BEGIN@10 | File::Copy::
1 | 1 | 1 | 17µs | 38µs | BEGIN@12.1 | File::Copy::
1 | 1 | 1 | 14µs | 41µs | BEGIN@11 | File::Copy::
1 | 1 | 1 | 14µs | 35µs | BEGIN@12 | File::Copy::
1 | 1 | 1 | 12µs | 25µs | BEGIN@14 | File::Copy::
1 | 1 | 1 | 4µs | 4µs | BEGIN@47 | File::Copy::
0 | 0 | 0 | 0s | 0s | __ANON__[:419] | File::Copy::
0 | 0 | 0 | 0s | 0s | __ANON__[:425] | 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 | _vms_efs | File::Copy::
0 | 0 | 0 | 0s | 0s | _vms_unix_rpt | 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 | 74µs | 1 | 30µs | # spent 30µs within File::Copy::BEGIN@10 which was called:
# once (30µs+0s) by Bio::Roary::PostAnalysis::BEGIN@12 at line 10 # spent 30µs making 1 call to File::Copy::BEGIN@10 |
11 | 2 | 42µs | 2 | 67µs | # spent 41µs (14+26) within File::Copy::BEGIN@11 which was called:
# once (14µs+26µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 11 # spent 41µs making 1 call to File::Copy::BEGIN@11
# spent 26µs making 1 call to strict::import |
12 | 4 | 107µs | 4 | 112µs | use warnings; no warnings 'newline'; # spent 38µs making 1 call to File::Copy::BEGIN@12.1
# spent 35µs making 1 call to File::Copy::BEGIN@12
# spent 20µs making 1 call to warnings::unimport
# spent 20µs making 1 call to warnings::import |
13 | 2 | 163µs | 1 | 3.17ms | # spent 3.17ms (2.40+776µs) within File::Copy::BEGIN@13 which was called:
# once (2.40ms+776µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 13 # spent 3.17ms making 1 call to File::Copy::BEGIN@13 |
14 | 2 | 173µs | 2 | 38µs | # spent 25µs (12+13) within File::Copy::BEGIN@14 which was called:
# once (12µs+13µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 14 # spent 25µs making 1 call to File::Copy::BEGIN@14
# spent 13µ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 | 20µs | my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 }; # spent 5µs executing statements in string eval | ||
19 | 1 | 600ns | our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); | ||
20 | sub copy; | ||||
21 | sub syscopy; | ||||
22 | sub cp; | ||||
23 | sub mv; | ||||
24 | |||||
25 | 1 | 500ns | $VERSION = '2.23'; | ||
26 | |||||
27 | 1 | 800ns | require Exporter; | ||
28 | 1 | 8µs | @ISA = qw(Exporter); | ||
29 | 1 | 800ns | @EXPORT = qw(copy move); | ||
30 | 1 | 500ns | @EXPORT_OK = qw(cp mv); | ||
31 | |||||
32 | 1 | 200ns | $Too_Big = 1024 * 1024 * 2; | ||
33 | |||||
34 | sub croak { | ||||
35 | require Carp; | ||||
36 | goto &Carp::croak; | ||||
37 | } | ||||
38 | |||||
39 | sub carp { | ||||
40 | require Carp; | ||||
41 | goto &Carp::carp; | ||||
42 | } | ||||
43 | |||||
44 | # Look up the feature settings on VMS using VMS::Feature when available. | ||||
45 | |||||
46 | 1 | 100ns | my $use_vms_feature = 0; | ||
47 | # spent 4µs within File::Copy::BEGIN@47 which was called:
# once (4µs+0s) by Bio::Roary::PostAnalysis::BEGIN@12 at line 53 | ||||
48 | 1 | 5µs | if ($^O eq 'VMS') { | ||
49 | if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { | ||||
50 | $use_vms_feature = 1; | ||||
51 | } | ||||
52 | } | ||||
53 | 1 | 1.77ms | 1 | 4µs | } # spent 4µs making 1 call to File::Copy::BEGIN@47 |
54 | |||||
55 | # Need to look up the UNIX report mode. This may become a dynamic mode | ||||
56 | # in the future. | ||||
57 | sub _vms_unix_rpt { | ||||
58 | my $unix_rpt; | ||||
59 | if ($use_vms_feature) { | ||||
60 | $unix_rpt = VMS::Feature::current("filename_unix_report"); | ||||
61 | } else { | ||||
62 | my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; | ||||
63 | $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; | ||||
64 | } | ||||
65 | return $unix_rpt; | ||||
66 | } | ||||
67 | |||||
68 | # Need to look up the EFS character set mode. This may become a dynamic | ||||
69 | # mode in the future. | ||||
70 | sub _vms_efs { | ||||
71 | my $efs; | ||||
72 | if ($use_vms_feature) { | ||||
73 | $efs = VMS::Feature::current("efs_charset"); | ||||
74 | } else { | ||||
75 | my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; | ||||
76 | $efs = $env_efs =~ /^[ET1]/i; | ||||
77 | } | ||||
78 | return $efs; | ||||
79 | } | ||||
80 | |||||
81 | |||||
82 | sub _catname { | ||||
83 | my($from, $to) = @_; | ||||
84 | if (not defined &basename) { | ||||
85 | require File::Basename; | ||||
86 | import File::Basename 'basename'; | ||||
87 | } | ||||
88 | |||||
89 | return File::Spec->catfile($to, basename($from)); | ||||
90 | } | ||||
91 | |||||
92 | # _eq($from, $to) tells whether $from and $to are identical | ||||
93 | sub _eq { | ||||
94 | my ($from, $to) = map { | ||||
95 | $Scalar_Util_loaded && Scalar::Util::blessed($_) | ||||
96 | && overload::Method($_, q{""}) | ||||
97 | ? "$_" | ||||
98 | : $_ | ||||
99 | } (@_); | ||||
100 | return '' if ( (ref $from) xor (ref $to) ); | ||||
101 | return $from == $to if ref $from; | ||||
102 | return $from eq $to; | ||||
103 | } | ||||
104 | |||||
105 | sub copy { | ||||
106 | croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") | ||||
107 | unless(@_ == 2 || @_ == 3); | ||||
108 | |||||
109 | my $from = shift; | ||||
110 | my $to = shift; | ||||
111 | |||||
112 | my $size; | ||||
113 | if (@_) { | ||||
114 | $size = shift(@_) + 0; | ||||
115 | croak("Bad buffer size for copy: $size\n") unless ($size > 0); | ||||
116 | } | ||||
117 | |||||
118 | my $from_a_handle = (ref($from) | ||||
119 | ? (ref($from) eq 'GLOB' | ||||
120 | || UNIVERSAL::isa($from, 'GLOB') | ||||
121 | || UNIVERSAL::isa($from, 'IO::Handle')) | ||||
122 | : (ref(\$from) eq 'GLOB')); | ||||
123 | my $to_a_handle = (ref($to) | ||||
124 | ? (ref($to) eq 'GLOB' | ||||
125 | || UNIVERSAL::isa($to, 'GLOB') | ||||
126 | || UNIVERSAL::isa($to, 'IO::Handle')) | ||||
127 | : (ref(\$to) eq 'GLOB')); | ||||
128 | |||||
129 | if (_eq($from, $to)) { # works for references, too | ||||
130 | carp("'$from' and '$to' are identical (not copied)"); | ||||
131 | # The "copy" was a success as the source and destination contain | ||||
132 | # the same data. | ||||
133 | return 1; | ||||
134 | } | ||||
135 | |||||
136 | if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && | ||||
137 | !($^O eq 'MSWin32' || $^O eq 'os2')) { | ||||
138 | my @fs = stat($from); | ||||
139 | if (@fs) { | ||||
140 | my @ts = stat($to); | ||||
141 | if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p $from) { | ||||
142 | carp("'$from' and '$to' are identical (not copied)"); | ||||
143 | return 0; | ||||
144 | } | ||||
145 | } | ||||
146 | } | ||||
147 | |||||
148 | if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { | ||||
149 | $to = _catname($from, $to); | ||||
150 | } | ||||
151 | |||||
152 | if (defined &syscopy && !$Syscopy_is_copy | ||||
153 | && !$to_a_handle | ||||
154 | && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles | ||||
155 | && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. | ||||
156 | && !($from_a_handle && $^O eq 'MSWin32') | ||||
157 | && !($from_a_handle && $^O eq 'NetWare') | ||||
158 | ) | ||||
159 | { | ||||
160 | my $copy_to = $to; | ||||
161 | |||||
162 | if ($^O eq 'VMS' && -e $from) { | ||||
163 | |||||
164 | if (! -d $to && ! -d $from) { | ||||
165 | |||||
166 | my $vms_efs = _vms_efs(); | ||||
167 | my $unix_rpt = _vms_unix_rpt(); | ||||
168 | my $unix_mode = 0; | ||||
169 | my $from_unix = 0; | ||||
170 | $from_unix = 1 if ($from =~ /^\.\.?$/); | ||||
171 | my $from_vms = 0; | ||||
172 | $from_vms = 1 if ($from =~ m#[\[<\]]#); | ||||
173 | |||||
174 | # Need to know if we are in Unix mode. | ||||
175 | if ($from_vms == $from_unix) { | ||||
176 | $unix_mode = $unix_rpt; | ||||
177 | } else { | ||||
178 | $unix_mode = $from_unix; | ||||
179 | } | ||||
180 | |||||
181 | # VMS has sticky defaults on extensions, which means that | ||||
182 | # if there is a null extension on the destination file, it | ||||
183 | # will inherit the extension of the source file | ||||
184 | # So add a '.' for a null extension. | ||||
185 | |||||
186 | # In unix_rpt mode, the trailing dot should not be added. | ||||
187 | |||||
188 | if ($vms_efs) { | ||||
189 | $copy_to = $to; | ||||
190 | } else { | ||||
191 | $copy_to = VMS::Filespec::vmsify($to); | ||||
192 | } | ||||
193 | my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to); | ||||
194 | $file = $file . '.' | ||||
195 | unless (($file =~ /(?<!\^)\./) || $unix_rpt); | ||||
196 | $copy_to = File::Spec->catpath($vol, $dirs, $file); | ||||
197 | |||||
198 | # Get rid of the old versions to be like UNIX | ||||
199 | 1 while unlink $copy_to; | ||||
200 | } | ||||
201 | } | ||||
202 | |||||
203 | return syscopy($from, $copy_to) || 0; | ||||
204 | } | ||||
205 | |||||
206 | my $closefrom = 0; | ||||
207 | my $closeto = 0; | ||||
208 | my ($status, $r, $buf); | ||||
209 | local($\) = ''; | ||||
210 | |||||
211 | my $from_h; | ||||
212 | if ($from_a_handle) { | ||||
213 | $from_h = $from; | ||||
214 | } else { | ||||
215 | open $from_h, "<", $from or goto fail_open1; | ||||
216 | binmode $from_h or die "($!,$^E)"; | ||||
217 | $closefrom = 1; | ||||
218 | } | ||||
219 | |||||
220 | # Seems most logical to do this here, in case future changes would want to | ||||
221 | # make this croak for some reason. | ||||
222 | unless (defined $size) { | ||||
223 | $size = tied(*$from_h) ? 0 : -s $from_h || 0; | ||||
224 | $size = 1024 if ($size < 512); | ||||
225 | $size = $Too_Big if ($size > $Too_Big); | ||||
226 | } | ||||
227 | |||||
228 | my $to_h; | ||||
229 | if ($to_a_handle) { | ||||
230 | $to_h = $to; | ||||
231 | } else { | ||||
232 | $to_h = \do { local *FH }; # XXX is this line obsolete? | ||||
233 | open $to_h, ">", $to or goto fail_open2; | ||||
234 | binmode $to_h or die "($!,$^E)"; | ||||
235 | $closeto = 1; | ||||
236 | } | ||||
237 | |||||
238 | $! = 0; | ||||
239 | for (;;) { | ||||
240 | my ($r, $w, $t); | ||||
241 | defined($r = sysread($from_h, $buf, $size)) | ||||
242 | or goto fail_inner; | ||||
243 | last unless $r; | ||||
244 | for ($w = 0; $w < $r; $w += $t) { | ||||
245 | $t = syswrite($to_h, $buf, $r - $w, $w) | ||||
246 | or goto fail_inner; | ||||
247 | } | ||||
248 | } | ||||
249 | |||||
250 | close($to_h) || goto fail_open2 if $closeto; | ||||
251 | close($from_h) || goto fail_open1 if $closefrom; | ||||
252 | |||||
253 | # Use this idiom to avoid uninitialized value warning. | ||||
254 | return 1; | ||||
255 | |||||
256 | # All of these contortions try to preserve error messages... | ||||
257 | fail_inner: | ||||
258 | if ($closeto) { | ||||
259 | $status = $!; | ||||
260 | $! = 0; | ||||
261 | close $to_h; | ||||
262 | $! = $status unless $!; | ||||
263 | } | ||||
264 | fail_open2: | ||||
265 | if ($closefrom) { | ||||
266 | $status = $!; | ||||
267 | $! = 0; | ||||
268 | close $from_h; | ||||
269 | $! = $status unless $!; | ||||
270 | } | ||||
271 | fail_open1: | ||||
272 | return 0; | ||||
273 | } | ||||
274 | |||||
275 | sub cp { | ||||
276 | my($from,$to) = @_; | ||||
277 | my(@fromstat) = stat $from; | ||||
278 | my(@tostat) = stat $to; | ||||
279 | my $perm; | ||||
280 | |||||
281 | return 0 unless copy(@_) and @fromstat; | ||||
282 | |||||
283 | if (@tostat) { | ||||
284 | $perm = $tostat[2]; | ||||
285 | } else { | ||||
286 | $perm = $fromstat[2] & ~(umask || 0); | ||||
287 | @tostat = stat $to; | ||||
288 | } | ||||
289 | # Might be more robust to look for S_I* in Fcntl, but we're | ||||
290 | # trying to avoid dependence on any XS-containing modules, | ||||
291 | # since File::Copy is used during the Perl build. | ||||
292 | $perm &= 07777; | ||||
293 | if ($perm & 06000) { | ||||
294 | croak("Unable to check setuid/setgid permissions for $to: $!") | ||||
295 | unless @tostat; | ||||
296 | |||||
297 | if ($perm & 04000 and # setuid | ||||
298 | $fromstat[4] != $tostat[4]) { # owner must match | ||||
299 | $perm &= ~06000; | ||||
300 | } | ||||
301 | |||||
302 | if ($perm & 02000 && $> != 0) { # if not root, setgid | ||||
303 | my $ok = $fromstat[5] == $tostat[5]; # group must match | ||||
304 | if ($ok) { # and we must be in group | ||||
305 | $ok = grep { $_ == $fromstat[5] } split /\s+/, $) | ||||
306 | } | ||||
307 | $perm &= ~06000 unless $ok; | ||||
308 | } | ||||
309 | } | ||||
310 | return 0 unless @tostat; | ||||
311 | return 1 if $perm == ($tostat[2] & 07777); | ||||
312 | return eval { chmod $perm, $to; } ? 1 : 0; | ||||
313 | } | ||||
314 | |||||
315 | sub _move { | ||||
316 | croak("Usage: move(FROM, TO) ") unless @_ == 3; | ||||
317 | |||||
318 | my($from,$to,$fallback) = @_; | ||||
319 | |||||
320 | my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts); | ||||
321 | |||||
322 | if (-d $to && ! -d $from) { | ||||
323 | $to = _catname($from, $to); | ||||
324 | } | ||||
325 | |||||
326 | ($tosz1,$tomt1) = (stat($to))[7,9]; | ||||
327 | $fromsz = -s $from; | ||||
328 | if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) { | ||||
329 | # will not rename with overwrite | ||||
330 | unlink $to; | ||||
331 | } | ||||
332 | |||||
333 | my $rename_to = $to; | ||||
334 | if (-$^O eq 'VMS' && -e $from) { | ||||
335 | |||||
336 | if (! -d $to && ! -d $from) { | ||||
337 | |||||
338 | my $vms_efs = _vms_efs(); | ||||
339 | my $unix_rpt = _vms_unix_rpt(); | ||||
340 | my $unix_mode = 0; | ||||
341 | my $from_unix = 0; | ||||
342 | $from_unix = 1 if ($from =~ /^\.\.?$/); | ||||
343 | my $from_vms = 0; | ||||
344 | $from_vms = 1 if ($from =~ m#[\[<\]]#); | ||||
345 | |||||
346 | # Need to know if we are in Unix mode. | ||||
347 | if ($from_vms == $from_unix) { | ||||
348 | $unix_mode = $unix_rpt; | ||||
349 | } else { | ||||
350 | $unix_mode = $from_unix; | ||||
351 | } | ||||
352 | |||||
353 | # VMS has sticky defaults on extensions, which means that | ||||
354 | # if there is a null extension on the destination file, it | ||||
355 | # will inherit the extension of the source file | ||||
356 | # So add a '.' for a null extension. | ||||
357 | |||||
358 | # In unix_rpt mode, the trailing dot should not be added. | ||||
359 | |||||
360 | if ($vms_efs) { | ||||
361 | $rename_to = $to; | ||||
362 | } else { | ||||
363 | $rename_to = VMS::Filespec::vmsify($to); | ||||
364 | } | ||||
365 | my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to); | ||||
366 | $file = $file . '.' | ||||
367 | unless (($file =~ /(?<!\^)\./) || $unix_rpt); | ||||
368 | $rename_to = File::Spec->catpath($vol, $dirs, $file); | ||||
369 | |||||
370 | # Get rid of the old versions to be like UNIX | ||||
371 | 1 while unlink $rename_to; | ||||
372 | } | ||||
373 | } | ||||
374 | |||||
375 | return 1 if rename $from, $rename_to; | ||||
376 | |||||
377 | # Did rename return an error even though it succeeded, because $to | ||||
378 | # is on a remote NFS file system, and NFS lost the server's ack? | ||||
379 | return 1 if defined($fromsz) && !-e $from && # $from disappeared | ||||
380 | (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there | ||||
381 | ((!defined $tosz1) || # not before or | ||||
382 | ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed | ||||
383 | $tosz2 == $fromsz; # it's all there | ||||
384 | |||||
385 | ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something | ||||
386 | |||||
387 | { | ||||
388 | local $@; | ||||
389 | eval { | ||||
390 | local $SIG{__DIE__}; | ||||
391 | $fallback->($from,$to) or die; | ||||
392 | my($atime, $mtime) = (stat($from))[8,9]; | ||||
393 | utime($atime, $mtime, $to); | ||||
394 | unlink($from) or die; | ||||
395 | }; | ||||
396 | return 1 unless $@; | ||||
397 | } | ||||
398 | ($sts,$ossts) = ($! + 0, $^E + 0); | ||||
399 | |||||
400 | ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; | ||||
401 | unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; | ||||
402 | ($!,$^E) = ($sts,$ossts); | ||||
403 | return 0; | ||||
404 | } | ||||
405 | |||||
406 | sub move { _move(@_,\©); } | ||||
407 | sub mv { _move(@_,\&cp); } | ||||
408 | |||||
409 | # &syscopy is an XSUB under OS/2 | ||||
410 | 1 | 900ns | unless (defined &syscopy) { | ||
411 | 1 | 2µs | if ($^O eq 'VMS') { | ||
412 | *syscopy = \&rmscopy; | ||||
413 | } elsif ($^O eq 'mpeix') { | ||||
414 | *syscopy = sub { | ||||
415 | return 0 unless @_ == 2; | ||||
416 | # Use the MPE cp program in order to | ||||
417 | # preserve MPE file attributes. | ||||
418 | return system('/bin/cp', '-f', $_[0], $_[1]) == 0; | ||||
419 | }; | ||||
420 | } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) { | ||||
421 | # Win32::CopyFile() fill only work if we can load Win32.xs | ||||
422 | *syscopy = sub { | ||||
423 | return 0 unless @_ == 2; | ||||
424 | return Win32::CopyFile(@_, 1); | ||||
425 | }; | ||||
426 | } else { | ||||
427 | 1 | 100ns | $Syscopy_is_copy = 1; | ||
428 | 1 | 2µs | *syscopy = \© | ||
429 | } | ||||
430 | } | ||||
431 | |||||
432 | 1 | 26µs | 1; | ||
433 | |||||
434 | __END__ |