1#line 1 2# $File: //member/autrijus/ExtUtils-AutoInstall/lib/ExtUtils/AutoInstall.pm $ 3# $Revision: #9 $ $Change: 9532 $ $DateTime: 2004/01/01 06:47:30 $ vim: expandtab shiftwidth=4 4 5package ExtUtils::AutoInstall; 6$ExtUtils::AutoInstall::VERSION = '0.56'; 7 8use strict; 9use Cwd (); 10use ExtUtils::MakeMaker (); 11 12#line 281 13 14# special map on pre-defined feature sets 15my %FeatureMap = ( 16 '' => 'Core Features', # XXX: deprecated 17 '-core' => 'Core Features', 18); 19 20# various lexical flags 21my (@Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS); 22my ($Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly); 23my ($PostambleActions, $PostambleUsed); 24 25$AcceptDefault = 1 unless -t STDIN; # non-interactive session 26_init(); 27 28sub missing_modules { 29 return @Missing; 30} 31 32sub do_install { 33 __PACKAGE__->install( 34 [ UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config}], 35 @Missing, 36 ); 37} 38 39# initialize various flags, and/or perform install 40sub _init { 41 foreach my $arg (@ARGV, split(/[\s\t]+/, $ENV{PERL_EXTUTILS_AUTOINSTALL} || '')) { 42 if ($arg =~ /^--config=(.*)$/) { 43 $Config = [ split(',', $1) ]; 44 } 45 elsif ($arg =~ /^--installdeps=(.*)$/) { 46 __PACKAGE__->install($Config, @Missing = split(/,/, $1)); 47 exit 0; 48 } 49 elsif ($arg =~ /^--default(?:deps)?$/) { 50 $AcceptDefault = 1; 51 } 52 elsif ($arg =~ /^--check(?:deps)?$/) { 53 $CheckOnly = 1; 54 } 55 elsif ($arg =~ /^--skip(?:deps)?$/) { 56 $SkipInstall = 1; 57 } 58 elsif ($arg =~ /^--test(?:only)?$/) { 59 $TestOnly = 1; 60 } 61 } 62} 63 64# overrides MakeMaker's prompt() to automatically accept the default choice 65sub _prompt { 66 goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; 67 68 my ($prompt, $default) = @_; 69 my $y = ($default =~ /^[Yy]/); 70 71 print $prompt, ' [', ($y ? 'Y' : 'y'), '/', ($y ? 'n' : 'N'), '] '; 72 print "$default\n"; 73 return $default; 74} 75 76# the workhorse 77sub import { 78 my $class = shift; 79 my @args = @_ or return; 80 my $core_all; 81 82 print "*** $class version ".$class->VERSION."\n"; 83 print "*** Checking for dependencies...\n"; 84 85 my $cwd = Cwd::cwd(); 86 87 $Config = []; 88 89 my $maxlen = length((sort { length($b) <=> length($a) } 90 grep { /^[^\-]/ } 91 map { ref($_) ? keys %{ref($_) eq 'HASH' ? $_ : +{@{$_}}} : '' } 92 map { +{@args}->{$_} } 93 grep { /^[^\-]/ or /^-core$/i } keys %{+{@args}})[0]); 94 95 while (my ($feature, $modules) = splice(@args, 0, 2)) { 96 my (@required, @tests, @skiptests); 97 my $default = 1; 98 my $conflict = 0; 99 100 if ($feature =~ m/^-(\w+)$/) { 101 my $option = lc($1); 102 103 # check for a newer version of myself 104 _update_to($modules, @_) and return if $option eq 'version'; 105 106 # sets CPAN configuration options 107 $Config = $modules if $option eq 'config'; 108 109 # promote every features to core status 110 $core_all = ($modules =~ /^all$/i) and next 111 if $option eq 'core'; 112 113 next unless $option eq 'core'; 114 } 115 116 print "[".($FeatureMap{lc($feature)} || $feature)."]\n"; 117 118 $modules = [ %{$modules} ] if UNIVERSAL::isa($modules, 'HASH'); 119 120 unshift @$modules, -default => &{shift(@$modules)} 121 if (ref($modules->[0]) eq 'CODE'); # XXX: bugward combatability 122 123 while (my ($mod, $arg) = splice(@$modules, 0, 2)) { 124 if ($mod =~ m/^-(\w+)$/) { 125 my $option = lc($1); 126 127 $default = $arg if ($option eq 'default'); 128 $conflict = $arg if ($option eq 'conflict'); 129 @tests = @{$arg} if ($option eq 'tests'); 130 @skiptests = @{$arg} if ($option eq 'skiptests'); 131 132 next; 133 } 134 135 printf("- %-${maxlen}s ...", $mod); 136 137 # XXX: check for conflicts and uninstalls(!) them. 138 if (defined(my $cur = _version_check(_load($mod), $arg ||= 0))) { 139 print "loaded. ($cur".($arg ? " >= $arg" : '').")\n"; 140 push @Existing, $mod => $arg; 141 $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 142 } 143 else { 144 print "missing." . ($arg ? " (would need $arg)" : '') . "\n"; 145 push @required, $mod => $arg; 146 } 147 } 148 149 next unless @required; 150 151 my $mandatory = ($feature eq '-core' or $core_all); 152 153 if (!$SkipInstall and ($CheckOnly or _prompt( 154 qq{==> Auto-install the }. (@required / 2). 155 ($mandatory ? ' mandatory' : ' optional'). 156 qq{ module(s) from CPAN?}, $default ? 'y' : 'n', 157 ) =~ /^[Yy]/)) { 158 push (@Missing, @required); 159 $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 160 } 161 162 elsif (!$SkipInstall and $default and $mandatory and _prompt( 163 qq{==> The module(s) are mandatory! Really skip?}, 'n', 164 ) =~ /^[Nn]/) { 165 push (@Missing, @required); 166 $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 167 } 168 169 else { 170 $DisabledTests{$_} = 1 for map { glob($_) } @tests; 171 } 172 } 173 174 _check_lock(); # check for $UnderCPAN 175 176 if (@Missing and not ($CheckOnly or $UnderCPAN)) { 177 require Config; 178 print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; 179 # make an educated guess of whether we'll need root permission. 180 print " (You may need to do that as the 'root' user.)\n" if eval '$>'; 181 } 182 print "*** $class configuration finished.\n"; 183 184 chdir $cwd; 185 186 # import to main:: 187 no strict 'refs'; 188 *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; 189} 190 191# CPAN.pm is non-reentrant, so check if we're under it and have no CPANPLUS 192sub _check_lock { 193 return unless @Missing; 194 return if _has_cpanplus(); 195 196 require CPAN; CPAN::Config->load; 197 my $lock = MM->catfile($CPAN::Config->{cpan_home}, ".lock"); 198 199 if (-f $lock and open(LOCK, $lock) 200 and ($^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid()) 201 and ($CPAN::Config->{prerequisites_policy} || '') ne 'ignore' 202 ) { 203 print << '.'; 204 205*** Since we're running under CPAN, I'll just let it take care 206 of the dependency's installation later. 207. 208 $UnderCPAN = 1; 209 } 210 211 close LOCK; 212} 213 214sub install { 215 my $class = shift; 216 217 my $i; # used below to strip leading '-' from config keys 218 my @config = (map { s/^-// if ++$i; $_ } @{+shift}); 219 220 my (@modules, @installed); 221 while (my ($pkg, $ver) = splice(@_, 0, 2)) { 222 # grep out those already installed 223 if (defined(_version_check(_load($pkg), $ver))) { 224 push @installed, $pkg; 225 } 226 else { 227 push @modules, $pkg, $ver; 228 } 229 } 230 231 return @installed unless @modules; # nothing to do 232 233 print "*** Installing dependencies...\n"; 234 235 return unless _connected_to('cpan.org'); 236 237 my %args = @config; 238 my %failed; 239 local *FAILED; 240 if ($args{do_once} and open(FAILED, '.#autoinstall.failed')) { 241 while (<FAILED>) { chomp; $failed{$_}++ } 242 close FAILED; 243 244 my @newmod; 245 while (my ($k, $v) = splice(@modules, 0, 2)) { 246 push @newmod, ($k => $v) unless $failed{$k}; 247 } 248 @modules = @newmod; 249 } 250 251 if (_has_cpanplus()) { 252 _install_cpanplus(\@modules, \@config); 253 } 254 else { 255 _install_cpan(\@modules, \@config); 256 } 257 258 print "*** $class installation finished.\n"; 259 260 # see if we have successfully installed them 261 while (my ($pkg, $ver) = splice(@modules, 0, 2)) { 262 if (defined(_version_check(_load($pkg), $ver))) { 263 push @installed, $pkg; 264 } 265 elsif ($args{do_once} and open(FAILED, '>> .#autoinstall.failed')) { 266 print FAILED "$pkg\n"; 267 } 268 } 269 270 close FAILED if $args{do_once}; 271 272 return @installed; 273} 274 275sub _install_cpanplus { 276 my @modules = @{+shift}; 277 my @config = @{+shift}; 278 my $installed = 0; 279 280 require CPANPLUS::Backend; 281 my $cp = CPANPLUS::Backend->new; 282 my $conf = $cp->configure_object; 283 284 return unless _can_write($conf->_get_build('base')); 285 286 # if we're root, set UNINST=1 to avoid trouble unless user asked for it. 287 my $makeflags = $conf->get_conf('makeflags') || ''; 288 if (UNIVERSAL::isa($makeflags, 'HASH')) { 289 # 0.03+ uses a hashref here 290 $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; 291 } 292 else { 293 # 0.02 and below uses a scalar 294 $makeflags = join(' ', split(' ', $makeflags), 'UNINST=1') 295 if ($makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' }); 296 } 297 $conf->set_conf(makeflags => $makeflags); 298 299 while (my ($key, $val) = splice(@config, 0, 2)) { 300 eval { $conf->set_conf($key, $val) }; 301 } 302 303 my $modtree = $cp->module_tree; 304 while (my ($pkg, $ver) = splice(@modules, 0, 2)) { 305 print "*** Installing $pkg...\n"; 306 307 MY::preinstall($pkg, $ver) or next if defined &MY::preinstall; 308 309 my $success; 310 my $obj = $modtree->{$pkg}; 311 312 if ($obj and defined(_version_check($obj->{version}, $ver))) { 313 my $pathname = $pkg; $pathname =~ s/::/\\W/; 314 315 foreach my $inc (grep { m/$pathname.pm/i } keys(%INC)) { 316 delete $INC{$inc}; 317 } 318 319 my $rv = $cp->install( modules => [ $obj->{module} ]); 320 321 if ($rv and ($rv->{$obj->{module}} or $rv->{ok})) { 322 print "*** $pkg successfully installed.\n"; 323 $success = 1; 324 } 325 else { 326 print "*** $pkg installation cancelled.\n"; 327 $success = 0; 328 } 329 330 $installed += $success; 331 } 332 else { 333 print << "."; 334*** Could not find a version $ver or above for $pkg; skipping. 335. 336 } 337 338 MY::postinstall($pkg, $ver, $success) if defined &MY::postinstall; 339 } 340 341 return $installed; 342} 343 344sub _install_cpan { 345 my @modules = @{+shift}; 346 my @config = @{+shift}; 347 my $installed = 0; 348 my %args; 349 350 require CPAN; CPAN::Config->load; 351 352 return unless _can_write(MM->catfile($CPAN::Config->{cpan_home}, 'sources')); 353 354 # if we're root, set UNINST=1 to avoid trouble unless user asked for it. 355 my $makeflags = $CPAN::Config->{make_install_arg} || ''; 356 $CPAN::Config->{make_install_arg} = join(' ', split(' ', $makeflags), 'UNINST=1') 357 if ($makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' }); 358 359 # don't show start-up info 360 $CPAN::Config->{inhibit_startup_message} = 1; 361 362 # set additional options 363 while (my ($opt, $arg) = splice(@config, 0, 2)) { 364 ($args{$opt} = $arg, next) 365 if $opt =~ /^force$/; # pseudo-option 366 $CPAN::Config->{$opt} = $arg; 367 } 368 369 while (my ($pkg, $ver) = splice(@modules, 0, 2)) { 370 MY::preinstall($pkg, $ver) or next if defined &MY::preinstall; 371 372 print "*** Installing $pkg...\n"; 373 374 my $obj = CPAN::Shell->expand(Module => $pkg); 375 my $success = 0; 376 377 if ($obj and defined(_version_check($obj->cpan_version, $ver))) { 378 my $pathname = $pkg; $pathname =~ s/::/\\W/; 379 380 foreach my $inc (grep { m/$pathname.pm/i } keys(%INC)) { 381 delete $INC{$inc}; 382 } 383 384 $obj->force('install') if $args{force}; 385 386 if ($obj->install eq 'YES') { 387 print "*** $pkg successfully installed.\n"; 388 $success = 1; 389 } 390 else { 391 print "*** $pkg installation failed.\n"; 392 $success = 0; 393 } 394 395 $installed += $success; 396 } 397 else { 398 print << "."; 399*** Could not find a version $ver or above for $pkg; skipping. 400. 401 } 402 403 MY::postinstall($pkg, $ver, $success) if defined &MY::postinstall; 404 } 405 406 return $installed; 407} 408 409sub _has_cpanplus { 410 return ( 411 $HasCPANPLUS = ( 412 $INC{'CPANPLUS/Config.pm'} or 413 _load('CPANPLUS::Shell::Default') 414 ) 415 ); 416} 417 418# make guesses on whether we're under the CPAN installation directory 419sub _under_cpan { 420 require Cwd; 421 require File::Spec; 422 423 my $cwd = File::Spec->canonpath(Cwd::cwd()); 424 my $cpan = File::Spec->canonpath($CPAN::Config->{cpan_home}); 425 426 return (index($cwd, $cpan) > -1); 427} 428 429sub _update_to { 430 my $class = __PACKAGE__; 431 my $ver = shift; 432 433 return if defined(_version_check(_load($class), $ver)); # no need to upgrade 434 435 if (_prompt( 436 "==> A newer version of $class ($ver) is required. Install?", 'y' 437 ) =~ /^[Nn]/) { 438 die "*** Please install $class $ver manually.\n"; 439 } 440 441 print << "."; 442*** Trying to fetch it from CPAN... 443. 444 445 # install ourselves 446 _load($class) and return $class->import(@_) 447 if $class->install([], $class, $ver); 448 449 print << '.'; exit 1; 450 451*** Cannot bootstrap myself. :-( Installation terminated. 452. 453} 454 455# check if we're connected to some host, using inet_aton 456sub _connected_to { 457 my $site = shift; 458 459 return ( 460 ( _load('Socket') and Socket::inet_aton($site) ) or _prompt(qq( 461*** Your host cannot resolve the domain name '$site', which 462 probably means the Internet connections are unavailable. 463==> Should we try to install the required module(s) anyway?), 'n' 464 ) =~ /^[Yy]/ 465 ); 466} 467 468# check if a directory is writable; may create it on demand 469sub _can_write { 470 my $path = shift; 471 mkdir ($path, 0755) unless -e $path; 472 473 require Config; 474 return 1 if -w $path and -w $Config::Config{sitelib}; 475 476 print << "."; 477*** You are not allowed to write to the directory '$path'; 478 the installation may fail due to insufficient permissions. 479. 480 481 if (eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(qq( 482==> Should we try to re-execute the autoinstall process with 'sudo'?), 'y' 483 ) =~ /^[Yy]/) { 484 # try to bootstrap ourselves from sudo 485 print << "."; 486*** Trying to re-execute the autoinstall process with 'sudo'... 487. 488 my $missing = join(',', @Missing); 489 my $config = join(',', 490 UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config} 491 ) if $Config; 492 493 return unless system('sudo', $^X, $0, "--config=$config", "--installdeps=$missing"); 494 495 print << "."; 496*** The 'sudo' command exited with error! Resuming... 497. 498 } 499 500 return _prompt(qq( 501==> Should we try to install the required module(s) anyway?), 'n' 502 ) =~ /^[Yy]/ 503} 504 505# load a module and return the version it reports 506sub _load { 507 my $mod = pop; # class/instance doesn't matter 508 my $file = $mod; 509 510 $file =~ s|::|/|g; 511 $file .= '.pm'; 512 513 local $@; 514 return eval { require $file; $mod->VERSION } || ($@ ? undef : 0); 515} 516 517# compare two versions, either use Sort::Versions or plain comparison 518sub _version_check { 519 my ($cur, $min) = @_; 520 return unless defined $cur; 521 522 $cur =~ s/\s+$//; 523 524 # check for version numbers that are not in decimal format 525 if (ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./) { 526 if ($version::VERSION or defined(_load('version'))) { 527 # use version.pm if it is installed. 528 return ((version->new($cur) >= version->new($min)) ? $cur : undef); 529 } 530 elsif ($Sort::Versions::VERSION or defined(_load('Sort::Versions'))) { 531 # use Sort::Versions as the sorting algorithm for a.b.c versions 532 return ((Sort::Versions::versioncmp($cur, $min) != -1) ? $cur : undef); 533 } 534 535 warn "Cannot reliably compare non-decimal formatted versions.\n". 536 "Please install version.pm or Sort::Versions.\n"; 537 } 538 539 # plain comparison 540 local $^W = 0; # shuts off 'not numeric' bugs 541 return ($cur >= $min ? $cur : undef); 542} 543 544# nothing; this usage is deprecated. 545sub main::PREREQ_PM { return {}; } 546 547sub _make_args { 548 my %args = @_; 549 550 $args{PREREQ_PM} = { %{$args{PREREQ_PM} || {} }, @Existing, @Missing } 551 if $UnderCPAN or $TestOnly; 552 553 if ($args{EXE_FILES}) { 554 require ExtUtils::Manifest; 555 my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); 556 557 $args{EXE_FILES} = [ 558 grep { exists $manifest->{$_} } @{$args{EXE_FILES}} 559 ]; 560 } 561 562 $args{test}{TESTS} ||= 't/*.t'; 563 $args{test}{TESTS} = join(' ', grep { 564 !exists($DisabledTests{$_}) 565 } map { glob($_) } split(/\s+/, $args{test}{TESTS})); 566 567 my $missing = join(',', @Missing); 568 my $config = join(',', 569 UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config} 570 ) if $Config; 571 572 $PostambleActions = ( 573 $missing ? "\$(PERL) $0 --config=$config --installdeps=$missing" 574 : "\@\$(NOOP)" 575 ); 576 577 return %args; 578} 579 580# a wrapper to ExtUtils::MakeMaker::WriteMakefile 581sub Write { 582 require Carp; 583 Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; 584 585 if ($CheckOnly) { 586 print << "."; 587*** Makefile not written in check-only mode. 588. 589 return; 590 } 591 592 my %args = _make_args(@_); 593 594 no strict 'refs'; 595 596 $PostambleUsed = 0; 597 local *MY::postamble = \&postamble unless defined &MY::postamble; 598 ExtUtils::MakeMaker::WriteMakefile(%args); 599 600 print << "." unless $PostambleUsed; 601*** WARNING: Makefile written with customized MY::postamble() without 602 including contents from ExtUtils::AutoInstall::postamble() -- 603 auto installation features disabled. Please contact the author. 604. 605 606 return 1; 607} 608 609sub postamble { 610 $PostambleUsed = 1; 611 612 return << "."; 613 614config :: installdeps 615\t\@\$(NOOP) 616 617checkdeps :: 618\t\$(PERL) $0 --checkdeps 619 620installdeps :: 621\t$PostambleActions 622 623. 624 625} 626 6271; 628 629__END__ 630 631#line 928 632