← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:09 2021

Filename/usr/local/lib/perl5/5.32/File/Copy.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sFile::Copy::::BEGIN@10File::Copy::BEGIN@10
0000s0sFile::Copy::::BEGIN@11File::Copy::BEGIN@11
0000s0sFile::Copy::::BEGIN@12File::Copy::BEGIN@12
0000s0sFile::Copy::::BEGIN@12.22File::Copy::BEGIN@12.22
0000s0sFile::Copy::::BEGIN@13File::Copy::BEGIN@13
0000s0sFile::Copy::::BEGIN@14File::Copy::BEGIN@14
0000s0sFile::Copy::::BEGIN@20File::Copy::BEGIN@20
0000s0sFile::Copy::::__ANON__File::Copy::__ANON__ (xsub)
0000s0sFile::Copy::::__ANON__[:326]File::Copy::__ANON__[:326]
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
10use 5.006;
11use strict;
12use warnings; no warnings 'newline';
13use File::Spec;
14use Config;
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.
18my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
# spent 0s executing statements in string eval
19# We want HiRes stat and utime if available
20BEGIN { eval q{ use Time::HiRes qw( stat utime ) } };
# spent 0s executing statements in string eval
21our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
22sub copy;
23sub syscopy;
24sub cp;
25sub mv;
26
27$VERSION = '2.34';
28
29require Exporter;
30@ISA = qw(Exporter);
31@EXPORT = qw(copy move);
32@EXPORT_OK = qw(cp mv);
33
34$Too_Big = 1024 * 1024 * 2;
35
36sub croak {
37 require Carp;
38 goto &Carp::croak;
39}
40
41sub carp {
42 require Carp;
43 goto &Carp::carp;
44}
45
46sub _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
57sub _eq {
58 my ($from, $to) = map {
59 $Scalar_Util_loaded && Scalar::Util::blessed($_)
60 && overload::Method($_, q{""})
61 ? "$_"
62 : $_
63 } (@_);
64 return '' if ( (ref $from) xor (ref $to) );
65 return $from == $to if ref $from;
66 return $from eq $to;
67}
68
69sub copy {
70 croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
71 unless(@_ == 2 || @_ == 3);
72
73 my $from = shift;
74 my $to = shift;
75
76 my $size;
77 if (@_) {
78 $size = shift(@_) + 0;
79 croak("Bad buffer size for copy: $size\n") unless ($size > 0);
80 }
81
82 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 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 if (_eq($from, $to)) { # works for references, too
94 carp("'$from' and '$to' are identical (not copied)");
95 return 0;
96 }
97
98 if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
99 $to = _catname($from, $to);
100 }
101
102 if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
103 !($^O eq 'MSWin32' || $^O eq 'os2')) {
104 my @fs = stat($from);
105 if (@fs) {
106 my @ts = stat($to);
107 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 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 my $closefrom = 0;
143 my $closeto = 0;
144 my ($status, $r, $buf);
145 local($\) = '';
146
147 my $from_h;
148 if ($from_a_handle) {
149 $from_h = $from;
150 } else {
151 open $from_h, "<", $from or goto fail_open1;
152 binmode $from_h or die "($!,$^E)";
153 $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 unless (defined $size) {
159 $size = tied(*$from_h) ? 0 : -s $from_h || 0;
160 $size = 1024 if ($size < 512);
161 $size = $Too_Big if ($size > $Too_Big);
162 }
163
164 my $to_h;
165 if ($to_a_handle) {
166 $to_h = $to;
167 } else {
168 $to_h = \do { local *FH }; # XXX is this line obsolete?
169 open $to_h, ">", $to or goto fail_open2;
170 binmode $to_h or die "($!,$^E)";
171 $closeto = 1;
172 }
173
174 $! = 0;
175 for (;;) {
176 my ($r, $w, $t);
177 defined($r = sysread($from_h, $buf, $size))
178 or goto fail_inner;
179 last unless $r;
180 for ($w = 0; $w < $r; $w += $t) {
181 $t = syswrite($to_h, $buf, $r - $w, $w)
182 or goto fail_inner;
183 }
184 }
185
186 close($to_h) || goto fail_open2 if $closeto;
187 close($from_h) || goto fail_open1 if $closefrom;
188
189 # Use this idiom to avoid uninitialized value warning.
190 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
211sub 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
251sub _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
314sub move { _move(@_,\&copy); }
315sub mv { _move(@_,\&cp); }
316
317# &syscopy is an XSUB under OS/2
318unless (defined &syscopy) {
319 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 $Syscopy_is_copy = 1;
329 *syscopy = \&copy;
330 }
331}
332
3331;
334
335__END__