| 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 | File::Copy::BEGIN@14 |
| 1 | 1 | 1 | 21µs | 101µs | File::Copy::BEGIN@19 |
| 1 | 1 | 1 | 11µs | 11µs | File::Copy::BEGIN@10 |
| 1 | 1 | 1 | 5µs | 6µs | File::Copy::BEGIN@16 |
| 1 | 1 | 1 | 4µs | 5µs | File::Copy::BEGIN@11 |
| 1 | 1 | 1 | 3µs | 12µs | File::Copy::BEGIN@12.1 |
| 1 | 1 | 1 | 3µs | 10µs | File::Copy::BEGIN@15 |
| 1 | 1 | 1 | 3µs | 8µs | File::Copy::BEGIN@17 |
| 1 | 1 | 1 | 3µs | 20µs | File::Copy::BEGIN@12 |
| 1 | 1 | 1 | 3µs | 8µs | File::Copy::BEGIN@13 |
| 1 | 1 | 1 | 300ns | 300ns | File::Copy::__ANON__ (xsub) |
| 0 | 0 | 0 | 0s | 0s | File::Copy::__ANON__[:323] |
| 0 | 0 | 0 | 0s | 0s | File::Copy::_catname |
| 0 | 0 | 0 | 0s | 0s | File::Copy::_eq |
| 0 | 0 | 0 | 0s | 0s | File::Copy::_move |
| 0 | 0 | 0 | 0s | 0s | File::Copy::carp |
| 0 | 0 | 0 | 0s | 0s | File::Copy::copy |
| 0 | 0 | 0 | 0s | 0s | File::Copy::cp |
| 0 | 0 | 0 | 0s | 0s | File::Copy::croak |
| 0 | 0 | 0 | 0s | 0s | File::Copy::move |
| 0 | 0 | 0 | 0s | 0s | File::Copy::mv |
| 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 |