Bio/Root/Build.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::Root::Build
   4 #
   5 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   6 #
   7 # Cared for by Sendu Bala <bix@sendu.me.uk>
   8 #
   9 # Copyright Sendu Bala
  10 #
  11 # You may distribute this module under the same terms as perl itself
  12
  13 # POD documentation - main docs before the code
  14
  15 =head1 NAME
  16
  17 Bio::Root::Build - A common Module::Build subclass base for BioPerl distributions
  18
  19 =head1 SYNOPSIS
  20
  21   ...TO BE ADDED
  22
  23 =head1 DESCRIPTION
  24
  25 This is a subclass of Module::Build so we can override certain methods and do
  26 fancy stuff
  27
  28 It was first written against Module::Build::Base v0.2805. Many of the methods
  29 here are copy/pasted from there in their entirety just to change one or two
  30 minor things, since for the most part Module::Build::Base code is hard to
  31 cleanly override.
  32
  33 =head1 FEEDBACK
  34
  35 =head2 Mailing Lists
  36
  37 User feedback is an integral part of the evolution of this and other
  38 Bioperl modules. Send your comments and suggestions preferably to
  39 the Bioperl mailing list.  Your participation is much appreciated.
  40
  41   bioperl-l@bioperl.org                  - General discussion
  42   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  43
  44 =head2 Support
  45
  46 Please direct usage questions or support issues to the mailing list:
  47
  48 I<bioperl-l@bioperl.org>
  49
  50 rather than to the module maintainer directly. Many experienced and
  51 reponsive experts will be able look at the problem and quickly
  52 address it. Please include a thorough description of the problem
  53 with code and data examples if at all possible.
  54
  55 =head2 Reporting Bugs
  56
  57 Report bugs to the Bioperl bug tracking system to help us keep track
  58 of the bugs and their resolution. Bug reports can be submitted via
  59 the web:
  60
  61   http://bugzilla.open-bio.org/
  62
  63 =head1 AUTHOR - Sendu Bala
  64
  65 Email bix@sendu.me.uk
  66
  67 =head1 APPENDIX
  68
  69 The rest of the documentation details each of the object methods.
  70 Internal methods are usually preceded with a _
  71
  72 =cut
  73
  74 package Bio::Root::Build;
  75
  76 BEGIN {
  77     # we really need Module::Build to be installed
  78     eval "use base Module::Build; 1" or die "This package requires Module::Build v0.2805 or greater to install itself.\n$@";
  79
  80     # ensure we'll be able to reload this module later by adding its path to inc
  81     use Cwd;
  82     use lib Cwd::cwd();
  83 }
  84
  85 use strict;
  86 use warnings;
  87
  88 our $VERSION = '1.006900'; # pre-1.7
  89 our @extra_types = qw(options excludes_os feature_requires test); # test must always be last in the list!
  90 our $checking_types = "requires|conflicts|".join("|", @extra_types);
  91
  92
  93 # our modules are in Bio, not lib
  94 sub find_pm_files {
  95     my $self = shift;
  96     foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) {
  97         $self->{properties}{pm_files}->{$pm} = File::Spec->catfile('lib', $pm);
  98     }
  99
 100     $self->_find_file_by_type('pm', 'lib');
 101 }
 102
 103 # ask what scripts to install (this method is unique to bioperl)
 104 sub choose_scripts {
 105     my $self = shift;
 106     my $accept = shift;
 107
 108     # we can offer interactive installation by groups only if we have subdirs
 109     # in scripts and no .PLS files there
 110     opendir(my $scripts_dir, 'scripts') or die "Can't open directory 'scripts': $!\n";
 111     my $int_ok = 0;
 112     my @group_dirs;
 113     while (my $thing = readdir($scripts_dir)) {
 114         next if $thing =~ /^\./;
 115         next if $thing eq 'CVS';
 116         if ($thing =~ /PLS$|pl$/) {
 117             $int_ok = 0;
 118             last;
 119         }
 120         $thing = File::Spec->catfile('scripts', $thing);
 121         if (-d $thing) {
 122             $int_ok = 1;
 123             push(@group_dirs, $thing);
 124         }
 125     }
 126     closedir($scripts_dir);
 127     my $question = $int_ok ? "Install [a]ll BioPerl scripts, [n]one, or choose groups [i]nteractively?" : "Install [a]ll BioPerl scripts or [n]one?";
 128
 129     my $prompt = $accept ? 'a' : $self->prompt($question, 'a');
 130
 131     if ($prompt =~ /^[aA]/) {
 132         $self->log_info("  - will install all scripts\n");
 133         $self->notes(chosen_scripts => 'all');
 134     }
 135     elsif ($prompt =~ /^[iI]/) {
 136         $self->log_info("  - will install interactively:\n");
 137
 138         my @chosen_scripts;
 139         foreach my $group_dir (@group_dirs) {
 140             my $group = File::Basename::basename($group_dir);
 141             print "    * group '$group' has:\n";
 142
 143             my @script_files = @{$self->rscan_dir($group_dir, qr/\.PLS$|\.pl$/)};
 144             foreach my $script_file (@script_files) {
 145                 my $script = File::Basename::basename($script_file);
 146                 print "      $script\n";
 147             }
 148
 149             my $result = $self->prompt("    Install scripts for group '$group'? [y]es [n]o [q]uit", 'n');
 150             die if $result =~ /^[qQ]/;
 151             if ($result =~ /^[yY]/) {
 152                 $self->log_info("      + will install group '$group'\n");
 153                 push(@chosen_scripts, @script_files);
 154             }
 155             else {
 156                 $self->log_info("      - will not install group '$group'\n");
 157             }
 158         }
 159
 160         my $chosen_scripts = @chosen_scripts ? join("|", @chosen_scripts) : 'none';
 161
 162         $self->notes(chosen_scripts => $chosen_scripts);
 163     }
 164     else {
 165         $self->log_info("  - won't install any scripts\n");
 166         $self->notes(chosen_scripts => 'none');
 167     }
 168
 169     print "\n";
 170 }
 171
 172 # our version of script_files doesn't take args but just installs those scripts
 173 # requested by the user after choose_scripts() is called. If it wasn't called,
 174 # installs all scripts in scripts directory
 175 sub script_files {
 176     my $self = shift;
 177
 178     unless (-d 'scripts') {
 179         return {};
 180     }
 181
 182     my $chosen_scripts = $self->notes('chosen_scripts');
 183     if ($chosen_scripts) {
 184         return if $chosen_scripts eq 'none';
 185         return { map {$_, 1} split(/\|/, $chosen_scripts) } unless $chosen_scripts eq 'all';
 186     }
 187
 188     return $_ = { map {$_,1} @{$self->rscan_dir('scripts', qr/\.PLS$|\.pl$/)} };
 189 }
 190
 191 # process scripts normally, except that we change name from *.PLS to bp_*.pl
 192 sub process_script_files {
 193     my $self = shift;
 194     my $files = $self->find_script_files;
 195     return unless keys %$files;
 196
 197     my $script_dir = File::Spec->catdir($self->blib, 'script');
 198     File::Path::mkpath( $script_dir );
 199
 200     foreach my $file (keys %$files) {
 201         my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
 202         $self->fix_shebang_line($result) unless $self->os_type eq 'VMS';
 203         $self->make_executable($result);
 204
 205         my $final = File::Basename::basename($result);
 206         $final =~ s/\.PLS$/\.pl/;                  # change from .PLS to .pl
 207         $final =~ s/^/bp_/ unless $final =~ /^bp/; # add the "bp" prefix
 208         $final = File::Spec->catfile($script_dir, $final);
 209         $self->log_info("$result -> $final\n");
 210         if (-e $final) {
 211             unlink $final || warn "[WARNING] Deleting '$final' failed!\n";
 212         }
 213         File::Copy::move($result, $final) or die "Can't rename '$result' to '$final': $!";
 214     }
 215 }
 216
 217 # extended to handle extra checking types
 218 sub features {
 219     my $self = shift;
 220     my $ph = $self->{phash};
 221
 222     if (@_) {
 223         my $key = shift;
 224         if ($ph->{features}->exists($key)) {
 225             return $ph->{features}->access($key, @_);
 226         }
 227
 228         if (my $info = $ph->{auto_features}->access($key)) {
 229             my $failures = $self->prereq_failures($info);
 230             my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0;
 231             return !$disabled;
 232         }
 233
 234         return $ph->{features}->access($key, @_);
 235     }
 236
 237     # No args - get the auto_features & overlay the regular features
 238     my %features;
 239     my %auto_features = $ph->{auto_features}->access();
 240     while (my ($name, $info) = each %auto_features) {
 241         my $failures = $self->prereq_failures($info);
 242         my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0;
 243         $features{$name} = $disabled ? 0 : 1;
 244     }
 245     %features = (%features, $ph->{features}->access());
 246
 247     return wantarray ? %features : \%features;
 248 }
 249 *feature = \&features;
 250
 251 # overridden to fix a stupid bug in Module::Build and extended to handle extra
 252 # checking types
 253 sub check_autofeatures {
 254     my ($self) = @_;
 255     my $features = $self->auto_features;
 256
 257     return unless %$features;
 258
 259     $self->log_info("Checking features:\n");
 260
 261     my $max_name_len = 0; # this wasn't set to 0 in Module::Build, causing warning in next line
 262     $max_name_len = ( length($_) > $max_name_len ) ? length($_) : $max_name_len for keys %$features;
 263
 264     while (my ($name, $info) = each %$features) {
 265         $self->log_info("  $name" . '.' x ($max_name_len - length($name) + 4));
 266         if ($name eq 'PL_files') {
 267             print "got $name => $info\n";
 268             print "info has:\n";
 269             while (my ($key, $val) = each %$info) {
 270                 print "  $key => $val\n";
 271             }
 272         }
 273
 274         if ( my $failures = $self->prereq_failures($info) ) {
 275             my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0;
 276             $self->log_info( $disabled ? "disabled\n" : "enabled\n" );
 277
 278             my $log_text;
 279             while (my ($type, $prereqs) = each %$failures) {
 280                 while (my ($module, $status) = each %$prereqs) {
 281                     my $required = ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0;
 282                     my $prefix = ($required) ? '-' : '*';
 283                     $log_text .= "    $prefix $status->{message}\n";
 284                 }
 285             }
 286             $self->log_warn($log_text) if $log_text && ! $self->quiet;
 287         }
 288         else {
 289             $self->log_info("enabled\n");
 290         }
 291     }
 292
 293     $self->log_info("\n");
 294 }
 295
 296 # TODO: STDERR output redirect is causing some installations to fail, commenting
 297 # out until a fix is in place
 298
 299 # overriden just to hide pointless ugly warnings
 300 sub check_installed_status {
 301     my $self = shift;
 302
 303     open (my $olderr, ">&". fileno(STDERR));
 304     open(STDERR, "/dev/null");
 305     my $return = $self->SUPER::check_installed_status(@_);
 306     open(STDERR, ">&". fileno($olderr));
 307     return $return;
 308 }
 309
 310 # extend to handle option checking (which takes an array ref) and code test
 311 # checking (which takes a code ref and must return a message only on failure)
 312 # and excludes_os (which takes an array ref of regexps).
 313 # also handles more informative output of recommends section
 314 sub prereq_failures {
 315     my ($self, $info) = @_;
 316
 317     my @types = (@{ $self->prereq_action_types }, @extra_types);
 318     $info ||= {map {$_, $self->$_()} @types};
 319
 320     my $out = {};
 321     foreach my $type (@types) {
 322         my $prereqs = $info->{$type} || next;
 323
 324         my $status = {};
 325         if ($type eq 'test') {
 326             unless (keys %$out) {
 327                 if (ref($prereqs) eq 'CODE') {
 328                     $status->{message} = &{$prereqs};
 329
 330                     # drop the code-ref to avoid Module::Build trying to store
 331                     # it with Data::Dumper, generating warnings. (And also, may
 332                     # be expensive to run the sub multiple times.)
 333                     $info->{$type} = $status->{message};
 334                 }
 335                 else {
 336                     $status->{message} = $prereqs;
 337                 }
 338                 $out->{$type}{'test'} = $status if $status->{message};
 339             }
 340         }
 341         elsif ($type eq 'options') {
 342             my @not_ok;
 343             foreach my $wanted_option (@{$prereqs}) {
 344                 unless ($self->args($wanted_option)) {
 345                     push(@not_ok, $wanted_option);
 346                 }
 347             }
 348
 349             if (@not_ok > 0) {
 350                 $status->{message} = "Command line option(s) '@not_ok' not supplied";
 351                 $out->{$type}{'options'} = $status;
 352             }
 353         }
 354         elsif ($type eq 'excludes_os') {
 355             foreach my $os (@{$prereqs}) {
 356                 if ($^O =~ /$os/i) {
 357                     $status->{message} = "This feature isn't supported under your OS ($os)";
 358                     $out->{$type}{'excludes_os'} = $status;
 359                     last;
 360                 }
 361             }
 362         }
 363         else {
 364             while ( my ($modname, $spec) = each %$prereqs ) {
 365                 $status = $self->check_installed_status($modname, $spec);
 366
 367                 if ($type =~ /^(?:\w+_)?conflicts$/) {
 368                     next if !$status->{ok};
 369                     $status->{conflicts} = delete $status->{need};
 370                     $status->{message} = "$modname ($status->{have}) conflicts with this distribution";
 371                 }
 372                 elsif ($type =~ /^(?:\w+_)?recommends$/) {
 373                     next if $status->{ok};
 374
 375                     my ($preferred_version, $why, $by_what) = split("/", $spec);
 376                     $by_what = join(", ", split(",", $by_what));
 377                     $by_what =~ s/, (\S+)$/ and $1/;
 378
 379                     $status->{message} = (!ref($status->{have}) && $status->{have} eq '<none>'
 380                                   ? "Optional prerequisite $modname is not installed"
 381                                   : "$modname ($status->{have}) is installed, but we prefer to have $preferred_version");
 382
 383                     $status->{message} .= "\n   (wanted for $why, used by $by_what)";
 384
 385                     if ($by_what =~ /\[circular dependency!\]/) {
 386                         $preferred_version = -1;
 387                     }
 388
 389                     my $installed = $self->install_optional($modname, $preferred_version, $status->{message});
 390                     next if $installed eq 'ok';
 391                     $status->{message} = $installed unless $installed eq 'skip';
 392                 }
 393                 elsif ($type =~ /^feature_requires/) {
 394                     next if $status->{ok};
 395
 396                     # if there is a test code-ref, drop it to avoid
 397                     # Module::Build trying to store it with Data::Dumper,
 398                     # generating warnings.
 399                     delete $info->{test};
 400                 }
 401                 else {
 402                     next if $status->{ok};
 403
 404                     my $installed = $self->install_required($modname, $spec, $status->{message});
 405                     next if $installed eq 'ok';
 406                     $status->{message} = $installed;
 407                 }
 408
 409                 $out->{$type}{$modname} = $status;
 410             }
 411         }
 412     }
 413
 414     return keys %{$out} ? $out : return;
 415 }
 416
 417 # install an external module using CPAN prior to testing and installation
 418 # should only be called by install_required or install_optional
 419 sub install_prereq {
 420     my ($self, $desired, $version, $required) = @_;
 421
 422     if ($self->under_cpan) {
 423         # Just add to the required hash, which CPAN >= 1.81 will check prior
 424         # to install
 425         $self->{properties}{requires}->{$desired} = $version;
 426         $self->log_info("   I'll get CPAN to prepend the installation of this\n");
 427         return 'ok';
 428     }
 429     else {
 430         my $question = $required ?  "$desired is absolutely required prior to installation: shall I install it now using a CPAN shell?" :
 431                                     "To install $desired I'll need to open a CPAN shell right now; is that OK?";
 432         my $do_install = $self->y_n($question.' y/n', 'y');
 433
 434         if ($do_install) {
 435             # Here we use CPAN to actually install the desired module, the benefit
 436             # being we continue even if installation fails, and that this works
 437             # even when not using CPAN to install.
 438             require Cwd;
 439             require CPAN;
 440
 441             # Save this because CPAN will chdir all over the place.
 442             my $cwd = Cwd::cwd();
 443
 444             CPAN::Shell->install($desired);
 445             my $msg;
 446             my $expanded = CPAN::Shell->expand("Module", $desired);
 447             if ($expanded && $expanded->uptodate) {
 448                 $self->log_info("\n\n*** (back in BioPerl Build.PL) ***\n * You chose to install $desired and it installed fine\n");
 449                 $msg = 'ok';
 450             }
 451             else {
 452                 $self->log_info("\n\n*** (back in BioPerl Build.PL) ***\n");
 453                 $msg = "You chose to install $desired but it failed to install";
 454             }
 455
 456             chdir $cwd or die "Cannot chdir() back to $cwd: $!";
 457             return $msg;
 458         }
 459         else {
 460             return $required ? "You chose not to install the REQUIRED module $desired: you'd better install it yourself manually!" :
 461                                "Even though you wanted the optional module $desired, you chose not to actually install it: do it yourself manually.";
 462         }
 463     }
 464 }
 465
 466 # install required modules listed in 'requires' or 'build_requires' arg to
 467 # new that weren't already installed. Should only be called by prereq_failures
 468 sub install_required {
 469     my ($self, $desired, $version, $msg) = @_;
 470
 471     $self->log_info(" - ERROR: $msg\n");
 472
 473     return $self->install_prereq($desired, $version, 1);
 474 }
 475
 476 # install optional modules listed in 'recommends' arg to new that weren't
 477 # already installed. Should only be called by prereq_failures
 478 sub install_optional {
 479     my ($self, $desired, $version, $msg) = @_;
 480
 481     unless (defined $self->{ask_optional}) {
 482         $self->{ask_optional} = $self->args->{accept}
 483                               ? 'n' : $self->prompt("Install [a]ll optional external modules, [n]one, or choose [i]nteractively?", 'n');
 484     }
 485     return 'skip' if $self->{ask_optional} =~ /^n/i;
 486
 487     my $install;
 488     if ($self->{ask_optional} =~ /^a/i) {
 489         $self->log_info(" * $msg\n");
 490         $install = 1;
 491     }
 492     else {
 493         $install = $self->y_n(" * $msg\n   Do you want to install it? y/n", 'n');
 494     }
 495
 496     my $orig_version = $version;
 497     $version = 0 if $version == -1;
 498     if ($install && ! ($self->{ask_optional} =~ /^a/i && $orig_version == -1)) {
 499         return $self->install_prereq($desired, $version);
 500     }
 501     else {
 502         my $circular = ($self->{ask_optional} =~ /^a/i && $orig_version == -1) ? " - this is a circular dependency so doesn't get installed when installing 'all' modules. If you really want it, choose modules interactively." : '';
 503         $self->log_info(" * You chose not to install $desired$circular\n");
 504         return 'ok';
 505     }
 506 }
 507
 508 # there's no official way to discover if being run by CPAN, we take an approach
 509 # similar to that of Module::AutoInstall
 510 sub under_cpan {
 511     my $self = shift;
 512
 513     unless (defined $self->{under_cpan}) {
 514         ## modified from Module::AutoInstall
 515
 516         my $cpan_env = $ENV{PERl5_CPAN_IS_RUNNING};
 517         if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
 518             $self->{under_cpan} = $cpan_env ? 'CPAN' : 'CPANPLUS';
 519         }
 520
 521         require CPAN;
 522
 523         unless (defined $self->{under_cpan}) {
 524             if ($CPAN::VERSION > '1.89') {
 525                 if ($cpan_env) {
 526                     $self->{under_cpan} = 'CPAN';
 527                 }
 528                 else {
 529                     $self->{under_cpan} = 0;
 530                 }
 531             }
 532         }
 533
 534         unless (defined $self->{under_cpan}) {
 535             # load cpan config
 536             if ($CPAN::HandleConfig::VERSION) {
 537                 # Newer versions of CPAN have a HandleConfig module
 538                 CPAN::HandleConfig->load;
 539             }
 540             else {
 541                 # Older versions had the load method in Config directly
 542                 CPAN::Config->load;
 543             }
 544
 545             # Find the CPAN lock-file
 546             my $lock = File::Spec->catfile($CPAN::Config->{cpan_home}, '.lock');
 547             if (-f $lock) {
 548                 # Module::AutoInstall now goes on to open the lock file and compare
 549                 # its pid to ours, but we're not in a situation where we expect
 550                 # the pids to match, so we take the windows approach for all OSes:
 551                 # find out if we're in cpan_home
 552                 my $cwd  = File::Spec->canonpath(Cwd::cwd());
 553                 my $cpan = File::Spec->canonpath($CPAN::Config->{cpan_home});
 554
 555                 $self->{under_cpan} = index($cwd, $cpan) > -1;
 556             }
 557         }
 558
 559         if ($self->{under_cpan}) {
 560             $self->log_info("(I think I'm being run by CPAN/CPANPLUS, so will rely on it to handle prerequisite installation)\n");
 561         }
 562         else {
 563             $self->log_info("(I think you ran Build.PL directly, so will use CPAN to install prerequisites on demand)\n");
 564             $self->{under_cpan} = 0;
 565         }
 566     }
 567
 568     return $self->{under_cpan};
 569 }
 570
 571 # overridden simply to not print the default answer if chosen by hitting return
 572 sub prompt {
 573     my $self = shift;
 574     my $mess = shift or die "prompt() called without a prompt message";
 575
 576     my $def;
 577     if ( $self->_is_unattended && !@_ ) {
 578         die <<EOF;
 579 ERROR: This build seems to be unattended, but there is no default value
 580 for this question.  Aborting.
 581 EOF
 582     }
 583     $def = shift if @_;
 584     ($def, my $dispdef) = defined $def ? ($def, "[$def] ") : ('', ' ');
 585
 586     local $|=1;
 587     print "$mess $dispdef";
 588
 589     my $ans = $self->_readline();
 590
 591     if ( !defined($ans)        # Ctrl-D or unattended
 592          or !length($ans) ) {  # User hit return
 593         #print "$def\n"; didn't like this!
 594         $ans = $def;
 595     }
 596
 597     return $ans;
 598 }
 599
 600 # like the Module::Build version, except that we always get version from
 601 # dist_version
 602 sub find_dist_packages {
 603     my $self = shift;
 604
 605     # Only packages in .pm files are candidates for inclusion here.
 606     # Only include things in the MANIFEST, not things in developer's
 607     # private stock.
 608
 609     my $manifest = $self->_read_manifest('MANIFEST') or die "Can't find dist packages without a MANIFEST file - run 'manifest' action first";
 610
 611     # Localize
 612     my %dist_files = map { $self->localize_file_path($_) => $_ } keys %$manifest;
 613
 614     my @pm_files = grep {exists $dist_files{$_}} keys %{ $self->find_pm_files };
 615
 616     my $actual_version = $self->dist_version;
 617
 618     # First, we enumerate all packages & versions,
 619     # seperating into primary & alternative candidates
 620     my( %prime, %alt );
 621     foreach my $file (@pm_files) {
 622         next if $dist_files{$file} =~ m{^t/};  # Skip things in t/
 623
 624         my @path = split( /\//, $dist_files{$file} );
 625         (my $prime_package = join( '::', @path[1..$#path] )) =~ s/\.pm$//;
 626
 627         my $pm_info = Module::Build::ModuleInfo->new_from_file( $file );
 628
 629         foreach my $package ( $pm_info->packages_inside ) {
 630             next if $package eq 'main';  # main can appear numerous times, ignore
 631             next if grep /^_/, split( /::/, $package ); # private package, ignore
 632
 633             my $version = $pm_info->version( $package );
 634             if ($version && $version != $actual_version) {
 635                 $self->log_warn("Package $package had version $version!\n");
 636             }
 637             $version = $actual_version;
 638
 639             if ( $package eq $prime_package ) {
 640                 if ( exists( $prime{$package} ) ) {
 641                     # M::B::ModuleInfo will handle this conflict
 642                     die "Unexpected conflict in '$package'; multiple versions found.\n";
 643                 }
 644                 else {
 645                     $prime{$package}{file} = $dist_files{$file};
 646                     $prime{$package}{version} = $version if defined( $version );
 647                 }
 648             }
 649             else {
 650                 push( @{$alt{$package}}, { file => $dist_files{$file}, version => $version } );
 651             }
 652         }
 653     }
 654
 655     # Then we iterate over all the packages found above, identifying conflicts
 656     # and selecting the "best" candidate for recording the file & version
 657     # for each package.
 658     foreach my $package ( keys( %alt ) ) {
 659         my $result = $self->_resolve_module_versions( $alt{$package} );
 660
 661         if ( exists( $prime{$package} ) ) { # primary package selected
 662             if ( $result->{err} ) {
 663                 # Use the selected primary package, but there are conflicting
 664                  # errors amoung multiple alternative packages that need to be
 665                  # reported
 666                  $self->log_warn("Found conflicting versions for package '$package'\n" .
 667                                  "  $prime{$package}{file} ($prime{$package}{version})\n" . $result->{err});
 668             }
 669             elsif ( defined( $result->{version} ) ) {
 670                 # There is a primary package selected, and exactly one
 671                 # alternative package
 672
 673                 if ( exists( $prime{$package}{version} ) && defined( $prime{$package}{version} ) ) {
 674                     # Unless the version of the primary package agrees with the
 675                     # version of the alternative package, report a conflict
 676                     if ( $self->compare_versions( $prime{$package}{version}, '!=', $result->{version} ) ) {
 677                         $self->log_warn("Found conflicting versions for package '$package'\n" .
 678                                         "  $prime{$package}{file} ($prime{$package}{version})\n" .
 679                                         "  $result->{file} ($result->{version})\n");
 680                     }
 681                 }
 682                 else {
 683                   # The prime package selected has no version so, we choose to
 684                   # use any alternative package that does have a version
 685                   $prime{$package}{file}    = $result->{file};
 686                   $prime{$package}{version} = $result->{version};
 687                 }
 688             }
 689             else {
 690                 # no alt package found with a version, but we have a prime
 691                 # package so we use it whether it has a version or not
 692             }
 693         }
 694         else { # No primary package was selected, use the best alternative
 695             if ( $result->{err} ) {
 696                 $self->log_warn("Found conflicting versions for package '$package'\n" . $result->{err});
 697             }
 698
 699             # Despite possible conflicting versions, we choose to record
 700             # something rather than nothing
 701             $prime{$package}{file}    = $result->{file};
 702             $prime{$package}{version} = $result->{version} if defined( $result->{version} );
 703         }
 704     }
 705
 706     # Stringify versions
 707     for (grep exists $_->{version}, values %prime) {
 708         $_->{version} = $_->{version}->stringify if ref($_->{version});
 709     }
 710
 711     return \%prime;
 712 }
 713
 714 # our recommends syntax contains extra info that needs to be ignored at this
 715 # stage
 716 sub _parse_conditions {
 717     my ($self, $spec) = @_;
 718
 719     ($spec) = split("/", $spec);
 720
 721     if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores
 722         return (">= $spec");
 723     }
 724     else {
 725         return split /\s*,\s*/, $spec;
 726     }
 727 }
 728
 729 # when generating META.yml, we output optional_features syntax (instead of
 730 # recommends syntax). Note that as of CPAN v1.9402 nothing useful is done
 731 # with this information, which is why we implement our own request to install
 732 # the optional modules in install_optional().
 733 # Also note that CPAN PLUS complains with an [ERROR] when it sees this META.yml,
 734 # but it isn't fatal and installation continues fine.
 735
 736 # 'recommends' groups broken up now into separate modules and grouping the
 737 # 'requires' instead of lumping modules together (quotes were choking YAML
 738 # parsing). Now passes Parse::CPAN::Meta w/o errors.
 739 # -cjfields 9-17-09
 740
 741 sub prepare_metadata {
 742     my ($self, $node, $keys) = @_;
 743     my $p = $self->{properties};
 744
 745     # A little helper sub
 746     my $add_node = sub {
 747         my ($name, $val) = @_;
 748         $node->{$name} = $val;
 749         push @$keys, $name if $keys;
 750     };
 751
 752     foreach (qw(dist_name dist_version dist_author dist_abstract license)) {
 753         (my $name = $_) =~ s/^dist_//;
 754         $add_node->($name, $self->$_());
 755         die "ERROR: Missing required field '$_' for META.yml\n" unless defined($node->{$name}) && length($node->{$name});
 756     }
 757     $node->{version} = '' . $node->{version}; # Stringify version objects
 758
 759     if (defined( $self->license ) && defined( my $url = $self->valid_licenses->{ $self->license } )) {
 760         $node->{resources}{license} = $url;
 761     }
 762
 763     foreach ( @{$self->prereq_action_types} ) {
 764         if (exists $p->{$_} and keys %{ $p->{$_} }) {
 765             if ($_ eq 'recommends') {
 766                 my $hash;
 767                 while (my ($req, $val) = each %{ $p->{$_} }) {
 768                     my ($ver, $why, $mods) = split("/", $val);
 769                     for my $used_by (split ',',$mods) {
 770                         $used_by =~ s{^(\S+)\s.*$}{$1};
 771                         if (exists $hash->{$used_by}) {
 772                             push @{$hash->{$used_by}->{requires}}, {$req => $ver};
 773                         } else {
 774                             $hash->{$used_by} = {description => $why,
 775                                     requires    => [{$req => $ver}]};
 776                         }
 777                     }
 778                 }
 779                 $add_node->('optional_features', $hash);
 780             }
 781             else {
 782                 $add_node->($_, $p->{$_});
 783             }
 784         }
 785     }
 786
 787     if (exists $p->{dynamic_config}) {
 788         $add_node->('dynamic_config', $p->{dynamic_config});
 789     }
 790     my $pkgs = eval { $self->find_dist_packages };
 791     if ($@) {
 792         $self->log_warn("$@\nWARNING: Possible missing or corrupt 'MANIFEST' file.\n" . "Nothing to enter for 'provides' field in META.yml\n");
 793     }
 794     else {
 795         $node->{provides} = $pkgs if %$pkgs;
 796     };
 797
 798     if (exists $p->{no_index}) {
 799         $add_node->('no_index', $p->{no_index});
 800     }
 801
 802     $add_node->('generated_by', "Module::Build version $Module::Build::VERSION");
 803
 804     $add_node->('meta-spec',
 805             {version => '1.2',
 806              url     => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
 807             });
 808
 809     while (my($k, $v) = each %{$self->meta_add}) {
 810         $add_node->($k, $v);
 811     }
 812
 813     while (my($k, $v) = each %{$self->meta_merge}) {
 814         $self->_hash_merge($node, $k, $v);
 815     }
 816
 817     return $node;
 818 }
 819
 820 # let us store extra things persistently in _build
 821 sub _construct {
 822     my $self = shift;
 823
 824     # calling SUPER::_construct will dump some of the input to this sub out
 825     # with Data::Dumper, which will complain about code refs. So we replace
 826     # any code refs with dummies first, then put them back afterwards
 827     my %in_hash = @_;
 828     my $auto_features = $in_hash{auto_features} if defined $in_hash{auto_features};
 829     my %code_refs;
 830     if ($auto_features) {
 831         while (my ($key, $hash) = each %{$auto_features}) {
 832             while (my ($sub_key, $val) = each %{$hash}) {
 833                 if (ref($val) && ref($val) eq 'CODE') {
 834                     $hash->{$sub_key} = 'CODE_ref';
 835                     $code_refs{$key}->{$sub_key} = $val;
 836                 }
 837             }
 838         }
 839     }
 840
 841     $self = $self->SUPER::_construct(@_);
 842
 843     my ($p, $ph) = ($self->{properties}, $self->{phash});
 844
 845     if (keys %code_refs) {
 846         while (my ($key, $hash) = each %{$auto_features}) {
 847             if (defined $code_refs{$key}) {
 848                 while (my ($sub_key, $code_ref) = each %{$code_refs{$key}}) {
 849                     $hash->{$sub_key} = $code_ref;
 850                 }
 851                 $ph->{auto_features}->{$key} = $hash;
 852             }
 853         }
 854     }
 855
 856     foreach (qw(manifest_skip post_install_scripts)) {
 857         my $file = File::Spec->catfile($self->config_dir, $_);
 858         $ph->{$_} = Module::Build::Notes->new(file => $file);
 859         $ph->{$_}->restore if -e $file;
 860     }
 861
 862     return $self;
 863 }
 864 sub write_config {
 865     my $self = shift;
 866     $self->SUPER::write_config;
 867
 868     # write extra things
 869     $self->{phash}{$_}->write() foreach qw(manifest_skip post_install_scripts);
 870
 871     # be even more certain we can reload ourselves during a resume by copying
 872     # ourselves to _build\lib
 873     # this is only possible for the core distribution where we are actually
 874     # present in the distribution
 875     my $self_filename = File::Spec->catfile('Bio', 'Root', 'Build.pm');
 876     -e $self_filename || return;
 877
 878     my $filename = File::Spec->catfile($self->{properties}{config_dir}, 'lib', 'Bio', 'Root', 'Build.pm');
 879     my $filedir  = File::Basename::dirname($filename);
 880
 881     File::Path::mkpath($filedir);
 882     warn "Can't create directory $filedir: $!" unless -d $filedir;
 883
 884     File::Copy::copy($self_filename, $filename);
 885     warn "Unable to copy 'Bio/Root/Build.pm' to '$filename'\n" unless -e $filename;
 886 }
 887
 888 # add a file to the default MANIFEST.SKIP
 889 sub add_to_manifest_skip {
 890     my $self = shift;
 891     my %files = map {$self->localize_file_path($_), 1} @_;
 892     $self->{phash}{manifest_skip}->write(\%files);
 893 }
 894
 895 # we always generate a new MANIFEST and MANIFEST.SKIP here, instead of allowing
 896 # existing files to remain
 897 sub ACTION_manifest {
 898     my ($self) = @_;
 899
 900     my $maniskip = 'MANIFEST.SKIP';
 901     if ( -e 'MANIFEST' || -e $maniskip ) {
 902         $self->log_warn("MANIFEST files already exist, will overwrite them\n");
 903         unlink('MANIFEST');
 904         unlink($maniskip);
 905     }
 906     $self->_write_default_maniskip($maniskip);
 907
 908     require ExtUtils::Manifest;  # ExtUtils::Manifest is not warnings clean.
 909     local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
 910     ExtUtils::Manifest::mkmanifest();
 911 }
 912
 913 # extended to add extra things to the default MANIFEST.SKIP
 914 sub _write_default_maniskip {
 915     my $self = shift;
 916     $self->SUPER::_write_default_maniskip;
 917
 918     my @extra = keys %{$self->{phash}{manifest_skip}->read};
 919     if (@extra) {
 920         open(my $fh, '>>', 'MANIFEST.SKIP') or die "Could not open MANIFEST.SKIP file\n";
 921         print $fh "\n# Avoid additional run-time generated things\n";
 922         foreach my $line (@extra) {
 923             print $fh $line, "\n";
 924         }
 925         close($fh);
 926     }
 927 }
 928
 929 # extended to run scripts post-installation
 930 sub ACTION_install {
 931   my ($self) = @_;
 932   require ExtUtils::Install;
 933   $self->depends_on('build');
 934   ExtUtils::Install::install($self->install_map, !$self->quiet, 0, $self->{args}{uninst}||0);
 935   $self->run_post_install_scripts;
 936 }
 937 sub add_post_install_script {
 938     my $self = shift;
 939     my %files = map {$self->localize_file_path($_), 1} @_;
 940     $self->{phash}{post_install_scripts}->write(\%files);
 941 }
 942 sub run_post_install_scripts {
 943     my $self = shift;
 944     my @scripts = keys %{$self->{phash}{post_install_scripts}->read};
 945     foreach my $script (@scripts) {
 946         $self->run_perl_script($script);
 947     }
 948 }
 949
 950 # for use with auto_features, which should require LWP::UserAgent as one of
 951 # its reqs
 952 sub test_internet {
 953     eval {require LWP::UserAgent;};
 954     if ($@) {
 955         # ideally this won't happen because auto_feature already specified
 956         # LWP::UserAgent, so this sub wouldn't get called if LWP not installed
 957         return "LWP::UserAgent not installed";
 958     }
 959     my $ua = LWP::UserAgent->new;
 960     $ua->timeout(10);
 961     $ua->env_proxy;
 962     my $response = $ua->get('http://search.cpan.org/');
 963     unless ($response->is_success) {
 964         return "Could not connect to the internet (http://search.cpan.org/)";
 965     }
 966     return;
 967 }
 968
 969 # nice directory names for dist-related actions
 970 sub dist_dir {
 971     my ($self) = @_;
 972     my $version = $self->dist_version;
 973     if ($version =~ /^\d\.\d{6}\d$/) {
 974         # 1.x.x.100 returned as 1.x.x.1
 975         $version .= '00';
 976     }
 977     $version =~ s/00(\d)/$1./g;
 978     $version =~ s/\.$//;
 979
 980     if (my ($minor, $rev) = $version =~ /^\d\.(\d)\.\d\.(\d+)$/) {
 981         my $dev = ! ($minor % 2 == 0);
 982         if ($rev == 100) {
 983             my $replace = $dev ? "_$rev" : '';
 984             $version =~ s/\.\d+$/$replace/;
 985         }
 986         elsif ($rev < 100) {
 987             $rev = sprintf("%03d", $rev);
 988             $version =~ s/\.\d+$/_$rev-RC/;
 989         }
 990         else {
 991             $rev -= 100 unless $dev;
 992             my $replace = $dev ? "_$rev" : ".$rev";
 993             $version =~ s/\.\d+$/$replace/;
 994         }
 995     }
 996
 997     return "$self->{properties}{dist_name}-$version";
 998 }
 999 sub ppm_name {
1000     my $self = shift;
1001     return $self->dist_dir.'-ppm';
1002 }
1003
1004 # generate complete ppd4 version file
1005 sub ACTION_ppd {
1006     my $self = shift;
1007
1008     my $file = $self->make_ppd(%{$self->{args}});
1009     $self->add_to_cleanup($file);
1010     $self->add_to_manifest_skip($file);
1011 }
1012
1013 # add pod2htm temp files to MANIFEST.SKIP, generated during ppmdist most likely
1014 sub htmlify_pods {
1015     my $self = shift;
1016     $self->SUPER::htmlify_pods(@_);
1017     $self->add_to_manifest_skip('pod2htm*');
1018 }
1019
1020 # don't copy across man3 docs since they're of little use under Windows and
1021 # have bad filenames
1022 sub ACTION_ppmdist {
1023     my $self = shift;
1024     my @types = $self->install_types(1);
1025     $self->SUPER::ACTION_ppmdist(@_);
1026     $self->install_types(0);
1027 }
1028
1029 # when supplied a true value, pretends libdoc doesn't exist (preventing man3
1030 # installation for ppmdist). when supplied false, they exist again
1031 sub install_types {
1032     my ($self, $no_libdoc) = @_;
1033     $self->{no_libdoc} = $no_libdoc if defined $no_libdoc;
1034     my @types = $self->SUPER::install_types;
1035     if ($self->{no_libdoc}) {
1036         my @altered_types;
1037         foreach my $type (@types) {
1038             push(@altered_types, $type) unless $type eq 'libdoc';
1039         }
1040         return @altered_types;
1041     }
1042     return @types;
1043 }
1044
1045 # overridden from Module::Build::PPMMaker for ppd4 compatability
1046 sub make_ppd {
1047     my ($self, %args) = @_;
1048
1049     require Module::Build::PPMMaker;
1050     my $mbp = Module::Build::PPMMaker->new();
1051
1052     my %dist;
1053     foreach my $info (qw(name author abstract version)) {
1054         my $method = "dist_$info";
1055         $dist{$info} = $self->$method() or die "Can't determine distribution's $info\n";
1056     }
1057     $dist{codebase} = $self->ppm_name.'.tar.gz';
1058     $mbp->_simple_xml_escape($_) foreach $dist{abstract}, $dist{codebase}, @{$dist{author}};
1059
1060     my (undef, undef, undef, $mday, $mon, $year) = localtime();
1061     $year += 1900;
1062     $mon++;
1063     my $date = "$year-$mon-$mday";
1064
1065     my $softpkg_version = $self->dist_dir;
1066     $softpkg_version =~ s/^$dist{name}-//;
1067
1068     # to avoid a ppm bug, instead of including the requires in the softpackage
1069     # for the distribution we're making, we'll make a seperate Bundle::
1070     # softpackage that contains all the requires, and require only the Bundle in
1071     # the real softpackage
1072     my ($bundle_name) = $dist{name} =~ /^.+-(.+)/;
1073     $bundle_name ||= 'core';
1074     $bundle_name =~ s/^(\w)/\U$1/;
1075     my $bundle_dir = "Bundle-BioPerl-$bundle_name-$softpkg_version-ppm";
1076     my $bundle_file = "$bundle_dir.tar.gz";
1077     my $bundle_softpkg_name = "Bundle-BioPerl-$bundle_name";
1078     $bundle_name = "Bundle::BioPerl::$bundle_name";
1079
1080     # header
1081     my $ppd = <<"PPD";
1082     <SOFTPKG NAME=\"$dist{name}\" VERSION=\"$softpkg_version\" DATE=\"$date\">
1083         <TITLE>$dist{name}</TITLE>
1084         <ABSTRACT>$dist{abstract}</ABSTRACT>
1085 @{[ join "\n", map "        <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
1086         <PROVIDE NAME=\"$dist{name}::\" VERSION=\"$dist{version}\"/>
1087 PPD
1088
1089     # provide section
1090     foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) {
1091         # convert these filepaths to Module names
1092         $pm =~ s/\//::/g;
1093         $pm =~ s/\.pm//;
1094
1095         $ppd .= sprintf(<<'EOF', $pm, $dist{version});
1096         <PROVIDE NAME="%s" VERSION="%s"/>
1097 EOF
1098     }
1099
1100     # rest of softpkg
1101     $ppd .= <<"PPD";
1102         <IMPLEMENTATION>
1103             <ARCHITECTURE NAME=\"MSWin32-x86-multi-thread-5.8\"/>
1104             <CODEBASE HREF=\"$dist{codebase}\"/>
1105             <REQUIRE NAME=\"$bundle_name\" VERSION=\"$dist{version}\"/>
1106         </IMPLEMENTATION>
1107     </SOFTPKG>
1108 PPD
1109
1110     # now a new softpkg for the bundle
1111     $ppd .= <<"PPD";
1112
1113     <SOFTPKG NAME=\"$bundle_softpkg_name\" VERSION=\"$softpkg_version\" DATE=\"$date\">
1114         <TITLE>$bundle_name</TITLE>
1115         <ABSTRACT>Bundle of pre-requisites for $dist{name}</ABSTRACT>
1116 @{[ join "\n", map "        <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
1117         <PROVIDE NAME=\"$bundle_name\" VERSION=\"$dist{version}\"/>
1118         <IMPLEMENTATION>
1119             <ARCHITECTURE NAME=\"MSWin32-x86-multi-thread-5.8\"/>
1120             <CODEBASE HREF=\"$bundle_file\"/>
1121 PPD
1122
1123     # required section
1124     # we do both requires and recommends to make installation on Windows as
1125     # easy (mindless) as possible
1126     for my $type ('requires', 'recommends') {
1127         my $prereq = $self->$type;
1128         while (my ($modname, $version) = each %$prereq) {
1129             next if $modname eq 'perl';
1130             ($version) = split("/", $version) if $version =~ /\//;
1131
1132             # Module names must have at least one ::
1133             unless ($modname =~ /::/) {
1134                 $modname .= '::';
1135             }
1136
1137             # Bio::Root::Version number comes out as triplet number like 1.5.2;
1138             # convert to our own version
1139             if ($modname eq 'Bio::Root::Version') {
1140                 $version = $dist{version};
1141             }
1142
1143             $ppd .= sprintf(<<'EOF', $modname, $version || '');
1144             <REQUIRE NAME="%s" VERSION="%s"/>
1145 EOF
1146         }
1147     }
1148
1149     # footer
1150     $ppd .= <<'EOF';
1151         </IMPLEMENTATION>
1152     </SOFTPKG>
1153 EOF
1154
1155     my $ppd_file = "$dist{name}.ppd";
1156     my $fh = IO::File->new(">$ppd_file") or die "Cannot write to $ppd_file: $!";
1157     print $fh $ppd;
1158     close $fh;
1159
1160     $self->delete_filetree($bundle_dir);
1161     mkdir($bundle_dir) or die "Cannot create '$bundle_dir': $!";
1162     $self->make_tarball($bundle_dir);
1163     $self->delete_filetree($bundle_dir);
1164     $self->add_to_cleanup($bundle_file);
1165     $self->add_to_manifest_skip($bundle_file);
1166
1167     return $ppd_file;
1168 }
1169
1170 # we make all archive formats we want, not just .tar.gz
1171 # we also auto-run manifest action, since we always want to re-create
1172 # MANIFEST and MANIFEST.SKIP just-in-time
1173 sub ACTION_dist {
1174     my ($self) = @_;
1175
1176     $self->depends_on('manifest');
1177     $self->depends_on('distdir');
1178
1179     my $dist_dir = $self->dist_dir;
1180
1181     $self->make_zip($dist_dir);
1182     $self->make_tarball($dist_dir);
1183     $self->delete_filetree($dist_dir);
1184 }
1185
1186 # makes zip file for windows users and bzip2 files as well
1187 sub make_zip {
1188     my ($self, $dir, $file) = @_;
1189     $file ||= $dir;
1190
1191     $self->log_info("Creating $file.zip\n");
1192     my $zip_flags = $self->verbose ? '-r' : '-rq';
1193     $self->do_system($self->split_like_shell("zip"), $zip_flags, "$file.zip", $dir);
1194
1195     $self->log_info("Creating $file.bz2\n");
1196     require Archive::Tar;
1197     # Archive::Tar versions >= 1.09 use the following to enable a compatibility
1198     # hack so that the resulting archive is compatible with older clients.
1199     $Archive::Tar::DO_NOT_USE_PREFIX = 0;
1200     my $files = $self->rscan_dir($dir);
1201     Archive::Tar->create_archive("$file.tar", 0, @$files);
1202     $self->do_system($self->split_like_shell("bzip2"), "-k", "$file.tar");
1203 }
1204
1205 # a method that can be called in a Build.PL script to ask the user if they want
1206 # internet tests.
1207 # Should only be called if you have tested for yourself that
1208 # $build->feature('Network') is true
1209 sub prompt_for_network {
1210     my ($self, $accept) = @_;
1211
1212     my $proceed = $accept ? 0 : $self->y_n("Do you want to run tests that require connection to servers across the internet\n(likely to cause some failures)? y/n", 'n');
1213
1214     if ($proceed) {
1215         $self->notes(network => 1);
1216         $self->log_info("  - will run internet-requiring tests\n");
1217         my $use_email = $self->y_n("Do you want to run tests requiring a valid email address? y/n",'n');
1218         if ($use_email) {
1219             my $address = $self->prompt("Enter email address:");
1220             $self->notes(email => $address);
1221         }
1222     }
1223     else {
1224         $self->notes(network => 0);
1225         $self->log_info("  - will not run internet-requiring tests\n");
1226     }
1227 }
1228
1229 1;