1package ExtUtils::Install; 2 3use 5.00503; 4use vars qw(@ISA @EXPORT $VERSION); 5$VERSION = 1.32; 6 7use Exporter; 8use Carp (); 9use Config qw(%Config); 10@ISA = ('Exporter'); 11@EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); 12$Is_VMS = $^O eq 'VMS'; 13$Is_MacPerl = $^O eq 'MacOS'; 14 15my $Inc_uninstall_warn_handler; 16 17# install relative to here 18 19my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; 20 21use File::Spec; 22my $Curdir = File::Spec->curdir; 23my $Updir = File::Spec->updir; 24 25 26=head1 NAME 27 28ExtUtils::Install - install files from here to there 29 30=head1 SYNOPSIS 31 32 use ExtUtils::Install; 33 34 install({ 'blib/lib' => 'some/install/dir' } ); 35 36 uninstall($packlist); 37 38 pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' }); 39 40 41=head1 DESCRIPTION 42 43Handles the installing and uninstalling of perl modules, scripts, man 44pages, etc... 45 46Both install() and uninstall() are specific to the way 47ExtUtils::MakeMaker handles the installation and deinstallation of 48perl modules. They are not designed as general purpose tools. 49 50=head2 Functions 51 52=over 4 53 54=item B<install> 55 56 install(\%from_to); 57 install(\%from_to, $verbose, $dont_execute, $uninstall_shadows); 58 59Copies each directory tree of %from_to to its corresponding value 60preserving timestamps and permissions. 61 62There are two keys with a special meaning in the hash: "read" and 63"write". These contain packlist files. After the copying is done, 64install() will write the list of target files to $from_to{write}. If 65$from_to{read} is given the contents of this file will be merged into 66the written file. The read and the written file may be identical, but 67on AFS it is quite likely that people are installing to a different 68directory than the one where the files later appear. 69 70If $verbose is true, will print out each file removed. Default is 71false. This is "make install VERBINST=1" 72 73If $dont_execute is true it will only print what it was going to do 74without actually doing it. Default is false. 75 76If $uninstall_shadows is true any differing versions throughout @INC 77will be uninstalled. This is "make install UNINST=1" 78 79=cut 80 81sub install { 82 my($from_to,$verbose,$nonono,$inc_uninstall) = @_; 83 $verbose ||= 0; 84 $nonono ||= 0; 85 86 use Cwd qw(cwd); 87 use ExtUtils::Packlist; 88 use File::Basename qw(dirname); 89 use File::Copy qw(copy); 90 use File::Find qw(find); 91 use File::Path qw(mkpath); 92 use File::Compare qw(compare); 93 94 my(%from_to) = %$from_to; 95 my(%pack, $dir, $warn_permissions); 96 my($packlist) = ExtUtils::Packlist->new(); 97 # -w doesn't work reliably on FAT dirs 98 $warn_permissions++ if $^O eq 'MSWin32'; 99 local(*DIR); 100 for (qw/read write/) { 101 $pack{$_}=$from_to{$_}; 102 delete $from_to{$_}; 103 } 104 my($source_dir_or_file); 105 foreach $source_dir_or_file (sort keys %from_to) { 106 #Check if there are files, and if yes, look if the corresponding 107 #target directory is writable for us 108 opendir DIR, $source_dir_or_file or next; 109 for (readdir DIR) { 110 next if $_ eq $Curdir || $_ eq $Updir || $_ eq ".exists"; 111 my $targetdir = install_rooted_dir($from_to{$source_dir_or_file}); 112 mkpath($targetdir) unless $nonono; 113 if (!$nonono && !-w $targetdir) { 114 warn "Warning: You do not have permissions to " . 115 "install into $from_to{$source_dir_or_file}" 116 unless $warn_permissions++; 117 } 118 } 119 closedir DIR; 120 } 121 my $tmpfile = install_rooted_file($pack{"read"}); 122 $packlist->read($tmpfile) if (-f $tmpfile); 123 my $cwd = cwd(); 124 125 MOD_INSTALL: foreach my $source (sort keys %from_to) { 126 #copy the tree to the target directory without altering 127 #timestamp and permission and remember for the .packlist 128 #file. The packlist file contains the absolute paths of the 129 #install locations. AFS users may call this a bug. We'll have 130 #to reconsider how to add the means to satisfy AFS users also. 131 132 #October 1997: we want to install .pm files into archlib if 133 #there are any files in arch. So we depend on having ./blib/arch 134 #hardcoded here. 135 136 my $targetroot = install_rooted_dir($from_to{$source}); 137 138 my $blib_lib = File::Spec->catdir('blib', 'lib'); 139 my $blib_arch = File::Spec->catdir('blib', 'arch'); 140 if ($source eq $blib_lib and 141 exists $from_to{$blib_arch} and 142 directory_not_empty($blib_arch)) { 143 $targetroot = install_rooted_dir($from_to{$blib_arch}); 144 print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n"; 145 } 146 147 chdir $source or next; 148 find(sub { 149 my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9]; 150 return unless -f _; 151 152 my $origfile = $_; 153 return if $origfile eq ".exists"; 154 my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir); 155 my $targetfile = File::Spec->catfile($targetdir, $origfile); 156 my $sourcedir = File::Spec->catdir($source, $File::Find::dir); 157 my $sourcefile = File::Spec->catfile($sourcedir, $origfile); 158 159 my $save_cwd = cwd; 160 chdir $cwd; # in case the target is relative 161 # 5.5.3's File::Find missing no_chdir option. 162 163 my $diff = 0; 164 if ( -f $targetfile && -s _ == $size) { 165 # We have a good chance, we can skip this one 166 $diff = compare($sourcefile, $targetfile); 167 } else { 168 print "$sourcefile differs\n" if $verbose>1; 169 $diff++; 170 } 171 172 if ($diff){ 173 if (-f $targetfile){ 174 forceunlink($targetfile) unless $nonono; 175 } else { 176 mkpath($targetdir,0,0755) unless $nonono; 177 print "mkpath($targetdir,0,0755)\n" if $verbose>1; 178 } 179 copy($sourcefile, $targetfile) unless $nonono; 180 print "Installing $targetfile\n"; 181 utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1; 182 print "utime($atime,$mtime,$targetfile)\n" if $verbose>1; 183 $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); 184 chmod $mode, $targetfile; 185 print "chmod($mode, $targetfile)\n" if $verbose>1; 186 } else { 187 print "Skipping $targetfile (unchanged)\n" if $verbose; 188 } 189 190 if (defined $inc_uninstall) { 191 inc_uninstall($sourcefile,$File::Find::dir,$verbose, 192 $inc_uninstall ? 0 : 1); 193 } 194 195 # Record the full pathname. 196 $packlist->{$targetfile}++; 197 198 # File::Find can get confused if you chdir in here. 199 chdir $save_cwd; 200 201 # File::Find seems to always be Unixy except on MacPerl :( 202 }, $Is_MacPerl ? $Curdir : '.' ); 203 chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!"); 204 } 205 if ($pack{'write'}) { 206 $dir = install_rooted_dir(dirname($pack{'write'})); 207 mkpath($dir,0,0755) unless $nonono; 208 print "Writing $pack{'write'}\n"; 209 $packlist->write(install_rooted_file($pack{'write'})) unless $nonono; 210 } 211} 212 213sub install_rooted_file { 214 if (defined $INSTALL_ROOT) { 215 File::Spec->catfile($INSTALL_ROOT, $_[0]); 216 } else { 217 $_[0]; 218 } 219} 220 221 222sub install_rooted_dir { 223 if (defined $INSTALL_ROOT) { 224 File::Spec->catdir($INSTALL_ROOT, $_[0]); 225 } else { 226 $_[0]; 227 } 228} 229 230 231sub forceunlink { 232 chmod 0666, $_[0]; 233 unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!") 234} 235 236 237sub directory_not_empty ($) { 238 my($dir) = @_; 239 my $files = 0; 240 find(sub { 241 return if $_ eq ".exists"; 242 if (-f) { 243 $File::Find::prune++; 244 $files = 1; 245 } 246 }, $dir); 247 return $files; 248} 249 250 251=item B<install_default> I<DISCOURAGED> 252 253 install_default(); 254 install_default($fullext); 255 256Calls install() with arguments to copy a module from blib/ to the 257default site installation location. 258 259$fullext is the name of the module converted to a directory 260(ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it 261will attempt to read it from @ARGV. 262 263This is primarily useful for install scripts. 264 265B<NOTE> This function is not really useful because of the hard-coded 266install location with no way to control site vs core vs vendor 267directories and the strange way in which the module name is given. 268Consider its use discouraged. 269 270=cut 271 272sub install_default { 273 @_ < 2 or die "install_default should be called with 0 or 1 argument"; 274 my $FULLEXT = @_ ? shift : $ARGV[0]; 275 defined $FULLEXT or die "Do not know to where to write install log"; 276 my $INST_LIB = File::Spec->catdir(File::Spec->curdir,"blib","lib"); 277 my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir,"blib","arch"); 278 my $INST_BIN = File::Spec->catdir(File::Spec->curdir,'blib','bin'); 279 my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir,'blib','script'); 280 my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir,'blib','man1'); 281 my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir,'blib','man3'); 282 install({ 283 read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", 284 write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", 285 $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ? 286 $Config{installsitearch} : 287 $Config{installsitelib}, 288 $INST_ARCHLIB => $Config{installsitearch}, 289 $INST_BIN => $Config{installbin} , 290 $INST_SCRIPT => $Config{installscript}, 291 $INST_MAN1DIR => $Config{installman1dir}, 292 $INST_MAN3DIR => $Config{installman3dir}, 293 },1,0,0); 294} 295 296 297=item B<uninstall> 298 299 uninstall($packlist_file); 300 uninstall($packlist_file, $verbose, $dont_execute); 301 302Removes the files listed in a $packlist_file. 303 304If $verbose is true, will print out each file removed. Default is 305false. 306 307If $dont_execute is true it will only print what it was going to do 308without actually doing it. Default is false. 309 310=cut 311 312sub uninstall { 313 use ExtUtils::Packlist; 314 my($fil,$verbose,$nonono) = @_; 315 $verbose ||= 0; 316 $nonono ||= 0; 317 318 die "no packlist file found: $fil" unless -f $fil; 319 # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); 320 # require $my_req; # Hairy, but for the first 321 my ($packlist) = ExtUtils::Packlist->new($fil); 322 foreach (sort(keys(%$packlist))) { 323 chomp; 324 print "unlink $_\n" if $verbose; 325 forceunlink($_) unless $nonono; 326 } 327 print "unlink $fil\n" if $verbose; 328 forceunlink($fil) unless $nonono; 329} 330 331sub inc_uninstall { 332 my($filepath,$libdir,$verbose,$nonono) = @_; 333 my($dir); 334 my $file = (File::Spec->splitpath($filepath))[2]; 335 my %seen_dir = (); 336 337 my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} 338 ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; 339 340 foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp 341 privlibexp 342 sitearchexp 343 sitelibexp)}) { 344 next if $dir eq $Curdir; 345 next if $seen_dir{$dir}++; 346 my($targetfile) = File::Spec->catfile($dir,$libdir,$file); 347 next unless -f $targetfile; 348 349 # The reason why we compare file's contents is, that we cannot 350 # know, which is the file we just installed (AFS). So we leave 351 # an identical file in place 352 my $diff = 0; 353 if ( -f $targetfile && -s _ == -s $filepath) { 354 # We have a good chance, we can skip this one 355 $diff = compare($filepath,$targetfile); 356 } else { 357 print "#$file and $targetfile differ\n" if $verbose>1; 358 $diff++; 359 } 360 361 next unless $diff; 362 if ($nonono) { 363 if ($verbose) { 364 $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn; 365 $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier. 366 $Inc_uninstall_warn_handler->add( 367 File::Spec->catfile($libdir, $file), 368 $targetfile 369 ); 370 } 371 # if not verbose, we just say nothing 372 } else { 373 print "Unlinking $targetfile (shadowing?)\n"; 374 forceunlink($targetfile); 375 } 376 } 377} 378 379sub run_filter { 380 my ($cmd, $src, $dest) = @_; 381 local(*CMD, *SRC); 382 open(CMD, "|$cmd >$dest") || die "Cannot fork: $!"; 383 open(SRC, $src) || die "Cannot open $src: $!"; 384 my $buf; 385 my $sz = 1024; 386 while (my $len = sysread(SRC, $buf, $sz)) { 387 syswrite(CMD, $buf, $len); 388 } 389 close SRC; 390 close CMD or die "Filter command '$cmd' failed for $src"; 391} 392 393 394=item B<pm_to_blib> 395 396 pm_to_blib(\%from_to, $autosplit_dir); 397 pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd); 398 399Copies each key of %from_to to its corresponding value efficiently. 400Filenames with the extension .pm are autosplit into the $autosplit_dir. 401 402$filter_cmd is an optional shell command to run each .pm file through 403prior to splitting and copying. Input is the contents of the module, 404output the new module contents. 405 406You can have an environment variable PERL_INSTALL_ROOT set which will 407be prepended as a directory to each installed file (and directory). 408 409=cut 410 411sub pm_to_blib { 412 my($fromto,$autodir,$pm_filter) = @_; 413 414 use File::Basename qw(dirname); 415 use File::Copy qw(copy); 416 use File::Path qw(mkpath); 417 use File::Compare qw(compare); 418 use AutoSplit; 419 # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); 420 # require $my_req; # Hairy, but for the first 421 422 if (!ref($fromto) && -r $fromto) 423 { 424 # Win32 has severe command line length limitations, but 425 # can generate temporary files on-the-fly 426 # so we pass name of file here - eval it to get hash 427 open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!"; 428 my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}'; 429 eval $str; 430 close(FROMTO); 431 } 432 433 mkpath($autodir,0,0755); 434 while(my($from, $to) = each %$fromto) { 435 if( -f $to && -s $from == -s $to && -M $to < -M $from ) { 436 print "Skip $to (unchanged)\n"; 437 next; 438 } 439 440 # When a pm_filter is defined, we need to pre-process the source first 441 # to determine whether it has changed or not. Therefore, only perform 442 # the comparison check when there's no filter to be ran. 443 # -- RAM, 03/01/2001 444 445 my $need_filtering = defined $pm_filter && length $pm_filter && 446 $from =~ /\.pm$/; 447 448 if (!$need_filtering && 0 == compare($from,$to)) { 449 print "Skip $to (unchanged)\n"; 450 next; 451 } 452 if (-f $to){ 453 forceunlink($to); 454 } else { 455 mkpath(dirname($to),0,0755); 456 } 457 if ($need_filtering) { 458 run_filter($pm_filter, $from, $to); 459 print "$pm_filter <$from >$to\n"; 460 } else { 461 copy($from,$to); 462 print "cp $from $to\n"; 463 } 464 my($mode,$atime,$mtime) = (stat $from)[2,8,9]; 465 utime($atime,$mtime+$Is_VMS,$to); 466 chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to); 467 next unless $from =~ /\.pm$/; 468 _autosplit($to,$autodir); 469 } 470} 471 472 473=begin _private 474 475=item _autosplit 476 477From 1.0307 back, AutoSplit will sometimes leave an open filehandle to 478the file being split. This causes problems on systems with mandatory 479locking (ie. Windows). So we wrap it and close the filehandle. 480 481=end _private 482 483=cut 484 485sub _autosplit { 486 my $retval = autosplit(@_); 487 close *AutoSplit::IN if defined *AutoSplit::IN{IO}; 488 489 return $retval; 490} 491 492 493package ExtUtils::Install::Warn; 494 495sub new { bless {}, shift } 496 497sub add { 498 my($self,$file,$targetfile) = @_; 499 push @{$self->{$file}}, $targetfile; 500} 501 502sub DESTROY { 503 unless(defined $INSTALL_ROOT) { 504 my $self = shift; 505 my($file,$i,$plural); 506 foreach $file (sort keys %$self) { 507 $plural = @{$self->{$file}} > 1 ? "s" : ""; 508 print "## Differing version$plural of $file found. You might like to\n"; 509 for (0..$#{$self->{$file}}) { 510 print "rm ", $self->{$file}[$_], "\n"; 511 $i++; 512 } 513 } 514 $plural = $i>1 ? "all those files" : "this file"; 515 print "## Running 'make install UNINST=1' will unlink $plural for you.\n"; 516 } 517} 518 519=back 520 521 522=head1 ENVIRONMENT 523 524=over 4 525 526=item B<PERL_INSTALL_ROOT> 527 528Will be prepended to each install path. 529 530=back 531 532=head1 AUTHOR 533 534Original author lost in the mists of time. Probably the same as Makemaker. 535 536Currently maintained by Michael G Schwern <F<schwern@pobox.com>> 537 538Send patches and ideas to <F<makemaker@perl.org>>. 539 540Send bug reports via http://rt.cpan.org/. Please send your 541generated Makefile along with your report. 542 543For more up-to-date information, see http://www.makemaker.org. 544 545 546=head1 LICENSE 547 548This program is free software; you can redistribute it and/or 549modify it under the same terms as Perl itself. 550 551See F<http://www.perl.com/perl/misc/Artistic.html> 552 553 554=cut 555 5561; 557