Bio/Root/Build.pm

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