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