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