Bio/Root/Build.pm

   1 #
   2 # BioPerl module for Bio::Root::Build
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Sendu Bala <bix@sendu.me.uk>
   7 #
   8 # Copyright Sendu Bala
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 # POD documentation - main docs before the code
  13
  14 =head1 NAME
  15
  16 Bio::Root::Build - A common Module::Build subclass base for BioPerl distributions
  17
  18 =head1 SYNOPSIS
  19
  20   ...TO BE ADDED
  21
  22 =head1 DESCRIPTION
  23
  24 This is a subclass of Module::Build so we can override certain methods and do
  25 fancy stuff
  26
  27 It was first written against Module::Build::Base v0.2805. Many of the methods
  28 here are copy/pasted from there in their entirety just to change one or two
  29 minor things, since for the most part Module::Build::Base code is hard to
  30 cleanly override.
  31
  32 =head1 FEEDBACK
  33
  34 =head2 Mailing Lists
  35
  36 User feedback is an integral part of the evolution of this and other
  37 Bioperl modules. Send your comments and suggestions preferably to
  38 the Bioperl mailing list.  Your participation is much appreciated.
  39
  40   bioperl-l@bioperl.org                  - General discussion
  41   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  42
  43 =head2 Support
  44
  45 Please direct usage questions or support issues to the mailing list:
  46
  47 I<bioperl-l@bioperl.org>
  48
  49 rather than to the module maintainer directly. Many experienced and
  50 reponsive experts will be able look at the problem and quickly
  51 address it. Please include a thorough description of the problem
  52 with code and data examples if at all possible.
  53
  54 =head2 Reporting Bugs
  55
  56 Report bugs to the Bioperl bug tracking system to help us keep track
  57 of the bugs and their resolution. Bug reports can be submitted via
  58 the web:
  59
  60   https://redmine.open-bio.org/projects/bioperl/
  61
  62 =head1 AUTHOR - Sendu Bala
  63
  64 Email bix@sendu.me.uk
  65
  66 =head1 APPENDIX
  67
  68 The rest of the documentation details each of the object methods.
  69 Internal methods are usually preceded with a _
  70
  71 =cut
  72
  73 package Bio::Root::Build;
  74
  75 BEGIN {
  76     # we really need Module::Build to be installed
  77     eval "use base Module::Build; 1" or die "This package requires Module::Build v0.2805 or greater to install itself.\n$@";
  78
  79     # ensure we'll be able to reload this module later by adding its path to inc
  80     use Cwd;
  81     use lib Cwd::cwd();
  82 }
  83
  84 use strict;
  85 use warnings;
  86
  87 our $VERSION = '1.006900'; # pre-1.7
  88 our @extra_types = qw(options excludes_os feature_requires test); # test must always be last in the list!
  89 our $checking_types = "requires|conflicts|".join("|", @extra_types);
  90
  91
  92 # our modules are in Bio, not lib
  93 sub find_pm_files {
  94     my $self = shift;
  95     foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) {
  96         $self->{properties}{pm_files}->{$pm} = File::Spec->catfile('lib', $pm);
  97     }
  98
  99     $self->_find_file_by_type('pm', 'lib');
 100 }
 101
 102 # ask what scripts to install (this method is unique to bioperl)
 103 sub choose_scripts {
 104     my $self = shift;
 105     my $accept = shift;
 106
 107     # we can offer interactive installation by groups only if we have subdirs
 108     # in scripts and no .PLS files there
 109     opendir(my $scripts_dir, 'scripts') or die "Can't open directory 'scripts': $!\n";
 110     my $int_ok = 0;
 111     my @group_dirs;
 112     while (my $thing = readdir($scripts_dir)) {
 113         next if $thing =~ /^\./;
 114         next if $thing eq 'CVS';
 115         if ($thing =~ /PLS$|pl$/) {
 116             $int_ok = 0;
 117             last;
 118         }
 119         $thing = File::Spec->catfile('scripts', $thing);
 120         if (-d $thing) {
 121             $int_ok = 1;
 122             push(@group_dirs, $thing);
 123         }
 124     }
 125     closedir($scripts_dir);
 126     my $question = $int_ok ? "Install [a]ll BioPerl scripts, [n]one, or choose groups [i]nteractively?" : "Install [a]ll BioPerl scripts or [n]one?";
 127
 128     my $prompt = $accept ? 'a' : $self->prompt($question, 'a');
 129
 130     if ($prompt =~ /^[aA]/) {
 131         $self->log_info("  - will install all scripts\n");
 132         $self->notes(chosen_scripts => 'all');
 133     }
 134     elsif ($prompt =~ /^[iI]/) {
 135         $self->log_info("  - will install interactively:\n");
 136
 137         my @chosen_scripts;
 138         foreach my $group_dir (@group_dirs) {
 139             my $group = File::Basename::basename($group_dir);
 140             print "    * group '$group' has:\n";
 141
 142             my @script_files = @{$self->rscan_dir($group_dir, qr/\.PLS$|\.pl$/)};
 143             foreach my $script_file (@script_files) {
 144                 my $script = File::Basename::basename($script_file);
 145                 print "      $script\n";
 146             }
 147
 148             my $result = $self->prompt("    Install scripts for group '$group'? [y]es [n]o [q]uit", 'n');
 149             die if $result =~ /^[qQ]/;
 150             if ($result =~ /^[yY]/) {
 151                 $self->log_info("      + will install group '$group'\n");
 152                 push(@chosen_scripts, @script_files);
 153             }
 154             else {
 155                 $self->log_info("      - will not install group '$group'\n");
 156             }
 157         }
 158
 159         my $chosen_scripts = @chosen_scripts ? join("|", @chosen_scripts) : 'none';
 160
 161         $self->notes(chosen_scripts => $chosen_scripts);
 162     }
 163     else {
 164         $self->log_info("  - won't install any scripts\n");
 165         $self->notes(chosen_scripts => 'none');
 166     }
 167
 168     print "\n";
 169 }
 170
 171 # our version of script_files doesn't take args but just installs those scripts
 172 # requested by the user after choose_scripts() is called. If it wasn't called,
 173 # installs all scripts in scripts directory
 174 sub script_files {
 175     my $self = shift;
 176
 177     unless (-d 'scripts') {
 178         return {};
 179     }
 180
 181     my $chosen_scripts = $self->notes('chosen_scripts');
 182     if ($chosen_scripts) {
 183         return if $chosen_scripts eq 'none';
 184         return { map {$_, 1} split(/\|/, $chosen_scripts) } unless $chosen_scripts eq 'all';
 185     }
 186
 187     return $_ = { map {$_,1} @{$self->rscan_dir('scripts', qr/\.PLS$|\.pl$/)} };
 188 }
 189
 190 # process scripts normally, except that we change name from *.PLS to bp_*.pl
 191 sub process_script_files {
 192     my $self = shift;
 193     my $files = $self->find_script_files;
 194     return unless keys %$files;
 195
 196     my $script_dir = File::Spec->catdir($self->blib, 'script');
 197     File::Path::mkpath( $script_dir );
 198
 199     foreach my $file (keys %$files) {
 200         my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
 201         $self->fix_shebang_line($result) unless $self->os_type eq 'VMS';
 202         $self->make_executable($result);
 203
 204         my $final = File::Basename::basename($result);
 205         $final =~ s/\.PLS$/\.pl/;                  # change from .PLS to .pl
 206         $final =~ s/^/bp_/ unless $final =~ /^bp/; # add the "bp" prefix
 207         $final = File::Spec->catfile($script_dir, $final);
 208         # silence scripts
 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 # let us store extra things persistently in _build
 742 sub _construct {
 743     my $self = shift;
 744
 745     # calling SUPER::_construct will dump some of the input to this sub out
 746     # with Data::Dumper, which will complain about code refs. So we replace
 747     # any code refs with dummies first, then put them back afterwards
 748     my %in_hash = @_;
 749     my $auto_features = $in_hash{auto_features} if defined $in_hash{auto_features};
 750     my %code_refs;
 751     if ($auto_features) {
 752         while (my ($key, $hash) = each %{$auto_features}) {
 753             while (my ($sub_key, $val) = each %{$hash}) {
 754                 if (ref($val) && ref($val) eq 'CODE') {
 755                     $hash->{$sub_key} = 'CODE_ref';
 756                     $code_refs{$key}->{$sub_key} = $val;
 757                 }
 758             }
 759         }
 760     }
 761
 762     $self = $self->SUPER::_construct(@_);
 763
 764     my ($p, $ph) = ($self->{properties}, $self->{phash});
 765
 766     if (keys %code_refs) {
 767         while (my ($key, $hash) = each %{$auto_features}) {
 768             if (defined $code_refs{$key}) {
 769                 while (my ($sub_key, $code_ref) = each %{$code_refs{$key}}) {
 770                     $hash->{$sub_key} = $code_ref;
 771                 }
 772                 $ph->{auto_features}->{$key} = $hash;
 773             }
 774         }
 775     }
 776
 777     foreach (qw(manifest_skip post_install_scripts)) {
 778         my $file = File::Spec->catfile($self->config_dir, $_);
 779         $ph->{$_} = Module::Build::Notes->new(file => $file);
 780         $ph->{$_}->restore if -e $file;
 781     }
 782
 783     return $self;
 784 }
 785 sub write_config {
 786     my $self = shift;
 787     $self->SUPER::write_config;
 788
 789     # write extra things
 790     $self->{phash}{$_}->write() foreach qw(manifest_skip post_install_scripts);
 791
 792     # be even more certain we can reload ourselves during a resume by copying
 793     # ourselves to _build\lib
 794     # this is only possible for the core distribution where we are actually
 795     # present in the distribution
 796     my $self_filename = File::Spec->catfile('Bio', 'Root', 'Build.pm');
 797     -e $self_filename || return;
 798
 799     my $filename = File::Spec->catfile($self->{properties}{config_dir}, 'lib', 'Bio', 'Root', 'Build.pm');
 800     my $filedir  = File::Basename::dirname($filename);
 801
 802     File::Path::mkpath($filedir);
 803     warn "Can't create directory $filedir: $!" unless -d $filedir;
 804
 805     File::Copy::copy($self_filename, $filename);
 806     warn "Unable to copy 'Bio/Root/Build.pm' to '$filename'\n" unless -e $filename;
 807 }
 808
 809 # add a file to the default MANIFEST.SKIP
 810 sub add_to_manifest_skip {
 811     my $self = shift;
 812     my %files = map {$self->localize_file_path($_), 1} @_;
 813     $self->{phash}{manifest_skip}->write(\%files);
 814 }
 815
 816 # we always generate a new MANIFEST and MANIFEST.SKIP here, instead of allowing
 817 # existing files to remain
 818 sub ACTION_manifest {
 819     my ($self) = @_;
 820
 821     my $maniskip = 'MANIFEST.SKIP';
 822     if ( -e 'MANIFEST' || -e $maniskip ) {
 823         $self->log_warn("MANIFEST files already exist, will overwrite them\n");
 824         unlink('MANIFEST');
 825         unlink($maniskip);
 826     }
 827     $self->_write_default_maniskip($maniskip);
 828
 829     require ExtUtils::Manifest;  # ExtUtils::Manifest is not warnings clean.
 830     local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
 831     ExtUtils::Manifest::mkmanifest();
 832 }
 833
 834 # extended to add extra things to the default MANIFEST.SKIP
 835 sub _write_default_maniskip {
 836     my $self = shift;
 837     $self->SUPER::_write_default_maniskip;
 838
 839     my @extra = keys %{$self->{phash}{manifest_skip}->read};
 840     if (@extra) {
 841         open(my $fh, '>>', 'MANIFEST.SKIP') or die "Could not open MANIFEST.SKIP file\n";
 842         print $fh "\n# Avoid additional run-time generated things\n";
 843         foreach my $line (@extra) {
 844             print $fh $line, "\n";
 845         }
 846         close($fh);
 847     }
 848 }
 849
 850 # extended to run scripts post-installation
 851 sub ACTION_install {
 852   my ($self) = @_;
 853   require ExtUtils::Install;
 854   $self->depends_on('build');
 855   ExtUtils::Install::install($self->install_map, !$self->quiet, 0, $self->{args}{uninst}||0);
 856   $self->run_post_install_scripts;
 857 }
 858 sub add_post_install_script {
 859     my $self = shift;
 860     my %files = map {$self->localize_file_path($_), 1} @_;
 861     $self->{phash}{post_install_scripts}->write(\%files);
 862 }
 863 sub run_post_install_scripts {
 864     my $self = shift;
 865     my @scripts = keys %{$self->{phash}{post_install_scripts}->read};
 866     foreach my $script (@scripts) {
 867         $self->run_perl_script($script);
 868     }
 869 }
 870
 871 # for use with auto_features, which should require LWP::UserAgent as one of
 872 # its reqs
 873 sub test_internet {
 874     eval {require LWP::UserAgent;};
 875     if ($@) {
 876         # ideally this won't happen because auto_feature already specified
 877         # LWP::UserAgent, so this sub wouldn't get called if LWP not installed
 878         return "LWP::UserAgent not installed";
 879     }
 880     my $ua = LWP::UserAgent->new;
 881     $ua->timeout(10);
 882     $ua->env_proxy;
 883     my $response = $ua->get('http://search.cpan.org/');
 884     unless ($response->is_success) {
 885         return "Could not connect to the internet (http://search.cpan.org/)";
 886     }
 887     return;
 888 }
 889
 890 # nice directory names for dist-related actions
 891 sub dist_dir {
 892     my ($self) = @_;
 893     my $version = $self->dist_version;
 894     if ($version =~ /^\d\.\d{6}\d$/) {
 895         # 1.x.x.100 returned as 1.x.x.1
 896         $version .= '00';
 897     }
 898     $version =~ s/00(\d)/$1./g;
 899     $version =~ s/\.$//;
 900
 901     if (my ($minor, $rev) = $version =~ /^\d\.(\d)\.\d\.(\d+)$/) {
 902         my $dev = ! ($minor % 2 == 0);
 903         if ($rev == 100) {
 904             my $replace = $dev ? "_$rev" : '';
 905             $version =~ s/\.\d+$/$replace/;
 906         }
 907         elsif ($rev < 100) {
 908             $rev = sprintf("%03d", $rev);
 909             $version =~ s/\.\d+$/_$rev-RC/;
 910         }
 911         else {
 912             $rev -= 100 unless $dev;
 913             my $replace = $dev ? "_$rev" : ".$rev";
 914             $version =~ s/\.\d+$/$replace/;
 915         }
 916     }
 917
 918     return "$self->{properties}{dist_name}-$version";
 919 }
 920 sub ppm_name {
 921     my $self = shift;
 922     return $self->dist_dir.'-ppm';
 923 }
 924
 925 # generate complete ppd4 version file
 926 sub ACTION_ppd {
 927     my $self = shift;
 928
 929     my $file = $self->make_ppd(%{$self->{args}});
 930     $self->add_to_cleanup($file);
 931     $self->add_to_manifest_skip($file);
 932 }
 933
 934 # add pod2htm temp files to MANIFEST.SKIP, generated during ppmdist most likely
 935 sub htmlify_pods {
 936     my $self = shift;
 937     $self->SUPER::htmlify_pods(@_);
 938     $self->add_to_manifest_skip('pod2htm*');
 939 }
 940
 941 # don't copy across man3 docs since they're of little use under Windows and
 942 # have bad filenames
 943 sub ACTION_ppmdist {
 944     my $self = shift;
 945     my @types = $self->install_types(1);
 946     $self->SUPER::ACTION_ppmdist(@_);
 947     $self->install_types(0);
 948 }
 949
 950 # when supplied a true value, pretends libdoc doesn't exist (preventing man3
 951 # installation for ppmdist). when supplied false, they exist again
 952 sub install_types {
 953     my ($self, $no_libdoc) = @_;
 954     $self->{no_libdoc} = $no_libdoc if defined $no_libdoc;
 955     my @types = $self->SUPER::install_types;
 956     if ($self->{no_libdoc}) {
 957         my @altered_types;
 958         foreach my $type (@types) {
 959             push(@altered_types, $type) unless $type eq 'libdoc';
 960         }
 961         return @altered_types;
 962     }
 963     return @types;
 964 }
 965
 966 # overridden from Module::Build::PPMMaker for ppd4 compatability
 967 sub make_ppd {
 968     my ($self, %args) = @_;
 969
 970     require Module::Build::PPMMaker;
 971     my $mbp = Module::Build::PPMMaker->new();
 972
 973     my %dist;
 974     foreach my $info (qw(name author abstract version)) {
 975         my $method = "dist_$info";
 976         $dist{$info} = $self->$method() or die "Can't determine distribution's $info\n";
 977     }
 978     $dist{codebase} = $self->ppm_name.'.tar.gz';
 979     $mbp->_simple_xml_escape($_) foreach $dist{abstract}, $dist{codebase}, @{$dist{author}};
 980
 981     my (undef, undef, undef, $mday, $mon, $year) = localtime();
 982     $year += 1900;
 983     $mon++;
 984     my $date = "$year-$mon-$mday";
 985
 986     my $softpkg_version = $self->dist_dir;
 987     $softpkg_version =~ s/^$dist{name}-//;
 988
 989     # to avoid a ppm bug, instead of including the requires in the softpackage
 990     # for the distribution we're making, we'll make a seperate Bundle::
 991     # softpackage that contains all the requires, and require only the Bundle in
 992     # the real softpackage
 993     my ($bundle_name) = $dist{name} =~ /^.+-(.+)/;
 994     $bundle_name ||= 'core';
 995     $bundle_name =~ s/^(\w)/\U$1/;
 996     my $bundle_dir = "Bundle-BioPerl-$bundle_name-$softpkg_version-ppm";
 997     my $bundle_file = "$bundle_dir.tar.gz";
 998     my $bundle_softpkg_name = "Bundle-BioPerl-$bundle_name";
 999     $bundle_name = "Bundle::BioPerl::$bundle_name";
1000
1001     # header
1002     my $ppd = <<"PPD";
1003     <SOFTPKG NAME=\"$dist{name}\" VERSION=\"$softpkg_version\" DATE=\"$date\">
1004         <TITLE>$dist{name}</TITLE>
1005         <ABSTRACT>$dist{abstract}</ABSTRACT>
1006 @{[ join "\n", map "        <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
1007         <PROVIDE NAME=\"$dist{name}::\" VERSION=\"$dist{version}\"/>
1008 PPD
1009
1010     # provide section
1011     foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) {
1012         # convert these filepaths to Module names
1013         $pm =~ s/\//::/g;
1014         $pm =~ s/\.pm//;
1015
1016         $ppd .= sprintf(<<'EOF', $pm, $dist{version});
1017         <PROVIDE NAME="%s" VERSION="%s"/>
1018 EOF
1019     }
1020
1021     # rest of softpkg
1022     $ppd .= <<"PPD";
1023         <IMPLEMENTATION>
1024             <ARCHITECTURE NAME=\"MSWin32-x86-multi-thread-5.8\"/>
1025             <CODEBASE HREF=\"$dist{codebase}\"/>
1026             <REQUIRE NAME=\"$bundle_name\" VERSION=\"$dist{version}\"/>
1027         </IMPLEMENTATION>
1028     </SOFTPKG>
1029 PPD
1030
1031     # now a new softpkg for the bundle
1032     $ppd .= <<"PPD";
1033
1034     <SOFTPKG NAME=\"$bundle_softpkg_name\" VERSION=\"$softpkg_version\" DATE=\"$date\">
1035         <TITLE>$bundle_name</TITLE>
1036         <ABSTRACT>Bundle of pre-requisites for $dist{name}</ABSTRACT>
1037 @{[ join "\n", map "        <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
1038         <PROVIDE NAME=\"$bundle_name\" VERSION=\"$dist{version}\"/>
1039         <IMPLEMENTATION>
1040             <ARCHITECTURE NAME=\"MSWin32-x86-multi-thread-5.8\"/>
1041             <CODEBASE HREF=\"$bundle_file\"/>
1042 PPD
1043
1044     # required section
1045     # we do both requires and recommends to make installation on Windows as
1046     # easy (mindless) as possible
1047     for my $type ('requires', 'recommends') {
1048         my $prereq = $self->$type;
1049         while (my ($modname, $version) = each %$prereq) {
1050             next if $modname eq 'perl';
1051             ($version) = split("/", $version) if $version =~ /\//;
1052
1053             # Module names must have at least one ::
1054             unless ($modname =~ /::/) {
1055                 $modname .= '::';
1056             }
1057
1058             # Bio::Root::Version number comes out as triplet number like 1.5.2;
1059             # convert to our own version
1060             if ($modname eq 'Bio::Root::Version') {
1061                 $version = $dist{version};
1062             }
1063
1064             $ppd .= sprintf(<<'EOF', $modname, $version || '');
1065             <REQUIRE NAME="%s" VERSION="%s"/>
1066 EOF
1067         }
1068     }
1069
1070     # footer
1071     $ppd .= <<'EOF';
1072         </IMPLEMENTATION>
1073     </SOFTPKG>
1074 EOF
1075
1076     my $ppd_file = "$dist{name}.ppd";
1077     my $fh = IO::File->new(">$ppd_file") or die "Cannot write to $ppd_file: $!";
1078     print $fh $ppd;
1079     close $fh;
1080
1081     $self->delete_filetree($bundle_dir);
1082     mkdir($bundle_dir) or die "Cannot create '$bundle_dir': $!";
1083     $self->make_tarball($bundle_dir);
1084     $self->delete_filetree($bundle_dir);
1085     $self->add_to_cleanup($bundle_file);
1086     $self->add_to_manifest_skip($bundle_file);
1087
1088     return $ppd_file;
1089 }
1090
1091 # we make all archive formats we want, not just .tar.gz
1092 # we also auto-run manifest action, since we always want to re-create
1093 # MANIFEST and MANIFEST.SKIP just-in-time
1094 sub ACTION_dist {
1095     my ($self) = @_;
1096
1097     $self->depends_on('manifest');
1098     $self->depends_on('distdir');
1099
1100     my $dist_dir = $self->dist_dir;
1101
1102     $self->make_zip($dist_dir);
1103     $self->make_tarball($dist_dir);
1104     $self->delete_filetree($dist_dir);
1105 }
1106
1107 # makes zip file for windows users and bzip2 files as well
1108 sub make_zip {
1109     my ($self, $dir, $file) = @_;
1110     $file ||= $dir;
1111
1112     $self->log_info("Creating $file.zip\n");
1113     my $zip_flags = $self->verbose ? '-r' : '-rq';
1114     $self->do_system($self->split_like_shell("zip"), $zip_flags, "$file.zip", $dir);
1115
1116     $self->log_info("Creating $file.bz2\n");
1117     require Archive::Tar;
1118     # Archive::Tar versions >= 1.09 use the following to enable a compatibility
1119     # hack so that the resulting archive is compatible with older clients.
1120     $Archive::Tar::DO_NOT_USE_PREFIX = 0;
1121     my $files = $self->rscan_dir($dir);
1122     Archive::Tar->create_archive("$file.tar", 0, @$files);
1123     $self->do_system($self->split_like_shell("bzip2"), "-k", "$file.tar");
1124 }
1125
1126 # a method that can be called in a Build.PL script to ask the user if they want
1127 # internet tests.
1128 # Should only be called if you have tested for yourself that
1129 # $build->feature('Network') is true
1130 sub prompt_for_network {
1131     my ($self, $accept) = @_;
1132
1133     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');
1134
1135     if ($proceed) {
1136         $self->notes(network => 1);
1137         $self->log_info("  - will run internet-requiring tests\n");
1138         my $use_email = $self->y_n("Do you want to run tests requiring a valid email address? y/n",'n');
1139         if ($use_email) {
1140             my $address = $self->prompt("Enter email address:");
1141             $self->notes(email => $address);
1142         }
1143     }
1144     else {
1145         $self->notes(network => 0);
1146         $self->log_info("  - will not run internet-requiring tests\n");
1147     }
1148 }
1149
1150 1;