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