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