| Filename | /usr/lib/perl5/5.14/File/Copy.pm |
| Statements | Executed 427494 statements in 17.3s |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 15806 | 2 | 1 | 5.57s | 5.57s | File::Copy::CORE:open (opcode) |
| 15808 | 3 | 1 | 2.82s | 2.82s | File::Copy::CORE:stat (opcode) |
| 15943 | 1 | 1 | 2.69s | 2.69s | File::Copy::CORE:sysread (opcode) |
| 8040 | 1 | 1 | 1.88s | 1.88s | File::Copy::CORE:syswrite (opcode) |
| 7905 | 2 | 1 | 1.27s | 1.27s | File::Copy::CORE:ftdir (opcode) |
| 7903 | 1 | 1 | 1.24s | 17.2s | File::Copy::copy |
| 15806 | 2 | 1 | 792ms | 792ms | File::Copy::CORE:close (opcode) |
| 7905 | 2 | 1 | 648ms | 648ms | File::Copy::CORE:ftsize (opcode) |
| 2 | 1 | 1 | 225ms | 225ms | File::Copy::CORE:rename (opcode) |
| 7903 | 1 | 1 | 140ms | 166ms | File::Copy::_eq |
| 15806 | 2 | 1 | 33.7ms | 33.7ms | File::Copy::CORE:binmode (opcode) |
| 1 | 1 | 1 | 12.5ms | 13.5ms | File::Copy::BEGIN@13 |
| 1 | 1 | 1 | 277µs | 277µs | File::Copy::BEGIN@10 |
| 2 | 1 | 1 | 161µs | 226ms | File::Copy::_move |
| 2 | 2 | 1 | 35µs | 226ms | File::Copy::move |
| 1 | 1 | 1 | 21µs | 44µs | File::Copy::BEGIN@14 |
| 1 | 1 | 1 | 17µs | 24µs | File::Copy::BEGIN@11 |
| 1 | 1 | 1 | 15µs | 35µs | File::Copy::BEGIN@12 |
| 1 | 1 | 1 | 9µs | 9µs | File::Copy::BEGIN@47 |
| 0 | 0 | 0 | 0s | 0s | File::Copy::__ANON__[:419] |
| 0 | 0 | 0 | 0s | 0s | File::Copy::__ANON__[:425] |
| 0 | 0 | 0 | 0s | 0s | File::Copy::_catname |
| 0 | 0 | 0 | 0s | 0s | File::Copy::_vms_efs |
| 0 | 0 | 0 | 0s | 0s | File::Copy::_vms_unix_rpt |
| 0 | 0 | 0 | 0s | 0s | File::Copy::carp |
| 0 | 0 | 0 | 0s | 0s | File::Copy::cp |
| 0 | 0 | 0 | 0s | 0s | File::Copy::croak |
| 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 | 190µs | 1 | 277µs | # spent 277µs within File::Copy::BEGIN@10 which was called:
# once (277µs+0s) by installer::BEGIN@34 at line 10 # spent 277µs making 1 call to File::Copy::BEGIN@10 |
| 11 | 2 | 53µs | 2 | 31µs | # spent 24µs (17+7) within File::Copy::BEGIN@11 which was called:
# once (17µs+7µs) by installer::BEGIN@34 at line 11 # spent 24µs making 1 call to File::Copy::BEGIN@11
# spent 7µs making 1 call to strict::import |
| 12 | 2 | 50µs | 2 | 55µs | # spent 35µs (15+20) within File::Copy::BEGIN@12 which was called:
# once (15µs+20µs) by installer::BEGIN@34 at line 12 # spent 35µs making 1 call to File::Copy::BEGIN@12
# spent 20µs making 1 call to warnings::import |
| 13 | 2 | 2.43ms | 1 | 13.5ms | # spent 13.5ms (12.5+1.04) within File::Copy::BEGIN@13 which was called:
# once (12.5ms+1.04ms) by installer::BEGIN@34 at line 13 # spent 13.5ms making 1 call to File::Copy::BEGIN@13 |
| 14 | 2 | 381µs | 2 | 67µs | # spent 44µs (21+23) within File::Copy::BEGIN@14 which was called:
# once (21µs+23µs) by installer::BEGIN@34 at line 14 # spent 44µs making 1 call to File::Copy::BEGIN@14
# spent 23µ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 | 39µs | my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 }; # spent 2.43ms executing statements in string eval | ||
| 19 | 1 | 3µ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 | 2µs | $VERSION = '2.21'; | ||
| 26 | |||||
| 27 | 1 | 2µs | require Exporter; | ||
| 28 | 1 | 9µs | @ISA = qw(Exporter); | ||
| 29 | 1 | 3µs | @EXPORT = qw(copy move); | ||
| 30 | 1 | 3µs | @EXPORT_OK = qw(cp mv); | ||
| 31 | |||||
| 32 | 1 | 500ns | $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 | 1µs | my $use_vms_feature = 0; | ||
| 47 | # spent 9µs within File::Copy::BEGIN@47 which was called:
# once (9µs+0s) by installer::BEGIN@34 at line 53 | ||||
| 48 | 1 | 9µs | if ($^O eq 'VMS') { | ||
| 49 | if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { | ||||
| 50 | $use_vms_feature = 1; | ||||
| 51 | } | ||||
| 52 | } | ||||
| 53 | 1 | 3.54ms | 1 | 9µs | } # spent 9µ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 | # spent 166ms (140+25.7) within File::Copy::_eq which was called 7903 times, avg 21µs/call:
# 7903 times (140ms+25.7ms) by File::Copy::copy at line 129, avg 21µs/call | ||||
| 94 | 15806 | 25.7ms | my ($from, $to) = map { # spent 25.7ms making 15806 calls to Scalar::Util::blessed, avg 2µs/call | ||
| 95 | 47418 | 176ms | $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 | # spent 17.2s (1.24+15.9) within File::Copy::copy which was called 7903 times, avg 2.17ms/call:
# 7903 times (1.24s+15.9s) by installer::systemactions::copy_one_file at line 298 of /cygdrive/c/lo/libo-master/instsetoo_native/util/C:/lo/libo-master/solenv/bin/modules/installer/systemactions.pm, avg 2.17ms/call | ||||
| 106 | 197575 | 2.55s | 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 | 7903 | 166ms | if (_eq($from, $to)) { # works for references, too # spent 166ms making 7903 calls to File::Copy::_eq, avg 21µs/call | ||
| 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 | 15806 | 1.54s | 15806 | 75.0ms | if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && # spent 75.0ms making 15806 calls to Config::FETCH, avg 5µs/call |
| 137 | !($^O eq 'MSWin32' || $^O eq 'os2')) { | ||||
| 138 | 7903 | 1.39s | my @fs = stat($from); # spent 1.39s making 7903 calls to File::Copy::CORE:stat, avg 176µs/call | ||
| 139 | 15806 | 1.48s | if (@fs) { | ||
| 140 | 7903 | 1.43s | my @ts = stat($to); # spent 1.43s making 7903 calls to File::Copy::CORE:stat, avg 181µs/call | ||
| 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 | 7903 | 1.27s | if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { # spent 1.27s making 7903 calls to File::Copy::CORE:ftdir, avg 161µs/call | ||
| 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 | 23709 | 1.86s | if ($from_a_handle) { | ||
| 213 | $from_h = $from; | ||||
| 214 | } else { | ||||
| 215 | 7903 | 1.73s | open $from_h, "<", $from or goto fail_open1; # spent 1.73s making 7903 calls to File::Copy::CORE:open, avg 219µs/call | ||
| 216 | 7903 | 17.5ms | binmode $from_h or die "($!,$^E)"; # spent 17.5ms making 7903 calls to File::Copy::CORE:binmode, avg 2µs/call | ||
| 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 | 23709 | 703ms | unless (defined $size) { | ||
| 223 | 7903 | 648ms | $size = tied(*$from_h) ? 0 : -s $from_h || 0; # spent 648ms making 7903 calls to File::Copy::CORE:ftsize, avg 82µs/call | ||
| 224 | $size = 1024 if ($size < 512); | ||||
| 225 | $size = $Too_Big if ($size > $Too_Big); | ||||
| 226 | } | ||||
| 227 | |||||
| 228 | my $to_h; | ||||
| 229 | 31612 | 3.98s | if ($to_a_handle) { | ||
| 230 | $to_h = $to; | ||||
| 231 | } else { | ||||
| 232 | 7903 | 24.9ms | $to_h = \do { local *FH }; # XXX is this line obsolete? | ||
| 233 | 7903 | 3.84s | open $to_h, ">", $to or goto fail_open2; # spent 3.84s making 7903 calls to File::Copy::CORE:open, avg 486µs/call | ||
| 234 | 7903 | 16.1ms | binmode $to_h or die "($!,$^E)"; # spent 16.1ms making 7903 calls to File::Copy::CORE:binmode, avg 2µs/call | ||
| 235 | $closeto = 1; | ||||
| 236 | } | ||||
| 237 | |||||
| 238 | $! = 0; | ||||
| 239 | for (;;) { | ||||
| 240 | 55869 | 2.83s | my ($r, $w, $t); | ||
| 241 | 15943 | 2.69s | defined($r = sysread($from_h, $buf, $size)) # spent 2.69s making 15943 calls to File::Copy::CORE:sysread, avg 169µs/call | ||
| 242 | or goto fail_inner; | ||||
| 243 | last unless $r; | ||||
| 244 | 8040 | 1.94s | for ($w = 0; $w < $r; $w += $t) { | ||
| 245 | 8040 | 1.88s | $t = syswrite($to_h, $buf, $r - $w, $w) # spent 1.88s making 8040 calls to File::Copy::CORE:syswrite, avg 234µs/call | ||
| 246 | or goto fail_inner; | ||||
| 247 | } | ||||
| 248 | } | ||||
| 249 | |||||
| 250 | 7903 | 583ms | close($to_h) || goto fail_open2 if $closeto; # spent 583ms making 7903 calls to File::Copy::CORE:close, avg 74µs/call | ||
| 251 | 7903 | 209ms | close($from_h) || goto fail_open1 if $closefrom; # spent 209ms making 7903 calls to File::Copy::CORE:close, avg 26µs/call | ||
| 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 | # spent 226ms (161µs+226) within File::Copy::_move which was called 2 times, avg 113ms/call:
# 2 times (161µs+226ms) by File::Copy::move at line 406, avg 113ms/call | ||||
| 316 | 20 | 226ms | 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 | 2 | 322µs | if (-d $to && ! -d $from) { # spent 322µs making 2 calls to File::Copy::CORE:ftdir, avg 161µs/call | ||
| 323 | $to = _catname($from, $to); | ||||
| 324 | } | ||||
| 325 | |||||
| 326 | 2 | 310µs | ($tosz1,$tomt1) = (stat($to))[7,9]; # spent 310µs making 2 calls to File::Copy::CORE:stat, avg 155µs/call | ||
| 327 | 2 | 155µs | $fromsz = -s $from; # spent 155µs making 2 calls to File::Copy::CORE:ftsize, avg 78µs/call | ||
| 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 | 2 | 225ms | return 1 if rename $from, $rename_to; # spent 225ms making 2 calls to File::Copy::CORE:rename, avg 113ms/call | ||
| 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 | 2 | 34µs | 2 | 226ms | # spent 226ms (35µs+226) within File::Copy::move which was called 2 times, avg 113ms/call:
# once (17µs+136ms) by installer::systemactions::rename_directory at line 880 of /cygdrive/c/lo/libo-master/instsetoo_native/util/C:/lo/libo-master/solenv/bin/modules/installer/systemactions.pm
# once (18µs+90.1ms) by installer::systemactions::rename_string_in_directory at line 820 of /cygdrive/c/lo/libo-master/instsetoo_native/util/C:/lo/libo-master/solenv/bin/modules/installer/systemactions.pm # spent 226ms making 2 calls to File::Copy::_move, avg 113ms/call |
| 407 | sub mv { _move(@_,\&cp); } | ||||
| 408 | |||||
| 409 | # &syscopy is an XSUB under OS/2 | ||||
| 410 | 2 | 8µs | unless (defined &syscopy) { | ||
| 411 | 2 | 7µ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 | $Syscopy_is_copy = 1; | ||||
| 428 | *syscopy = \© | ||||
| 429 | } | ||||
| 430 | } | ||||
| 431 | |||||
| 432 | 1 | 84µs | 1; | ||
| 433 | |||||
| 434 | __END__ | ||||
sub File::Copy::CORE:binmode; # opcode | |||||
sub File::Copy::CORE:close; # opcode | |||||
sub File::Copy::CORE:ftdir; # opcode | |||||
sub File::Copy::CORE:ftsize; # opcode | |||||
sub File::Copy::CORE:open; # opcode | |||||
# spent 225ms within File::Copy::CORE:rename which was called 2 times, avg 113ms/call:
# 2 times (225ms+0s) by File::Copy::_move at line 375, avg 113ms/call | |||||
# spent 2.82s within File::Copy::CORE:stat which was called 15808 times, avg 178µs/call:
# 7903 times (1.43s+0s) by File::Copy::copy at line 140, avg 181µs/call
# 7903 times (1.39s+0s) by File::Copy::copy at line 138, avg 176µs/call
# 2 times (310µs+0s) by File::Copy::_move at line 326, avg 155µs/call | |||||
# spent 2.69s within File::Copy::CORE:sysread which was called 15943 times, avg 169µs/call:
# 15943 times (2.69s+0s) by File::Copy::copy at line 241, avg 169µs/call | |||||
# spent 1.88s within File::Copy::CORE:syswrite which was called 8040 times, avg 234µs/call:
# 8040 times (1.88s+0s) by File::Copy::copy at line 245, avg 234µs/call |