use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $Is_Darwin $Is_NetWare
%opts $packlist);
use subs qw(unlink link chmod);
+require File::Path;
+require File::Copy;
-use Config;
BEGIN {
- if ($Config{userelocatableinc}) {
+ require Config;
+ if ($Config::Config{userelocatableinc}) {
# This might be a considered a hack. Need to get information about the
# configuration from Config.pm *before* Config.pm expands any .../
# prefixes.
#
# So we set $^X to pretend that we're the already installed perl, so
- # Config.pm doesits ... expansion off that location.
+ # Config.pm does its ... expansion off that location.
- my $location = $Config{initialinstalllocation};
+ my $location = $Config::Config{initialinstalllocation};
die <<'OS' unless defined $location;
$Config{initialinstalllocation} is not defined - can't install a relocatable
perl without this.
undef %Config::;
delete $INC{"Config.pm"};
delete $INC{"Config_heavy.pl"};
+ delete $INC{"Config_git.pl"};
# You never saw us. We weren't here.
require Config;
- Config->import;
}
+ Config->import;
}
if ($Config{d_umask}) {
unless $opts{notify};
}
-
sub samepath {
my($p1, $p2) = @_;
return (lc($p1) eq lc($p2)) if ($Is_W32 || $Is_NetWare);
- if ($p1 ne $p2) {
- my($dev1, $ino1, $dev2, $ino2);
- ($dev1, $ino1) = stat($p1);
- ($dev2, $ino2) = stat($p2);
- ($dev1 == $dev2 && $ino1 == $ino2);
- }
- else {
- 1;
+ return 1
+ if $p1 eq $p2;
+
+ my ($dev1, $ino1) = stat $p1;
+ return 0
+ unless defined $dev1;
+ my ($dev2, $ino2) = stat $p2;
+
+ return $dev1 == $dev2 && $ino1 == $ino2;
+}
+
+sub safe_rename {
+ my($from,$to) = @_;
+ if (-f $to and not unlink($to)) {
+ my($i);
+ for ($i = 1; $i < 50; $i++) {
+ last if rename($to, "$to.$i");
+ }
+ warn("Cannot rename to '$to.$i': $!"), return 0
+ if $i >= 50; # Give up!
}
+ link($from,$to) || return 0;
+ unlink($from);
+}
+
+sub mkpath {
+ File::Path::mkpath(shift , $opts{verbose}, 0777) unless $opts{notify};
}
1;