| Filename | /Users/ap13/perl5/perlbrew/perls/perl-5.16.2/lib/5.16.2/File/Copy.pm |
| Statements | Executed 27 statements in 2.39ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 2.40ms | 3.17ms | File::Copy::BEGIN@13 |
| 1 | 1 | 1 | 30µs | 30µs | File::Copy::BEGIN@10 |
| 1 | 1 | 1 | 17µs | 38µs | File::Copy::BEGIN@12.1 |
| 1 | 1 | 1 | 14µs | 41µs | File::Copy::BEGIN@11 |
| 1 | 1 | 1 | 14µs | 35µs | File::Copy::BEGIN@12 |
| 1 | 1 | 1 | 12µs | 25µs | File::Copy::BEGIN@14 |
| 1 | 1 | 1 | 4µs | 4µ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::_eq |
| 0 | 0 | 0 | 0s | 0s | File::Copy::_move |
| 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::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 | 74µs | 1 | 30µs | # spent 30µs within File::Copy::BEGIN@10 which was called:
# once (30µs+0s) by Bio::Roary::PostAnalysis::BEGIN@12 at line 10 # spent 30µs making 1 call to File::Copy::BEGIN@10 |
| 11 | 2 | 42µs | 2 | 67µs | # spent 41µs (14+26) within File::Copy::BEGIN@11 which was called:
# once (14µs+26µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 11 # spent 41µs making 1 call to File::Copy::BEGIN@11
# spent 26µs making 1 call to strict::import |
| 12 | 4 | 107µs | 4 | 112µs | use warnings; no warnings 'newline'; # spent 38µs making 1 call to File::Copy::BEGIN@12.1
# spent 35µs making 1 call to File::Copy::BEGIN@12
# spent 20µs making 1 call to warnings::unimport
# spent 20µs making 1 call to warnings::import |
| 13 | 2 | 163µs | 1 | 3.17ms | # spent 3.17ms (2.40+776µs) within File::Copy::BEGIN@13 which was called:
# once (2.40ms+776µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 13 # spent 3.17ms making 1 call to File::Copy::BEGIN@13 |
| 14 | 2 | 173µs | 2 | 38µs | # spent 25µs (12+13) within File::Copy::BEGIN@14 which was called:
# once (12µs+13µs) by Bio::Roary::PostAnalysis::BEGIN@12 at line 14 # spent 25µs making 1 call to File::Copy::BEGIN@14
# spent 13µ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 | 20µs | my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 }; # spent 5µs executing statements in string eval | ||
| 19 | 1 | 600ns | 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 | 500ns | $VERSION = '2.23'; | ||
| 26 | |||||
| 27 | 1 | 800ns | require Exporter; | ||
| 28 | 1 | 8µs | @ISA = qw(Exporter); | ||
| 29 | 1 | 800ns | @EXPORT = qw(copy move); | ||
| 30 | 1 | 500ns | @EXPORT_OK = qw(cp mv); | ||
| 31 | |||||
| 32 | 1 | 200ns | $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 4µs within File::Copy::BEGIN@47 which was called:
# once (4µs+0s) by Bio::Roary::PostAnalysis::BEGIN@12 at line 53 | ||||
| 48 | 1 | 5µs | if ($^O eq 'VMS') { | ||
| 49 | if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { | ||||
| 50 | $use_vms_feature = 1; | ||||
| 51 | } | ||||
| 52 | } | ||||
| 53 | 1 | 1.77ms | 1 | 4µs | } # spent 4µ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 | # The "copy" was a success as the source and destination contain | ||||
| 132 | # the same data. | ||||
| 133 | return 1; | ||||
| 134 | } | ||||
| 135 | |||||
| 136 | if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && | ||||
| 137 | !($^O eq 'MSWin32' || $^O eq 'os2')) { | ||||
| 138 | my @fs = stat($from); | ||||
| 139 | if (@fs) { | ||||
| 140 | my @ts = stat($to); | ||||
| 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 | if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { | ||||
| 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 | if ($from_a_handle) { | ||||
| 213 | $from_h = $from; | ||||
| 214 | } else { | ||||
| 215 | open $from_h, "<", $from or goto fail_open1; | ||||
| 216 | binmode $from_h or die "($!,$^E)"; | ||||
| 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 | unless (defined $size) { | ||||
| 223 | $size = tied(*$from_h) ? 0 : -s $from_h || 0; | ||||
| 224 | $size = 1024 if ($size < 512); | ||||
| 225 | $size = $Too_Big if ($size > $Too_Big); | ||||
| 226 | } | ||||
| 227 | |||||
| 228 | my $to_h; | ||||
| 229 | if ($to_a_handle) { | ||||
| 230 | $to_h = $to; | ||||
| 231 | } else { | ||||
| 232 | $to_h = \do { local *FH }; # XXX is this line obsolete? | ||||
| 233 | open $to_h, ">", $to or goto fail_open2; | ||||
| 234 | binmode $to_h or die "($!,$^E)"; | ||||
| 235 | $closeto = 1; | ||||
| 236 | } | ||||
| 237 | |||||
| 238 | $! = 0; | ||||
| 239 | for (;;) { | ||||
| 240 | my ($r, $w, $t); | ||||
| 241 | defined($r = sysread($from_h, $buf, $size)) | ||||
| 242 | or goto fail_inner; | ||||
| 243 | last unless $r; | ||||
| 244 | for ($w = 0; $w < $r; $w += $t) { | ||||
| 245 | $t = syswrite($to_h, $buf, $r - $w, $w) | ||||
| 246 | or goto fail_inner; | ||||
| 247 | } | ||||
| 248 | } | ||||
| 249 | |||||
| 250 | close($to_h) || goto fail_open2 if $closeto; | ||||
| 251 | close($from_h) || goto fail_open1 if $closefrom; | ||||
| 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 | sub _move { | ||||
| 316 | 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 | if (-d $to && ! -d $from) { | ||||
| 323 | $to = _catname($from, $to); | ||||
| 324 | } | ||||
| 325 | |||||
| 326 | ($tosz1,$tomt1) = (stat($to))[7,9]; | ||||
| 327 | $fromsz = -s $from; | ||||
| 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 | return 1 if rename $from, $rename_to; | ||||
| 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 | sub move { _move(@_,\©); } | ||||
| 407 | sub mv { _move(@_,\&cp); } | ||||
| 408 | |||||
| 409 | # &syscopy is an XSUB under OS/2 | ||||
| 410 | 1 | 900ns | unless (defined &syscopy) { | ||
| 411 | 1 | 2µ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 | 1 | 100ns | $Syscopy_is_copy = 1; | ||
| 428 | 1 | 2µs | *syscopy = \© | ||
| 429 | } | ||||
| 430 | } | ||||
| 431 | |||||
| 432 | 1 | 26µs | 1; | ||
| 433 | |||||
| 434 | __END__ |