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 package ModuleBuildBioperl;
  12
  13 BEGIN {
  14     # we really need Module::Build to be installed
  15     unless (eval "use Module::Build; 1") {
  16         print "This package requires Module::Build to install itself.\n";
  17
  18         require ExtUtils::MakeMaker;
  19         my $yn = ExtUtils::MakeMaker::prompt('  Install Module::Build now from CPAN?', 'y');
  20
  21         unless ($yn =~ /^y/i) {
  22             die " *** Cannot install without Module::Build.  Exiting ...\n";
  23         }
  24
  25         require Cwd;
  26         require File::Spec;
  27         require File::Copy;
  28         require CPAN;
  29
  30         # Save this because CPAN will chdir all over the place.
  31         my $cwd = Cwd::cwd();
  32
  33         my $build_pl = File::Spec->catfile($cwd, "Build.PL");
  34
  35         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
  36         CPAN::Shell->install('Module::Build');
  37         File::Copy::move($build_pl."hidden", $build_pl);
  38         CPAN::Shell->expand("Module", "Module::Build")->uptodate or die "Couldn't install Module::Build, giving up.\n";
  39
  40         chdir $cwd or die "Cannot chdir() back to $cwd: $!";
  41     }
  42
  43     eval "use base Module::Build; 1" or die $@;
  44
  45     # ensure we'll be able to reload this module later by adding its path to inc
  46     use Cwd;
  47     use lib Cwd::cwd();
  48 }
  49
  50 use strict;
  51 use warnings;
  52
  53 our $VERSION = 1.005002005;
  54 our @extra_types = qw(options test excludes_os);
  55 our $checking_types = "requires|conflicts|".join("|", @extra_types);
  56
  57
  58 # our modules are in Bio, not lib
  59 sub find_pm_files {
  60     my $self = shift;
  61     foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) {
  62         $self->{properties}{pm_files}->{$pm} = File::Spec->catfile('lib', $pm);;
  63     }
  64
  65     $self->_find_file_by_type('pm', 'lib');
  66 }
  67
  68 # ask what scripts to install (this method is unique to bioperl)
  69 sub choose_scripts {
  70     my $self = shift;
  71
  72     # we can offer interactive installation by groups only if we have subdirs
  73     # in scripts and no .PLS files there
  74     opendir(my $scripts_dir, 'scripts') or die "Can't open directory 'scripts': $!\n";
  75     my $int_ok = 0;
  76     my @group_dirs;
  77     while (my $thing = readdir($scripts_dir)) {
  78         next if $thing =~ /^\./;
  79         next if $thing eq 'CVS';
  80         if ($thing =~ /PLS$|pl$/) {
  81             $int_ok = 0;
  82             last;
  83         }
  84         $thing = File::Spec->catfile('scripts', $thing);
  85         if (-d $thing) {
  86             $int_ok = 1;
  87             push(@group_dirs, $thing);
  88         }
  89     }
  90     closedir($scripts_dir);
  91     my $question = $int_ok ? "Install [a]ll Bioperl scripts, [n]one, or choose groups [i]nteractively?" : "Install [a]ll Bioperl scripts or [n]one?";
  92
  93     my $prompt = $self->prompt($question, 'a');
  94
  95     if ($prompt =~ /^[aA]/) {
  96         $self->log_info("  - will install all scripts\n");
  97         $self->notes(chosen_scripts => 'all');
  98     }
  99     elsif ($prompt =~ /^[iI]/) {
 100         $self->log_info("  - will install interactively:\n");
 101
 102         my @chosen_scripts;
 103         foreach my $group_dir (@group_dirs) {
 104             my $group = File::Basename::basename($group_dir);
 105             print "    * group '$group' has:\n";
 106
 107             my @script_files = @{$self->rscan_dir($group_dir, qr/\.PLS$|\.pl$/)};
 108             foreach my $script_file (@script_files) {
 109                 my $script = File::Basename::basename($script_file);
 110                 print "      $script\n";
 111             }
 112
 113             my $result = $self->prompt("    Install scripts for group '$group'? [y]es [n]o [q]uit", 'n');
 114             die if $result =~ /^[qQ]/;
 115             if ($result =~ /^[yY]/) {
 116                 $self->log_info("      + will install group '$group'\n");
 117                 push(@chosen_scripts, @script_files);
 118             }
 119             else {
 120                 $self->log_info("      - will not install group '$group'\n");
 121             }
 122         }
 123
 124         my $chosen_scripts = @chosen_scripts ? join("|", @chosen_scripts) : 'none';
 125
 126         $self->notes(chosen_scripts => $chosen_scripts);
 127     }
 128     else {
 129         $self->log_info("  - won't install any scripts\n");
 130         $self->notes(chosen_scripts => 'none');
 131     }
 132
 133     print "\n";
 134 }
 135
 136 # our version of script_files doesn't take args but just installs those scripts
 137 # requested by the user after choose_scripts() is called. If it wasn't called,
 138 # installs all scripts in scripts directory
 139 sub script_files {
 140     my $self = shift;
 141
 142     my $chosen_scripts = $self->notes('chosen_scripts');
 143     if ($chosen_scripts) {
 144         return if $chosen_scripts eq 'none';
 145         return { map {$_, 1} split(/\|/, $chosen_scripts) } unless $chosen_scripts eq 'all';
 146     }
 147
 148     return $_ = { map {$_,1} @{$self->rscan_dir('scripts', qr/\.PLS$|\.pl$/)} };
 149 }
 150
 151 # process scripts normally, except that we change name from *.PLS to bp_*.pl
 152 sub process_script_files {
 153     my $self = shift;
 154     my $files = $self->find_script_files;
 155     return unless keys %$files;
 156
 157     my $script_dir = File::Spec->catdir($self->blib, 'script');
 158     File::Path::mkpath( $script_dir );
 159
 160     foreach my $file (keys %$files) {
 161         my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
 162         $self->fix_shebang_line($result) unless $self->os_type eq 'VMS';
 163         $self->make_executable($result);
 164
 165         my $final = File::Basename::basename($result);
 166         $final =~ s/\.PLS$/\.pl/;                  # change from .PLS to .pl
 167         $final =~ s/^/bp_/ unless $final =~ /^bp/; # add the "bp" prefix
 168         $final = File::Spec->catfile($script_dir, $final);
 169         $self->log_info("$result -> $final\n");
 170         File::Copy::move($result, $final) or die "Can't rename '$result' to '$final': $!";
 171     }
 172 }
 173
 174 # extended to handle extra checking types
 175 sub features {
 176     my $self = shift;
 177     my $ph = $self->{phash};
 178
 179     if (@_) {
 180         my $key = shift;
 181         if ($ph->{features}->exists($key)) {
 182             return $ph->{features}->access($key, @_);
 183         }
 184
 185         if (my $info = $ph->{auto_features}->access($key)) {
 186             my $failures = $self->prereq_failures($info);
 187             my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0;
 188             return !$disabled;
 189         }
 190
 191         return $ph->{features}->access($key, @_);
 192     }
 193
 194     # No args - get the auto_features & overlay the regular features
 195     my %features;
 196     my %auto_features = $ph->{auto_features}->access();
 197     while (my ($name, $info) = each %auto_features) {
 198         my $failures = $self->prereq_failures($info);
 199         my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0;
 200         $features{$name} = $disabled ? 0 : 1;
 201     }
 202     %features = (%features, $ph->{features}->access());
 203
 204     return wantarray ? %features : \%features;
 205 }
 206 *feature = \&features;
 207
 208 # overridden to fix a stupid bug in Module::Build and extended to handle extra
 209 # checking types
 210 sub check_autofeatures {
 211     my ($self) = @_;
 212     my $features = $self->auto_features;
 213
 214     return unless %$features;
 215
 216     $self->log_info("Checking features:\n");
 217
 218     my $max_name_len = 0; # this wasn't set to 0 in Module::Build, causing warning in next line
 219     $max_name_len = ( length($_) > $max_name_len ) ? length($_) : $max_name_len for keys %$features;
 220
 221     while (my ($name, $info) = each %$features) {
 222         $self->log_info("  $name" . '.' x ($max_name_len - length($name) + 4));
 223         if ($name eq 'PL_files') {
 224             print "got $name => $info\n";
 225             print "info has:\n";
 226             while (my ($key, $val) = each %$info) {
 227                 print "  $key => $val\n";
 228             }
 229         }
 230
 231         if ( my $failures = $self->prereq_failures($info) ) {
 232             my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0;
 233             $self->log_info( $disabled ? "disabled\n" : "enabled\n" );
 234
 235             my $log_text;
 236             while (my ($type, $prereqs) = each %$failures) {
 237                 while (my ($module, $status) = each %$prereqs) {
 238                     my $required = ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0;
 239                     my $prefix = ($required) ? '-' : '*';
 240                     $log_text .= "    $prefix $status->{message}\n";
 241                 }
 242             }
 243             $self->log_warn($log_text) if $log_text && ! $self->quiet;
 244         }
 245         else {
 246             $self->log_info("enabled\n");
 247         }
 248     }
 249
 250     $self->log_info("\n");
 251 }
 252
 253 # extend to handle option checking (which takes an array ref) and code test
 254 # checking (which takes a code ref and must return a message only on failure)
 255 # and excludes_os (which takes an array ref of regexps).
 256 # also handles more informative output of recommends section
 257 sub prereq_failures {
 258     my ($self, $info) = @_;
 259
 260     my @types = (@{ $self->prereq_action_types }, @extra_types);
 261     $info ||= {map {$_, $self->$_()} @types};
 262
 263     my $out = {};
 264     foreach my $type (@types) {
 265         my $prereqs = $info->{$type} || next;
 266
 267         my $status = {};
 268         if ($type eq 'test') {
 269             unless (keys %$out) {
 270                 $status->{message} = &{$prereqs};
 271                 $out->{$type}{'test'} = $status if $status->{message};
 272             }
 273         }
 274         elsif ($type eq 'options') {
 275             my @not_ok;
 276             foreach my $wanted_option (@{$prereqs}) {
 277                 unless ($self->args($wanted_option)) {
 278                     push(@not_ok, $wanted_option);
 279                 }
 280             }
 281
 282             if (@not_ok > 0) {
 283                 $status->{message} = "Command line option(s) '@not_ok' not supplied";
 284                 $out->{$type}{'options'} = $status;
 285             }
 286         }
 287         elsif ($type eq 'excludes_os') {
 288             foreach my $os (@{$prereqs}) {
 289                 if ($^O =~ /$os/i) {
 290                     $status->{message} = "This feature isn't supported under your OS ($os)";
 291                     $out->{$type}{'excludes_os'} = $status;
 292                     last;
 293                 }
 294             }
 295         }
 296         else {
 297             while ( my ($modname, $spec) = each %$prereqs ) {
 298                 $status = $self->check_installed_status($modname, $spec);
 299
 300                 if ($type =~ /^(?:\w+_)?conflicts$/) {
 301                     next if !$status->{ok};
 302                     $status->{conflicts} = delete $status->{need};
 303                     $status->{message} = "$modname ($status->{have}) conflicts with this distribution";
 304                 }
 305                 elsif ($type =~ /^(?:\w+_)?recommends$/) {
 306                     next if $status->{ok};
 307
 308                     my ($preferred_version, $why, $by_what) = split("/", $spec);
 309                     $by_what = join(", ", split(",", $by_what));
 310                     $by_what =~ s/, (\S+)$/ and $1/;
 311
 312                     $status->{message} = (!ref($status->{have}) && $status->{have} eq '<none>'
 313                                   ? "Optional prerequisite $modname is not installed"
 314                                   : "$modname ($status->{have}) is installed, but we prefer to have $preferred_version");
 315
 316                     $status->{message} .= "\n   (wanted for $why, used by $by_what)";
 317
 318                     my $installed = $self->install_optional($modname, $preferred_version, $status->{message});
 319                     next if $installed eq 'ok';
 320                     $status->{message} = $installed unless $installed eq 'skip';
 321                 }
 322                 else {
 323                     next if $status->{ok};
 324                 }
 325
 326                 $out->{$type}{$modname} = $status;
 327             }
 328         }
 329     }
 330
 331     return keys %{$out} ? $out : return;
 332 }
 333
 334 # install optional modules listed in 'recommends' arg to new that weren't
 335 # already installed. Should only be called by prereq_failures
 336 sub install_optional {
 337     my ($self, $desired, $version, $msg) = @_;
 338
 339     unless (defined $self->{ask_optional}) {
 340         $self->{ask_optional} = $self->prompt("Install [a]ll optional external modules, [n]one, or choose [i]nteractively?", 'n');
 341     }
 342     return 'skip' if $self->{ask_optional} =~ /^n/i;
 343
 344     my $install;
 345     if ($self->{ask_optional} =~ /^a/i) {
 346         $self->log_info(" * $msg\n");
 347         $install = 1;
 348     }
 349     else {
 350         $install = $self->y_n(" * $msg\n   Do you want to install it? y/n", 'n');
 351     }
 352
 353     if ($install) {
 354         # Here we use CPAN to actually install the desired module, the benefit
 355         # being we continue even if installation fails, and that this works
 356         # even when not using CPAN to install.
 357         #
 358         # The alternative would be to simply append the module to 'requires'
 359         # and let CPAN deal with required modules in the normal way, but
 360         # older CPANs don't do that (look only at META.yml), and we get
 361         # total failure for something that was only optional
 362         require Cwd;
 363         require CPAN;
 364
 365         # Save this because CPAN will chdir all over the place.
 366         my $cwd = Cwd::cwd();
 367
 368         CPAN::Shell->install($desired);
 369         my $msg;
 370         if (CPAN::Shell->expand("Module", $desired)->uptodate) {
 371             $self->log_info("\n\n*** (back in Bioperl Build.PL) ***\n * You chose to install $desired and it installed fine\n");
 372             $msg = 'ok';
 373         }
 374         else {
 375             $self->log_info("\n\n*** (back in Bioperl Build.PL) ***\n");
 376             $msg = "You chose to install $desired but it failed to install";
 377         }
 378
 379         chdir $cwd or die "Cannot chdir() back to $cwd: $!";
 380         return $msg;
 381     }
 382     else {
 383         $self->log_info(" * You chose not to install $desired\n");
 384         return 'ok';
 385     }
 386 }
 387
 388 # overridden simply to not print the default answer if chosen by hitting return
 389 sub prompt {
 390     my $self = shift;
 391     my $mess = shift or die "prompt() called without a prompt message";
 392
 393     my $def;
 394     if ( $self->_is_unattended && !@_ ) {
 395         die <<EOF;
 396 ERROR: This build seems to be unattended, but there is no default value
 397 for this question.  Aborting.
 398 EOF
 399     }
 400     $def = shift if @_;
 401     ($def, my $dispdef) = defined $def ? ($def, "[$def] ") : ('', ' ');
 402
 403     local $|=1;
 404     print "$mess $dispdef";
 405
 406     my $ans = $self->_readline();
 407
 408     if ( !defined($ans)        # Ctrl-D or unattended
 409          or !length($ans) ) {  # User hit return
 410         #print "$def\n"; didn't like this!
 411         $ans = $def;
 412     }
 413
 414     return $ans;
 415 }
 416
 417 # like the Module::Build version, except that we always get version from
 418 # dist_version
 419 sub find_dist_packages {
 420     my $self = shift;
 421
 422     # Only packages in .pm files are candidates for inclusion here.
 423     # Only include things in the MANIFEST, not things in developer's
 424     # private stock.
 425
 426     my $manifest = $self->_read_manifest('MANIFEST') or die "Can't find dist packages without a MANIFEST file - run 'manifest' action first";
 427
 428     # Localize
 429     my %dist_files = map { $self->localize_file_path($_) => $_ } keys %$manifest;
 430
 431     my @pm_files = grep {exists $dist_files{$_}} keys %{ $self->find_pm_files };
 432
 433     my $actual_version = $self->dist_version;
 434
 435     # First, we enumerate all packages & versions,
 436     # seperating into primary & alternative candidates
 437     my( %prime, %alt );
 438     foreach my $file (@pm_files) {
 439         next if $dist_files{$file} =~ m{^t/};  # Skip things in t/
 440
 441         my @path = split( /\//, $dist_files{$file} );
 442         (my $prime_package = join( '::', @path[1..$#path] )) =~ s/\.pm$//;
 443
 444         my $pm_info = Module::Build::ModuleInfo->new_from_file( $file );
 445
 446         foreach my $package ( $pm_info->packages_inside ) {
 447             next if $package eq 'main';  # main can appear numerous times, ignore
 448             next if grep /^_/, split( /::/, $package ); # private package, ignore
 449
 450             my $version = $pm_info->version( $package );
 451             if ($version && $version != $actual_version) {
 452                 $self->log_warn("Package $package had version $version!\n");
 453             }
 454             $version = $actual_version;
 455
 456             if ( $package eq $prime_package ) {
 457                 if ( exists( $prime{$package} ) ) {
 458                     # M::B::ModuleInfo will handle this conflict
 459                     die "Unexpected conflict in '$package'; multiple versions found.\n";
 460                 }
 461                 else {
 462                     $prime{$package}{file} = $dist_files{$file};
 463                     $prime{$package}{version} = $version if defined( $version );
 464                 }
 465             }
 466             else {
 467                 push( @{$alt{$package}}, { file => $dist_files{$file}, version => $version } );
 468             }
 469         }
 470     }
 471
 472     # Then we iterate over all the packages found above, identifying conflicts
 473     # and selecting the "best" candidate for recording the file & version
 474     # for each package.
 475     foreach my $package ( keys( %alt ) ) {
 476         my $result = $self->_resolve_module_versions( $alt{$package} );
 477
 478         if ( exists( $prime{$package} ) ) { # primary package selected
 479             if ( $result->{err} ) {
 480                 # Use the selected primary package, but there are conflicting
 481                  # errors amoung multiple alternative packages that need to be
 482                  # reported
 483                  $self->log_warn("Found conflicting versions for package '$package'\n" .
 484                                  "  $prime{$package}{file} ($prime{$package}{version})\n" . $result->{err});
 485             }
 486             elsif ( defined( $result->{version} ) ) {
 487                 # There is a primary package selected, and exactly one
 488                 # alternative package
 489
 490                 if ( exists( $prime{$package}{version} ) && defined( $prime{$package}{version} ) ) {
 491                     # Unless the version of the primary package agrees with the
 492                     # version of the alternative package, report a conflict
 493                     if ( $self->compare_versions( $prime{$package}{version}, '!=', $result->{version} ) ) {
 494                         $self->log_warn("Found conflicting versions for package '$package'\n" .
 495                                         "  $prime{$package}{file} ($prime{$package}{version})\n" .
 496                                         "  $result->{file} ($result->{version})\n");
 497                     }
 498                 }
 499                 else {
 500                   # The prime package selected has no version so, we choose to
 501                   # use any alternative package that does have a version
 502                   $prime{$package}{file}    = $result->{file};
 503                   $prime{$package}{version} = $result->{version};
 504                 }
 505             }
 506             else {
 507                 # no alt package found with a version, but we have a prime
 508                 # package so we use it whether it has a version or not
 509             }
 510         }
 511         else { # No primary package was selected, use the best alternative
 512             if ( $result->{err} ) {
 513                 $self->log_warn("Found conflicting versions for package '$package'\n" . $result->{err});
 514             }
 515
 516             # Despite possible conflicting versions, we choose to record
 517             # something rather than nothing
 518             $prime{$package}{file}    = $result->{file};
 519             $prime{$package}{version} = $result->{version} if defined( $result->{version} );
 520         }
 521     }
 522
 523     # Stringify versions
 524     for (grep exists $_->{version}, values %prime) {
 525         $_->{version} = $_->{version}->stringify if ref($_->{version});
 526     }
 527
 528     return \%prime;
 529 }
 530
 531 # our recommends syntax contains extra info that needs to be ignored at this
 532 # stage
 533 sub _parse_conditions {
 534     my ($self, $spec) = @_;
 535
 536     ($spec) = split("/", $spec);
 537
 538     if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores
 539         return (">= $spec");
 540     }
 541     else {
 542         return split /\s*,\s*/, $spec;
 543     }
 544 }
 545
 546 # when generating META.yml, we output optional_features syntax (instead of
 547 # recommends syntax). Note that as of CPAN v1.8802 nothing useful is done
 548 # with this information, which is why we implement our own request to install
 549 # the optional modules in install_optional()
 550 sub prepare_metadata {
 551     my ($self, $node, $keys) = @_;
 552     my $p = $self->{properties};
 553
 554     # A little helper sub
 555     my $add_node = sub {
 556         my ($name, $val) = @_;
 557         $node->{$name} = $val;
 558         push @$keys, $name if $keys;
 559     };
 560
 561     foreach (qw(dist_name dist_version dist_author dist_abstract license)) {
 562         (my $name = $_) =~ s/^dist_//;
 563         $add_node->($name, $self->$_());
 564         die "ERROR: Missing required field '$_' for META.yml\n" unless defined($node->{$name}) && length($node->{$name});
 565     }
 566     $node->{version} = '' . $node->{version}; # Stringify version objects
 567
 568     if (defined( $self->license ) && defined( my $url = $self->valid_licenses->{ $self->license } )) {
 569         $node->{resources}{license} = $url;
 570     }
 571
 572     foreach ( @{$self->prereq_action_types} ) {
 573         if (exists $p->{$_} and keys %{ $p->{$_} }) {
 574             if ($_ eq 'recommends') {
 575                 my $hash;
 576                 while (my ($req, $val) = each %{ $p->{$_} }) {
 577                     my ($ver, $why, $used_by) = split("/", $val);
 578                     my $info = {};
 579                     $info->{description} = $why;
 580                     $info->{requires} = { $req => $ver };
 581                     $hash->{$used_by} = $info;
 582                 }
 583                 $add_node->('optional_features', $hash);
 584             }
 585             else {
 586                 $add_node->($_, $p->{$_});
 587             }
 588         }
 589     }
 590
 591     if (exists $p->{dynamic_config}) {
 592         $add_node->('dynamic_config', $p->{dynamic_config});
 593     }
 594     my $pkgs = eval { $self->find_dist_packages };
 595     if ($@) {
 596         $self->log_warn("$@\nWARNING: Possible missing or corrupt 'MANIFEST' file.\n" . "Nothing to enter for 'provides' field in META.yml\n");
 597     }
 598     else {
 599         $node->{provides} = $pkgs if %$pkgs;
 600     };
 601
 602     if (exists $p->{no_index}) {
 603         $add_node->('no_index', $p->{no_index});
 604     }
 605
 606     $add_node->('generated_by', "Module::Build version $Module::Build::VERSION");
 607
 608     $add_node->('meta-spec',
 609             {version => '1.2',
 610              url     => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
 611             });
 612
 613     while (my($k, $v) = each %{$self->meta_add}) {
 614         $add_node->($k, $v);
 615     }
 616
 617     while (my($k, $v) = each %{$self->meta_merge}) {
 618         $self->_hash_merge($node, $k, $v);
 619     }
 620
 621     return $node;
 622 }
 623
 624 # let us store extra things persistently in _build
 625 sub _construct {
 626     my $self = shift;
 627     $self = $self->SUPER::_construct(@_);
 628
 629     my ($p, $ph) = ($self->{properties}, $self->{phash});
 630
 631     foreach (qw(manifest_skip post_install_scripts)) {
 632         my $file = File::Spec->catfile($self->config_dir, $_);
 633         $ph->{$_} = Module::Build::Notes->new(file => $file);
 634         $ph->{$_}->restore if -e $file;
 635     }
 636
 637     return $self;
 638 }
 639 sub write_config {
 640     my $self = shift;
 641     $self->SUPER::write_config;
 642     $self->{phash}{$_}->write() foreach qw(manifest_skip post_install_scripts);
 643 }
 644
 645 # add a file to the default MANIFEST.SKIP
 646 sub add_to_manifest_skip {
 647     my $self = shift;
 648     my %files = map {$self->localize_file_path($_), 1} @_;
 649     $self->{phash}{manifest_skip}->write(\%files);
 650 }
 651
 652 # we always generate a new MANIFEST and MANIFEST.SKIP here, instead of allowing
 653 # existing files to remain
 654 sub ACTION_manifest {
 655     my ($self) = @_;
 656
 657     my $maniskip = 'MANIFEST.SKIP';
 658     if ( -e 'MANIFEST' || -e $maniskip ) {
 659         $self->log_warn("MANIFEST files already exist, will overwrite them\n");
 660         unlink('MANIFEST');
 661         unlink($maniskip);
 662     }
 663     $self->_write_default_maniskip($maniskip);
 664
 665     require ExtUtils::Manifest;  # ExtUtils::Manifest is not warnings clean.
 666     local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
 667     ExtUtils::Manifest::mkmanifest();
 668 }
 669
 670 # extended to add extra things to the default MANIFEST.SKIP
 671 sub _write_default_maniskip {
 672     my $self = shift;
 673     $self->SUPER::_write_default_maniskip;
 674
 675     my @extra = keys %{$self->{phash}{manifest_skip}->read};
 676     if (@extra) {
 677         open(my $fh, '>>', 'MANIFEST.SKIP') or die "Could not open MANIFEST.SKIP file\n";
 678         print $fh "\n# Avoid additional run-time generated things\n";
 679         foreach my $line (@extra) {
 680             print $fh $line, "\n";
 681         }
 682         close($fh);
 683     }
 684 }
 685
 686 # extended to run scripts post-installation
 687 sub ACTION_install {
 688   my ($self) = @_;
 689   require ExtUtils::Install;
 690   $self->depends_on('build');
 691   ExtUtils::Install::install($self->install_map, !$self->quiet, 0, $self->{args}{uninst}||0);
 692   $self->run_post_install_scripts;
 693 }
 694 sub add_post_install_script {
 695     my $self = shift;
 696     my %files = map {$self->localize_file_path($_), 1} @_;
 697     $self->{phash}{post_install_scripts}->write(\%files);
 698 }
 699 sub run_post_install_scripts {
 700     my $self = shift;
 701     my @scripts = keys %{$self->{phash}{post_install_scripts}->read};
 702     foreach my $script (@scripts) {
 703         $self->run_perl_script($script);
 704     }
 705 }
 706
 707 # for use with auto_features, which needs to require LWP::UserAgent as one of
 708 # its reqs
 709 sub test_internet {
 710     eval {require LWP::UserAgent;}; # if not installed, this sub won't actually be called
 711     my $ua = LWP::UserAgent->new;
 712     $ua->timeout(10);
 713     $ua->env_proxy;
 714     my $response = $ua->get('http://search.cpan.org/');
 715     unless ($response->is_success) {
 716         return "Could not connect to the internet (http://search.cpan.org/)";
 717     }
 718     return;
 719 }
 720
 721 # nice directory names for dist-related actions
 722 sub dist_dir {
 723     my ($self) = @_;
 724     my $version = $self->dist_version;
 725     if ($version =~ /^\d\.\d{6}\d$/) {
 726         # 1.x.x.100 returned as 1.x.x.1
 727         $version .= '00';
 728     }
 729     $version =~ s/00(\d)/$1./g;
 730     $version =~ s/\.$//;
 731
 732     if (my ($minor, $rev) = $version =~ /^\d\.(\d)\.\d\.(\d+)$/) {
 733         my $dev = ! ($minor % 2 == 0);
 734         if ($rev == 100) {
 735             my $replace = $dev ? "_$rev" : '';
 736             $version =~ s/\.\d+$/$replace/;
 737         }
 738         elsif ($rev < 100) {
 739             $rev = sprintf("%03d", $rev);
 740             $version =~ s/\.\d+$/_$rev-RC/;
 741         }
 742         else {
 743             $rev -= 100 unless $dev;
 744             my $replace = $dev ? "_$rev" : ".$rev";
 745             $version =~ s/\.\d+$/$replace/;
 746         }
 747     }
 748
 749     return "$self->{properties}{dist_name}-$version";
 750 }
 751 sub ppm_name {
 752     my $self = shift;
 753     return $self->dist_dir.'-ppm';
 754 }
 755
 756 # we make all archive formats we want, not just .tar.gz
 757 # we also auto-run manifest action, since we always want to re-create
 758 # MANIFEST and MANIFEST.SKIP just-in-time
 759 sub ACTION_dist {
 760     my ($self) = @_;
 761
 762     $self->depends_on('manifest');
 763     $self->depends_on('distdir');
 764
 765     my $dist_dir = $self->dist_dir;
 766
 767     $self->make_zip($dist_dir);
 768     $self->make_tarball($dist_dir);
 769     $self->delete_filetree($dist_dir);
 770 }
 771
 772 # makes zip file for windows users and bzip2 files as well
 773 sub make_zip {
 774     my ($self, $dir, $file) = @_;
 775     $file ||= $dir;
 776
 777     $self->log_info("Creating $file.zip\n");
 778     my $zip_flags = $self->verbose ? '-r' : '-rq';
 779     $self->do_system($self->split_like_shell("zip"), $zip_flags, "$file.zip", $dir);
 780
 781     $self->log_info("Creating $file.bz2\n");
 782     require Archive::Tar;
 783     # Archive::Tar versions >= 1.09 use the following to enable a compatibility
 784     # hack so that the resulting archive is compatible with older clients.
 785     $Archive::Tar::DO_NOT_USE_PREFIX = 0;
 786     my $files = $self->rscan_dir($dir);
 787     Archive::Tar->create_archive("$file.tar", 0, @$files);
 788     $self->do_system($self->split_like_shell("bzip2"), "-k", "$file.tar");
 789 }
 790
 791 1;