Profile of File/Copy.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

Filename | /usr/share/perl/5.18/File/Copy.pm
Statements | Executed 27 statements in 1.91ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 14µs | 14µs | File::Copy::::BEGIN@10File::Copy::BEGIN@10
1 | 1 | 1 | 7µs | 17µs | File::Copy::::BEGIN@14File::Copy::BEGIN@14
1 | 1 | 1 | 7µs | 19µs | File::Copy::::BEGIN@12.11File::Copy::BEGIN@12.11
1 | 1 | 1 | 6µs | 10µs | File::Copy::::BEGIN@12File::Copy::BEGIN@12
1 | 1 | 1 | 5µs | 15µs | File::Copy::::BEGIN@11File::Copy::BEGIN@11
1 | 1 | 1 | 4µs | 4µs | File::Copy::::BEGIN@13File::Copy::BEGIN@13
1 | 1 | 1 | 3µs | 3µs | File::Copy::::BEGIN@47File::Copy::BEGIN@47
0 | 0 | 0 | 0s | 0s | File::Copy::::__ANON__[:419]File::Copy::__ANON__[:419]
0 | 0 | 0 | 0s | 0s | File::Copy::::_catnameFile::Copy::_catname
0 | 0 | 0 | 0s | 0s | File::Copy::::_eqFile::Copy::_eq
0 | 0 | 0 | 0s | 0s | File::Copy::::_moveFile::Copy::_move
0 | 0 | 0 | 0s | 0s | File::Copy::::_vms_efsFile::Copy::_vms_efs
0 | 0 | 0 | 0s | 0s | File::Copy::::_vms_unix_rptFile::Copy::_vms_unix_rpt
0 | 0 | 0 | 0s | 0s | File::Copy::::carpFile::Copy::carp
0 | 0 | 0 | 0s | 0s | File::Copy::::copyFile::Copy::copy
0 | 0 | 0 | 0s | 0s | File::Copy::::cpFile::Copy::cp
0 | 0 | 0 | 0s | 0s | File::Copy::::croakFile::Copy::croak
0 | 0 | 0 | 0s | 0s | File::Copy::::moveFile::Copy::move
0 | 0 | 0 | 0s | 0s | File::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 |  |  |  |  |
8 |  |  |  |  | package File::Copy;
9 |  |  |  |  |
10 | 2 | 37µs | 1 | 14µs | # spent 14µs within File::Copy::BEGIN@10 which was called: # once (14µs+0s) by Path::Class::File::BEGIN@14 at line 10 use 5.006; # spent 14µs making 1 call to File::Copy::BEGIN@10
11 | 2 | 18µs | 2 | 24µs | # spent 15µs (5+10) within File::Copy::BEGIN@11 which was called: # once (5µs+10µs) by Path::Class::File::BEGIN@14 at line 11 use strict; # spent 15µs making 1 call to File::Copy::BEGIN@11 # spent 10µs making 1 call to strict::import
12 | 4 | 36µs | 4 | 45µs | # spent 19µs (7+12) within File::Copy::BEGIN@12.11 which was called: # once (7µs+12µs) by Path::Class::File::BEGIN@14 at line 12 # spent 10µs (6+4) within File::Copy::BEGIN@12 which was called: # once (6µs+4µs) by Path::Class::File::BEGIN@14 at line 12 use warnings; no warnings 'newline'; # spent 19µs making 1 call to File::Copy::BEGIN@12.11 # spent 12µs making 1 call to warnings::unimport # spent 10µs making 1 call to File::Copy::BEGIN@12 # spent 4µs making 1 call to warnings::import
13 | 2 | 17µs | 1 | 4µs | # spent 4µs within File::Copy::BEGIN@13 which was called: # once (4µs+0s) by Path::Class::File::BEGIN@14 at line 13 use File::Spec; # spent 4µs making 1 call to File::Copy::BEGIN@13
14 | 2 | 157µs | 2 | 27µs | # spent 17µs (7+10) within File::Copy::BEGIN@14 which was called: # once (7µs+10µs) by Path::Class::File::BEGIN@14 at line 14 use Config; # spent 17µs making 1 call to File::Copy::BEGIN@14 # spent 10µ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 | 18µs |  |  | my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 }; # spent 3µs executing statements in string eval
19 | 1 | 2µs |  |  | 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 | 200ns |  |  | $VERSION = '2.26';
26 |  |  |  |  |
27 | 1 | 300ns |  |  | require Exporter;
28 | 1 | 4µs |  |  | @ISA = qw(Exporter);
29 | 1 | 500ns |  |  | @EXPORT = qw(copy move);
30 | 1 | 300ns |  |  | @EXPORT_OK = qw(cp mv);
31 |  |  |  |  |
32 | 1 | 100ns |  |  | $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 3µs within File::Copy::BEGIN@47 which was called: # once (3µs+0s) by Path::Class::File::BEGIN@14 at line 53 BEGIN {
48 | 1 | 6µs |  |  | if ($^O eq 'VMS') {
49 |  |  |  |  | if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
50 |  |  |  |  | $use_vms_feature = 1;
51 |  |  |  |  | }
52 |  |  |  |  | }
53 | 1 | 1.61ms | 1 | 3µs | } # spent 3µ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 |  |  |  |  | return 0;
132 |  |  |  |  | }
133 |  |  |  |  |
134 |  |  |  |  | if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
135 |  |  |  |  | $to = _catname($from, $to);
136 |  |  |  |  | }
137 |  |  |  |  |
138 |  |  |  |  | if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
139 |  |  |  |  | !($^O eq 'MSWin32' || $^O eq 'os2')) {
140 |  |  |  |  | my @fs = stat($from);
141 |  |  |  |  | if (@fs) {
142 |  |  |  |  | my @ts = stat($to);
143 |  |  |  |  | if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p $from) {
144 |  |  |  |  | carp("'$from' and '$to' are identical (not copied)");
145 |  |  |  |  | return 0;
146 |  |  |  |  | }
147 |  |  |  |  | }
148 |  |  |  |  | }
149 |  |  |  |  | elsif (_eq($from, $to)) {
150 |  |  |  |  | carp("'$from' and '$to' are identical (not copied)");
151 |  |  |  |  | return 0;
152 |  |  |  |  | }
153 |  |  |  |  |
154 |  |  |  |  | if (defined &syscopy && !$Syscopy_is_copy
155 |  |  |  |  | && !$to_a_handle
156 |  |  |  |  | && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles
157 |  |  |  |  | && !($from_a_handle && $^O eq 'MSWin32')
158 |  |  |  |  | && !($from_a_handle && $^O eq 'NetWare')
159 |  |  |  |  | )
160 |  |  |  |  | {
161 |  |  |  |  | my $copy_to = $to;
162 |  |  |  |  |
163 |  |  |  |  | if ($^O eq 'VMS' && -e $from) {
164 |  |  |  |  |
165 |  |  |  |  | if (! -d $to && ! -d $from) {
166 |  |  |  |  |
167 |  |  |  |  | my $vms_efs = _vms_efs();
168 |  |  |  |  | my $unix_rpt = _vms_unix_rpt();
169 |  |  |  |  | my $unix_mode = 0;
170 |  |  |  |  | my $from_unix = 0;
171 |  |  |  |  | $from_unix = 1 if ($from =~ /^\.\.?$/);
172 |  |  |  |  | my $from_vms = 0;
173 |  |  |  |  | $from_vms = 1 if ($from =~ m#[\[<\]]#);
174 |  |  |  |  |
175 |  |  |  |  | # Need to know if we are in Unix mode.
176 |  |  |  |  | if ($from_vms == $from_unix) {
177 |  |  |  |  | $unix_mode = $unix_rpt;
178 |  |  |  |  | } else {
179 |  |  |  |  | $unix_mode = $from_unix;
180 |  |  |  |  | }
181 |  |  |  |  |
182 |  |  |  |  | # VMS has sticky defaults on extensions, which means that
183 |  |  |  |  | # if there is a null extension on the destination file, it
184 |  |  |  |  | # will inherit the extension of the source file
185 |  |  |  |  | # So add a '.' for a null extension.
186 |  |  |  |  |
187 |  |  |  |  | # In unix_rpt mode, the trailing dot should not be added.
188 |  |  |  |  |
189 |  |  |  |  | if ($vms_efs) {
190 |  |  |  |  | $copy_to = $to;
191 |  |  |  |  | } else {
192 |  |  |  |  | $copy_to = VMS::Filespec::vmsify($to);
193 |  |  |  |  | }
194 |  |  |  |  | my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
195 |  |  |  |  | $file = $file . '.'
196 |  |  |  |  | unless (($file =~ /(?<!\^)\./) || $unix_rpt);
197 |  |  |  |  | $copy_to = File::Spec->catpath($vol, $dirs, $file);
198 |  |  |  |  |
199 |  |  |  |  | # Get rid of the old versions to be like UNIX
200 |  |  |  |  | 1 while unlink $copy_to;
201 |  |  |  |  | }
202 |  |  |  |  | }
203 |  |  |  |  |
204 |  |  |  |  | return syscopy($from, $copy_to) || 0;
205 |  |  |  |  | }
206 |  |  |  |  |
207 |  |  |  |  | my $closefrom = 0;
208 |  |  |  |  | my $closeto = 0;
209 |  |  |  |  | my ($status, $r, $buf);
210 |  |  |  |  | local($\) = '';
211 |  |  |  |  |
212 |  |  |  |  | my $from_h;
213 |  |  |  |  | if ($from_a_handle) {
214 |  |  |  |  | $from_h = $from;
215 |  |  |  |  | } else {
216 |  |  |  |  | open $from_h, "<", $from or goto fail_open1;
217 |  |  |  |  | binmode $from_h or die "($!,$^E)";
218 |  |  |  |  | $closefrom = 1;
219 |  |  |  |  | }
220 |  |  |  |  |
221 |  |  |  |  | # Seems most logical to do this here, in case future changes would want to
222 |  |  |  |  | # make this croak for some reason.
223 |  |  |  |  | unless (defined $size) {
224 |  |  |  |  | $size = tied(*$from_h) ? 0 : -s $from_h || 0;
225 |  |  |  |  | $size = 1024 if ($size < 512);
226 |  |  |  |  | $size = $Too_Big if ($size > $Too_Big);
227 |  |  |  |  | }
228 |  |  |  |  |
229 |  |  |  |  | my $to_h;
230 |  |  |  |  | if ($to_a_handle) {
231 |  |  |  |  | $to_h = $to;
232 |  |  |  |  | } else {
233 |  |  |  |  | $to_h = \do { local *FH }; # XXX is this line obsolete?
234 |  |  |  |  | open $to_h, ">", $to or goto fail_open2;
235 |  |  |  |  | binmode $to_h or die "($!,$^E)";
236 |  |  |  |  | $closeto = 1;
237 |  |  |  |  | }
238 |  |  |  |  |
239 |  |  |  |  | $! = 0;
240 |  |  |  |  | for (;;) {
241 |  |  |  |  | my ($r, $w, $t);
242 |  |  |  |  | defined($r = sysread($from_h, $buf, $size))
243 |  |  |  |  | or goto fail_inner;
244 |  |  |  |  | last unless $r;
245 |  |  |  |  | for ($w = 0; $w < $r; $w += $t) {
246 |  |  |  |  | $t = syswrite($to_h, $buf, $r - $w, $w)
247 |  |  |  |  | or goto fail_inner;
248 |  |  |  |  | }
249 |  |  |  |  | }
250 |  |  |  |  |
251 |  |  |  |  | close($to_h) || goto fail_open2 if $closeto;
252 |  |  |  |  | close($from_h) || goto fail_open1 if $closefrom;
253 |  |  |  |  |
254 |  |  |  |  | # Use this idiom to avoid uninitialized value warning.
255 |  |  |  |  | return 1;
256 |  |  |  |  |
257 |  |  |  |  | # All of these contortions try to preserve error messages...
258 |  |  |  |  | fail_inner:
259 |  |  |  |  | if ($closeto) {
260 |  |  |  |  | $status = $!;
261 |  |  |  |  | $! = 0;
262 |  |  |  |  | close $to_h;
263 |  |  |  |  | $! = $status unless $!;
264 |  |  |  |  | }
265 |  |  |  |  | fail_open2:
266 |  |  |  |  | if ($closefrom) {
267 |  |  |  |  | $status = $!;
268 |  |  |  |  | $! = 0;
269 |  |  |  |  | close $from_h;
270 |  |  |  |  | $! = $status unless $!;
271 |  |  |  |  | }
272 |  |  |  |  | fail_open1:
273 |  |  |  |  | return 0;
274 |  |  |  |  | }
275 |  |  |  |  |
276 |  |  |  |  | sub cp {
277 |  |  |  |  | my($from,$to) = @_;
278 |  |  |  |  | my(@fromstat) = stat $from;
279 |  |  |  |  | my(@tostat) = stat $to;
280 |  |  |  |  | my $perm;
281 |  |  |  |  |
282 |  |  |  |  | return 0 unless copy(@_) and @fromstat;
283 |  |  |  |  |
284 |  |  |  |  | if (@tostat) {
285 |  |  |  |  | $perm = $tostat[2];
286 |  |  |  |  | } else {
287 |  |  |  |  | $perm = $fromstat[2] & ~(umask || 0);
288 |  |  |  |  | @tostat = stat $to;
289 |  |  |  |  | }
290 |  |  |  |  | # Might be more robust to look for S_I* in Fcntl, but we're
291 |  |  |  |  | # trying to avoid dependence on any XS-containing modules,
292 |  |  |  |  | # since File::Copy is used during the Perl build.
293 |  |  |  |  | $perm &= 07777;
294 |  |  |  |  | if ($perm & 06000) {
295 |  |  |  |  | croak("Unable to check setuid/setgid permissions for $to: $!")
296 |  |  |  |  | unless @tostat;
297 |  |  |  |  |
298 |  |  |  |  | if ($perm & 04000 and # setuid
299 |  |  |  |  | $fromstat[4] != $tostat[4]) { # owner must match
300 |  |  |  |  | $perm &= ~06000;
301 |  |  |  |  | }
302 |  |  |  |  |
303 |  |  |  |  | if ($perm & 02000 && $> != 0) { # if not root, setgid
304 |  |  |  |  | my $ok = $fromstat[5] == $tostat[5]; # group must match
305 |  |  |  |  | if ($ok) { # and we must be in group
306 |  |  |  |  | $ok = grep { $_ == $fromstat[5] } split /\s+/, $)
307 |  |  |  |  | }
308 |  |  |  |  | $perm &= ~06000 unless $ok;
309 |  |  |  |  | }
310 |  |  |  |  | }
311 |  |  |  |  | return 0 unless @tostat;
312 |  |  |  |  | return 1 if $perm == ($tostat[2] & 07777);
313 |  |  |  |  | return eval { chmod $perm, $to; } ? 1 : 0;
314 |  |  |  |  | }
315 |  |  |  |  |
316 |  |  |  |  | sub _move {
317 |  |  |  |  | croak("Usage: move(FROM, TO) ") unless @_ == 3;
318 |  |  |  |  |
319 |  |  |  |  | my($from,$to,$fallback) = @_;
320 |  |  |  |  |
321 |  |  |  |  | my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
322 |  |  |  |  |
323 |  |  |  |  | if (-d $to && ! -d $from) {
324 |  |  |  |  | $to = _catname($from, $to);
325 |  |  |  |  | }
326 |  |  |  |  |
327 |  |  |  |  | ($tosz1,$tomt1) = (stat($to))[7,9];
328 |  |  |  |  | $fromsz = -s $from;
329 |  |  |  |  | if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
330 |  |  |  |  | # will not rename with overwrite
331 |  |  |  |  | unlink $to;
332 |  |  |  |  | }
333 |  |  |  |  |
334 |  |  |  |  | my $rename_to = $to;
335 |  |  |  |  | if (-$^O eq 'VMS' && -e $from) {
336 |  |  |  |  |
337 |  |  |  |  | if (! -d $to && ! -d $from) {
338 |  |  |  |  |
339 |  |  |  |  | my $vms_efs = _vms_efs();
340 |  |  |  |  | my $unix_rpt = _vms_unix_rpt();
341 |  |  |  |  | my $unix_mode = 0;
342 |  |  |  |  | my $from_unix = 0;
343 |  |  |  |  | $from_unix = 1 if ($from =~ /^\.\.?$/);
344 |  |  |  |  | my $from_vms = 0;
345 |  |  |  |  | $from_vms = 1 if ($from =~ m#[\[<\]]#);
346 |  |  |  |  |
347 |  |  |  |  | # Need to know if we are in Unix mode.
348 |  |  |  |  | if ($from_vms == $from_unix) {
349 |  |  |  |  | $unix_mode = $unix_rpt;
350 |  |  |  |  | } else {
351 |  |  |  |  | $unix_mode = $from_unix;
352 |  |  |  |  | }
353 |  |  |  |  |
354 |  |  |  |  | # VMS has sticky defaults on extensions, which means that
355 |  |  |  |  | # if there is a null extension on the destination file, it
356 |  |  |  |  | # will inherit the extension of the source file
357 |  |  |  |  | # So add a '.' for a null extension.
358 |  |  |  |  |
359 |  |  |  |  | # In unix_rpt mode, the trailing dot should not be added.
360 |  |  |  |  |
361 |  |  |  |  | if ($vms_efs) {
362 |  |  |  |  | $rename_to = $to;
363 |  |  |  |  | } else {
364 |  |  |  |  | $rename_to = VMS::Filespec::vmsify($to);
365 |  |  |  |  | }
366 |  |  |  |  | my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
367 |  |  |  |  | $file = $file . '.'
368 |  |  |  |  | unless (($file =~ /(?<!\^)\./) || $unix_rpt);
369 |  |  |  |  | $rename_to = File::Spec->catpath($vol, $dirs, $file);
370 |  |  |  |  |
371 |  |  |  |  | # Get rid of the old versions to be like UNIX
372 |  |  |  |  | 1 while unlink $rename_to;
373 |  |  |  |  | }
374 |  |  |  |  | }
375 |  |  |  |  |
376 |  |  |  |  | return 1 if rename $from, $rename_to;
377 |  |  |  |  |
378 |  |  |  |  | # Did rename return an error even though it succeeded, because $to
379 |  |  |  |  | # is on a remote NFS file system, and NFS lost the server's ack?
380 |  |  |  |  | return 1 if defined($fromsz) && !-e $from && # $from disappeared
381 |  |  |  |  | (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
382 |  |  |  |  | ((!defined $tosz1) || # not before or
383 |  |  |  |  | ($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
384 |  |  |  |  | $tosz2 == $fromsz; # it's all there
385 |  |  |  |  |
386 |  |  |  |  | ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
387 |  |  |  |  |
388 |  |  |  |  | {
389 |  |  |  |  | local $@;
390 |  |  |  |  | eval {
391 |  |  |  |  | local $SIG{__DIE__};
392 |  |  |  |  | $fallback->($from,$to) or die;
393 |  |  |  |  | my($atime, $mtime) = (stat($from))[8,9];
394 |  |  |  |  | utime($atime, $mtime, $to);
395 |  |  |  |  | unlink($from) or die;
396 |  |  |  |  | };
397 |  |  |  |  | return 1 unless $@;
398 |  |  |  |  | }
399 |  |  |  |  | ($sts,$ossts) = ($! + 0, $^E + 0);
400 |  |  |  |  |
401 |  |  |  |  | ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
402 |  |  |  |  | unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
403 |  |  |  |  | ($!,$^E) = ($sts,$ossts);
404 |  |  |  |  | return 0;
405 |  |  |  |  | }
406 |  |  |  |  |
407 |  |  |  |  | sub move { _move(@_,\&copy); }
408 |  |  |  |  | sub mv { _move(@_,\&cp); }
409 |  |  |  |  |
410 |  |  |  |  | # &syscopy is an XSUB under OS/2
411 | 1 | 700ns |  |  | unless (defined &syscopy) {
412 | 1 | 1µs |  |  | if ($^O eq 'VMS') {
413 |  |  |  |  | *syscopy = \&rmscopy;
414 |  |  |  |  | } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
415 |  |  |  |  | # Win32::CopyFile() fill only work if we can load Win32.xs
416 |  |  |  |  | *syscopy = sub {
417 |  |  |  |  | return 0 unless @_ == 2;
418 |  |  |  |  | return Win32::CopyFile(@_, 1);
419 |  |  |  |  | };
420 |  |  |  |  | } else {
421 | 1 | 200ns |  |  | $Syscopy_is_copy = 1;
422 | 1 | 2µs |  |  | *syscopy = \&copy;
423 |  |  |  |  | }
424 |  |  |  |  | }
425 |  |  |  |  |
426 | 1 | 7µs |  |  | 1;
427 |  |  |  |  |
428 |  |  |  |  | __END__