Bio/Root/Build.pm

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