ModuleBuildBioperl.pm

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