inc/ExtUtils/AutoInstall.pm

   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
   5 package ExtUtils::AutoInstall;
   6 $ExtUtils::AutoInstall::VERSION = '0.56';
   7
   8 use strict;
   9 use Cwd ();
  10 use ExtUtils::MakeMaker ();
  11
  12 #line 281
  13
  14 # special map on pre-defined feature sets
  15 my %FeatureMap = (
  16     ''      => 'Core Features', # XXX: deprecated
  17     '-core' => 'Core Features',
  18 );
  19
  20 # various lexical flags
  21 my (@Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS);
  22 my ($Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly);
  23 my ($PostambleActions, $PostambleUsed);
  24
  25 $AcceptDefault = 1 unless -t STDIN; # non-interactive session
  26 _init();
  27
  28 sub missing_modules {
  29     return @Missing;
  30 }
  31
  32 sub 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
  40 sub _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
  65 sub _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
  77 sub 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
 192 sub _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
 214 sub 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
 275 sub _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
 344 sub _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
 409 sub _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
 419 sub _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
 429 sub _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
 456 sub _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
 469 sub _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
 506 sub _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
 518 sub _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.
 545 sub main::PREREQ_PM { return {}; }
 546
 547 sub _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
 581 sub 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
 609 sub postamble {
 610     $PostambleUsed = 1;
 611
 612     return << ".";
 613
 614 config :: installdeps
 615 \t\@\$(NOOP)
 616
 617 checkdeps ::
 618 \t\$(PERL) $0 --checkdeps
 619
 620 installdeps ::
 621 \t$PostambleActions
 622
 623 .
 624
 625 }
 626
 627 1;
 628
 629 __END__
 630
 631 #line 928