install_lib.pl

   1 #!perl
   2
   3 # Initialisation code and subroutines shared between installperl and installman
   4 # Probably installhtml needs to join the club.
   5
   6 use strict;
   7 use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $Is_Darwin $Is_NetWare
   8             %opts $packlist);
   9 use subs qw(unlink link chmod);
  10 require File::Path;
  11 require File::Copy;
  12
  13 BEGIN {
  14     require Config;
  15     if ($Config::Config{userelocatableinc}) {
  16         # This might be a considered a hack. Need to get information about the
  17         # configuration from Config.pm *before* Config.pm expands any .../
  18         # prefixes.
  19         #
  20         # So we set $^X to pretend that we're the already installed perl, so
  21         # Config.pm does its ... expansion off that location.
  22
  23         my $location = $Config::Config{initialinstalllocation};
  24         die <<'OS' unless defined $location;
  25 $Config{initialinstalllocation} is not defined - can't install a relocatable
  26 perl without this.
  27 OS
  28         $^X = "$location/perl";
  29         # And then remove all trace of ever having loaded Config.pm, so that
  30         # it will reload with the revised $^X
  31         undef %Config::;
  32         delete $INC{"Config.pm"};
  33         delete $INC{"Config_heavy.pl"};
  34         delete $INC{"Config_git.pl"};
  35         # You never saw us. We weren't here.
  36
  37         require Config;
  38     }
  39     Config->import;
  40 }
  41
  42 if ($Config{d_umask}) {
  43     umask(022); # umasks like 077 aren't that useful for installations
  44 }
  45
  46 $Is_VMS = $^O eq 'VMS';
  47 $Is_W32 = $^O eq 'MSWin32';
  48 $Is_OS2 = $^O eq 'os2';
  49 $Is_Cygwin = $^O eq 'cygwin';
  50 $Is_Darwin = $^O eq 'darwin';
  51 $Is_NetWare = $Config{osname} eq 'NetWare';
  52
  53 sub unlink {
  54     my(@names) = @_;
  55     my($cnt) = 0;
  56
  57     return scalar(@names) if $Is_VMS;
  58
  59     foreach my $name (@names) {
  60         next unless -e $name;
  61         chmod 0777, $name if ($Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare);
  62         print "  unlink $name\n" if $opts{verbose};
  63         ( CORE::unlink($name) and ++$cnt
  64           or warn "Couldn't unlink $name: $!\n" ) unless $opts{notify};
  65     }
  66     return $cnt;
  67 }
  68
  69 sub link {
  70     my($from,$to) = @_;
  71     my($success) = 0;
  72
  73     my $xfrom = $from;
  74     $xfrom =~ s/^\Q$opts{destdir}\E// if $opts{destdir};
  75     my $xto = $to;
  76     $xto =~ s/^\Q$opts{destdir}\E// if $opts{destdir};
  77     print $opts{verbose} ? "  ln $xfrom $xto\n" : "  $xto\n"
  78         unless $opts{silent};
  79     eval {
  80         CORE::link($from, $to)
  81             ? $success++
  82             : ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
  83               ? die "AFS"  # okay inside eval {}
  84               : die "Couldn't link $from to $to: $!\n"
  85           unless $opts{notify};
  86         $packlist->{$xto} = { from => $xfrom, type => 'link' };
  87     };
  88     if ($@) {
  89         warn "Replacing link() with File::Copy::copy(): $@";
  90         print $opts{verbose} ? "  cp $from $xto\n" : "  $xto\n"
  91             unless $opts{silent};
  92         print "  creating new version of $xto\n"
  93                  if $Is_VMS and -e $to and !$opts{silent};
  94         unless ($opts{notify} or File::Copy::copy($from, $to) and ++$success) {
  95             # Might have been that F::C::c can't overwrite the target
  96             warn "Couldn't copy $from to $to: $!\n"
  97                 unless -f $to and (chmod(0666, $to), unlink $to)
  98                         and File::Copy::copy($from, $to) and ++$success;
  99         }
 100         $packlist->{$xto} = { type => 'file' };
 101     }
 102     $success;
 103 }
 104
 105 sub chmod {
 106     my($mode,$name) = @_;
 107
 108     return if ($^O eq 'dos');
 109     printf "  chmod %o %s\n", $mode, $name if $opts{verbose};
 110     CORE::chmod($mode,$name)
 111         || warn sprintf("Couldn't chmod %o %s: $!\n", $mode, $name)
 112       unless $opts{notify};
 113 }
 114
 115 sub samepath {
 116     my($p1, $p2) = @_;
 117
 118     return (lc($p1) eq lc($p2)) if ($Is_W32 || $Is_NetWare);
 119
 120     return 1
 121         if $p1 eq $p2;
 122
 123     my ($dev1, $ino1) = stat $p1;
 124     return 0
 125         unless defined $dev1;
 126     my ($dev2, $ino2) = stat $p2;
 127
 128     return $dev1 == $dev2 && $ino1 == $ino2;
 129 }
 130
 131 sub safe_rename {
 132     my($from,$to) = @_;
 133     if (-f $to and not unlink($to)) {
 134         my($i);
 135         for ($i = 1; $i < 50; $i++) {
 136             last if rename($to, "$to.$i");
 137         }
 138         warn("Cannot rename to '$to.$i': $!"), return 0
 139            if $i >= 50; # Give up!
 140     }
 141     link($from,$to) || return 0;
 142     unlink($from);
 143 }
 144
 145 sub mkpath {
 146     File::Path::mkpath(shift , $opts{verbose}, 0777) unless $opts{notify};
 147 }
 148
 149 1;