Bio/Root/Build.pm

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