Filename | /usr/local/lib/perl5/5.32/File/Copy.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN@10 | File::Copy::
0 | 0 | 0 | 0s | 0s | BEGIN@11 | File::Copy::
0 | 0 | 0 | 0s | 0s | BEGIN@12 | File::Copy::
0 | 0 | 0 | 0s | 0s | BEGIN@12.22 | File::Copy::
0 | 0 | 0 | 0s | 0s | BEGIN@13 | File::Copy::
0 | 0 | 0 | 0s | 0s | BEGIN@14 | File::Copy::
0 | 0 | 0 | 0s | 0s | BEGIN@20 | File::Copy::
0 | 0 | 0 | 0s | 0s | __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 | _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 | use 5.006; | ||||
11 | use strict; | ||||
12 | use warnings; no warnings 'newline'; | ||||
13 | use File::Spec; | ||||
14 | use 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. | ||||
18 | my $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 | ||||
20 | BEGIN { eval q{ use Time::HiRes qw( stat utime ) } }; # spent 0s executing statements in string eval | ||||
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 | $VERSION = '2.34'; | ||||
28 | |||||
29 | require Exporter; | ||||
30 | @ISA = qw(Exporter); | ||||
31 | @EXPORT = qw(copy move); | ||||
32 | @EXPORT_OK = qw(cp mv); | ||||
33 | |||||
34 | $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 | sub _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 | |||||
69 | sub 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 | |||||
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 | unless (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 = \© | ||||
330 | } | ||||
331 | } | ||||
332 | |||||
333 | 1; | ||||
334 | |||||
335 | __END__ |