Bio/Root/Build.pm

   1 package Bio::Root::Build;
   2 use Bio::Root::Version;
   3 use strict;
   4 use warnings;
   5
   6 =head1 SYNOPSIS
   7
   8   ...TO BE ADDED
   9
  10 =head1 DESCRIPTION
  11
  12 This is a subclass of Module::Build so we can override certain methods and do
  13 fancy stuff
  14
  15 It was first written against Module::Build::Base v0.2805. Many of the methods
  16 here are copy/pasted from there in their entirety just to change one or two
  17 minor things, since for the most part Module::Build::Base code is hard to
  18 cleanly override.
  19
  20 B<Note>: per bug 3196, the majority of the code in this module has been revised
  21 or commented out to bring it in line with the Module::Build API. In particular,
  22 'requires/recommends' tags in the Build.PL file were not of the same format as
  23 those for Module::Build, and so caused serious issues with newer versions
  24 (including giving incorrect meta data). Other problematic methods involving
  25 automatic installation of prereq modules via CPAN were also removed as they do
  26 not work with more modern perl tools such as perlbrew and cpanm.
  27
  28 =head1 AUTHOR Sendu Bala
  29
  30 =cut
  31
  32 BEGIN {
  33     # we really need Module::Build to be installed
  34     eval "use base 'Module::Build'; 1" or die "This package requires Module::Build v0.42 or greater to install itself.\n$@";
  35
  36     # ensure we'll be able to reload this module later by adding its path to inc
  37     use Cwd;
  38     use lib Cwd::cwd();
  39 }
  40
  41 our @extra_types = qw(options excludes_os feature_requires test); # test must always be last in the list!
  42 our $checking_types = "requires|conflicts|".join("|", @extra_types);
  43
  44 our $VERSION = $Bio::Root::Version::VERSION;
  45
  46 =head2 find_pm_files
  47
  48 Our modules are in Bio, not lib
  49 =cut
  50
  51 sub find_pm_files {
  52     my $self = shift;
  53     foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) {
  54         $self->{properties}{pm_files}->{$pm} = File::Spec->catfile('lib', $pm);
  55     }
  56
  57     $self->_find_file_by_type('pm', 'lib');
  58 }
  59
  60 =head2 choose_scripts
  61
  62 Ask what scripts to install (this method is unique to bioperl)
  63 =cut
  64
  65 sub choose_scripts {
  66     my $self = shift;
  67     my $accept = shift;
  68
  69     # we can offer interactive installation by groups only if we have subdirs
  70     # in scripts and no .PLS files there
  71     opendir(my $scripts_dir, 'scripts') or die "Can't open directory 'scripts': $!\n";
  72     my $int_ok = 0;
  73     my @group_dirs;
  74
  75     # only retain top-level script directories (the 'categories')
  76     while (my $thing = readdir($scripts_dir)) {
  77         next if $thing =~ /^\./;
  78         $thing = File::Spec->catfile('scripts', $thing);
  79         if (-d $thing) {
  80             $int_ok = 1;
  81             push(@group_dirs, $thing);
  82         }
  83     }
  84     closedir($scripts_dir);
  85     my $question = $int_ok ? "Install [a]ll BioPerl scripts, [n]one, ".
  86         "or choose groups [i]nteractively?" : "Install [a]ll BioPerl scripts ".
  87         "or [n]one?";
  88
  89     my $prompt = $accept ? 'a' : $self->prompt($question, 'a');
  90
  91     if ($prompt =~ /^[aA]/) {
  92         $self->log_info("  - will install all scripts\n");
  93         $self->notes(chosen_scripts => 'all');
  94     }
  95     elsif ($prompt =~ /^[iI]/) {
  96         $self->log_info("  - will install interactively:\n");
  97
  98         my @chosen_scripts;
  99         foreach my $group_dir (@group_dirs) {
 100             my $group = File::Basename::basename($group_dir);
 101             print "    * group '$group' has:\n";
 102
 103             my @script_files = @{$self->rscan_dir($group_dir, qr/\.PLS$|\.pl$/)};
 104             foreach my $script_file (@script_files) {
 105                 my $script = File::Basename::basename($script_file);
 106                 print "      $script\n";
 107             }
 108
 109             my $result = $self->prompt("    Install scripts for group '$group'? [y]es [n]o [q]uit", 'n');
 110             die if $result =~ /^[qQ]/;
 111             if ($result =~ /^[yY]/) {
 112                 $self->log_info("      + will install group '$group'\n");
 113                 push(@chosen_scripts, @script_files);
 114             }
 115             else {
 116                 $self->log_info("      - will not install group '$group'\n");
 117             }
 118         }
 119
 120         my $chosen_scripts = @chosen_scripts ? join("|", @chosen_scripts) : 'none';
 121
 122         $self->notes(chosen_scripts => $chosen_scripts);
 123     }
 124     else {
 125         $self->log_info("  - won't install any scripts\n");
 126         $self->notes(chosen_scripts => 'none');
 127     }
 128
 129     print "\n";
 130 }
 131
 132 =head2 script_files
 133
 134 Our version of script_files doesn't take args but just installs those scripts
 135 requested by the user after choose_scripts() is called. If it wasn't called,
 136 installs all scripts in scripts directory
 137 =cut
 138
 139 sub script_files {
 140     my $self = shift;
 141
 142     unless (-d 'scripts') {
 143         return {};
 144     }
 145
 146     my $chosen_scripts = $self->notes('chosen_scripts');
 147     if ($chosen_scripts) {
 148         return if $chosen_scripts eq 'none';
 149         return { map {$_, 1} split(/\|/, $chosen_scripts) } unless $chosen_scripts eq 'all';
 150     }
 151
 152     return $_ = { map {$_,1} @{$self->rscan_dir('scripts', qr/\.PLS$|\.pl$/)} };
 153 }
 154
 155 =head2 prompt
 156
 157 Overridden simply to not print the default answer if chosen by hitting return
 158 =cut
 159
 160 sub prompt {
 161     my $self = shift;
 162     my $mess = shift or die "prompt() called without a prompt message";
 163
 164     my $def;
 165     if ( $self->_is_unattended && !@_ ) {
 166         die <<EOF;
 167 ERROR: This build seems to be unattended, but there is no default value
 168 for this question.  Aborting.
 169 EOF
 170     }
 171     $def = shift if @_;
 172     ($def, my $dispdef) = defined $def ? ($def, "[$def] ") : ('', ' ');
 173
 174     local $|=1;
 175     print "$mess $dispdef";
 176
 177     my $ans = $self->_readline();
 178
 179     if ( !defined($ans)        # Ctrl-D or unattended
 180          or !length($ans) ) {  # User hit return
 181         #print "$def\n"; didn't like this!
 182         $ans = $def;
 183     }
 184
 185     return $ans;
 186 }
 187
 188 =head2 ACTION_manifest
 189
 190 We always generate a new MANIFEST instead of allowing existing files to remain
 191 MANIFEST.SKIP is left alone
 192 =cut
 193
 194 sub ACTION_manifest {
 195     my ($self) = @_;
 196     if ( -e 'MANIFEST' || -e 'MANIFEST.SKIP' ) {
 197         $self->log_warn("MANIFEST files already exist, will overwrite them\n");
 198         unlink('MANIFEST');
 199     }
 200     require ExtUtils::Manifest;  # ExtUtils::Manifest is not warnings clean.
 201     local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
 202     ExtUtils::Manifest::mkmanifest();
 203 }
 204
 205 =head2 ACTION_install
 206
 207 Extended to run scripts post-installation
 208 =cut
 209
 210 sub ACTION_install {
 211     my ($self) = @_;
 212     require ExtUtils::Install;
 213     $self->depends_on('build');
 214     ExtUtils::Install::install($self->install_map,
 215                                !$self->quiet,
 216                                0,
 217                                $self->{args}{uninst} || 0);
 218     #$self->run_post_install_scripts;
 219 }
 220
 221 =head2 test_internet
 222
 223 For use with auto_features, which should require LWP::UserAgent as one of
 224 its reqs
 225
 226 Note: as of 4-11-11, this is no longer called - if someone wants to run
 227 network tests (off by default) w/o a network, then they are hanging themselves
 228 by their own shoelaces.
 229 =cut
 230
 231 sub test_internet {
 232     eval {require LWP::UserAgent;};
 233     if ($@) {
 234         # ideally this won't happen because auto_feature already specified
 235         # LWP::UserAgent, so this sub wouldn't get called if LWP not installed
 236         return "LWP::UserAgent not installed";
 237     }
 238     my $ua = LWP::UserAgent->new;
 239     $ua->timeout(10);
 240     $ua->env_proxy;
 241     my $response = $ua->get('http://search.cpan.org/');
 242     unless ($response->is_success) {
 243         return "Could not connect to the internet (http://search.cpan.org/)";
 244     }
 245     return;
 246 }
 247
 248 =head2 ACTION_ppmdist
 249
 250 Don't copy across man3 docs since they're of little use under Windows and
 251 have bad filenames
 252 =cut
 253
 254 sub ACTION_ppmdist {
 255     my $self = shift;
 256     my @types = $self->install_types(1);
 257     $self->SUPER::ACTION_ppmdist(@_);
 258     $self->install_types(0);
 259 }
 260
 261 =head2 install_types
 262
 263 When supplied a true value, pretends libdoc doesn't exist (preventing man3
 264 installation for ppmdist). when supplied false, they exist again
 265 =cut
 266
 267 sub install_types {
 268     my ($self, $no_libdoc) = @_;
 269     $self->{no_libdoc} = $no_libdoc if defined $no_libdoc;
 270     my @types = $self->SUPER::install_types;
 271     if ($self->{no_libdoc}) {
 272         my @altered_types;
 273         foreach my $type (@types) {
 274             push(@altered_types, $type) unless $type eq 'libdoc';
 275         }
 276         return @altered_types;
 277     }
 278     return @types;
 279 }
 280
 281 =head2 ACTION_dist
 282
 283 We make all archive formats we want, not just .tar.gz
 284 we also auto-run manifest action, since we always want to re-create
 285 MANIFEST and MANIFEST.SKIP just-in-time
 286 =cut
 287
 288 sub ACTION_dist {
 289     my ($self) = @_;
 290
 291     $self->depends_on('manifest');
 292     $self->depends_on('distdir');
 293
 294     my $dist_dir = $self->dist_dir;
 295
 296     $self->make_zip($dist_dir);
 297     $self->make_tarball($dist_dir);
 298     $self->delete_filetree($dist_dir);
 299 }
 300
 301 =head2 ACTION_clean
 302
 303 Define custom clean/realclean actions to rearrange config file cleanup
 304 =cut
 305
 306 sub ACTION_clean {
 307     my ($self) = @_;
 308     $self->log_info("Cleaning up build files\n");
 309     foreach my $item (map glob($_), $self->cleanup) {
 310         $self->delete_filetree($item);
 311     }
 312     $self->log_info("Cleaning up configuration files\n");
 313     $self->delete_filetree($self->config_dir);
 314 }
 315
 316 =head2 ACTION_realclean
 317
 318 Define custom clean/realclean actions to rearrange config file cleanup
 319 =cut
 320
 321 sub ACTION_realclean {
 322     my ($self) = @_;
 323     $self->depends_on('clean');
 324     for my $method (qw(mymetafile mymetafile2 build_script)) {
 325         if ($self->can($method)) {
 326             $self->delete_filetree($self->$method);
 327             $self->log_info("Cleaning up $method data\n");
 328         }
 329     }
 330 }
 331
 332 =head2 get_metadata
 333
 334 This wraps the base metafile method to add in version information from
 335 Bio::Root::Version to META.json and META.yml if it isn't already present. Note
 336 this should be compliant with meta_add and meta_merge, but occurs after those
 337 steps. If a version is already set and dist_version differs from the set one, a
 338 warning is printed.
 339
 340 =cut
 341
 342 sub get_metadata {
 343     my ($self, %args) = @_;
 344     my $metadata = $self->SUPER::get_metadata(%args);
 345
 346     if (exists $metadata->{provides}) {
 347         my $ver = $self->dist_version;
 348         my $pkgs = $metadata->{provides};
 349         for my $p (keys %{$pkgs}) {
 350             if (!exists($pkgs->{$p}->{'version'})) {
 351                 $pkgs->{$p}->{'version'} = $ver;
 352             } else {
 353                 $self->log_warn("Note: Module $p has a set version: ".$pkgs->{$p}->{'version'}."\n")
 354                     if $pkgs->{$p}->{'version'} ne $ver;
 355             }
 356         }
 357     }
 358     return $metadata;
 359 }
 360
 361 =head2 make_zip
 362
 363 Makes zip file for windows users and bzip2 files as well
 364 =cut
 365
 366 sub make_zip {
 367     my ($self, $dir, $file) = @_;
 368     $file ||= $dir;
 369
 370     $self->log_info("Creating $file.zip\n");
 371     my $zip_flags = $self->verbose ? '-r' : '-rq';
 372     $self->do_system($self->split_like_shell("zip"), $zip_flags, "$file.zip", $dir);
 373
 374     $self->log_info("Creating $file.bz2\n");
 375     require Archive::Tar;
 376     # Archive::Tar versions >= 1.09 use the following to enable a compatibility
 377     # hack so that the resulting archive is compatible with older clients.
 378     $Archive::Tar::DO_NOT_USE_PREFIX = 0;
 379     my $files = $self->rscan_dir($dir);
 380     Archive::Tar->create_archive("$file.tar", 0, @$files);
 381     $self->do_system($self->split_like_shell("bzip2"), "-k", "$file.tar");
 382 }
 383
 384 =head2 prompt_for_network
 385
 386 A method that can be called in a Build.PL script to ask the user if they want
 387 internet tests.
 388 Should only be called if you have tested for yourself that
 389 $build->feature('Network Tests') is true
 390 =cut
 391
 392 sub prompt_for_network {
 393     my ($self, $accept) = @_;
 394
 395     my $proceed = $accept ? 0 : $self->y_n(  "Do you want to run tests that require connection to servers across the internet\n"
 396                                            . "(likely to cause some failures)? y/n", 'n');
 397
 398     if ($proceed) {
 399         $self->notes('network' => 1);
 400         $self->log_info("  - will run internet-requiring tests\n");
 401         my $use_email = $self->y_n("Do you want to run tests requiring a valid email address? y/n",'n');
 402         if ($use_email) {
 403             my $address = $self->prompt("Enter email address:");
 404             $self->notes(email => $address);
 405         }
 406     }
 407     else {
 408         $self->notes(network => 0);
 409         $self->log_info("  - will not run internet-requiring tests\n");
 410     }
 411 }
 412
 413 =head2 print_build_script
 414
 415 Override the build script warnings flag
 416 =cut
 417
 418 sub print_build_script {
 419     my ($self, $fh) = @_;
 420
 421     my $build_package = $self->build_class;
 422
 423     my $closedata="";
 424
 425     my $config_requires;
 426     if ( -f $self->metafile ) {
 427         my $meta = eval { $self->read_metafile( $self->metafile ) };
 428         $config_requires = $meta && $meta->{configure_requires}{'Module::Build'};
 429     }
 430     $config_requires ||= 0;
 431
 432     my %q = map {$_, $self->$_()} qw(config_dir base_dir);
 433
 434     $q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish;
 435
 436     $q{magic_numfile} = $self->config_file('magicnum');
 437
 438     my @myINC = $self->_added_to_INC;
 439     @myINC = map { $_ = File::Spec->canonpath( $_ );
 440                    $_ =~ s/([\\\'])/\\$1/g;
 441                    $_;
 442                   } @myINC;
 443     # Remove duplicates
 444     @myINC = sort {$a cmp $b}
 445              keys %{ { map { $_ => 1 } @myINC } };
 446
 447     foreach my $key (keys %q) {
 448         $q{$key} = File::Spec->canonpath( $q{$key} );
 449         $q{$key} =~ s/([\\\'])/\\$1/g;
 450     }
 451
 452     my $quoted_INC = join ",\n", map "         '$_'", @myINC;
 453     my $shebang = $self->_startperl;
 454     my $magic_number = $self->magic_number;
 455
 456     # unique to bioperl, shut off overly verbose warnings on windows, bug 3215
 457     my $w = $^O =~ /win/i ? '# no warnings (win)' : '$^W = 1;  # Use warnings';
 458
 459     print $fh <<EOF;
 460 $shebang
 461
 462 use strict;
 463 use Cwd;
 464 use File::Basename;
 465 use File::Spec;
 466
 467 sub magic_number_matches {
 468     return 0 unless -e '$q{magic_numfile}';
 469     open my \$FH, '<', '$q{magic_numfile}' or return 0;
 470     my \$filenum = <\$FH>;
 471     close \$FH;
 472     return \$filenum == $magic_number;
 473 }
 474
 475 my \$progname;
 476 my \$orig_dir;
 477 BEGIN {
 478     $w
 479     \$progname = basename(\$0);
 480     \$orig_dir = Cwd::cwd();
 481     my \$base_dir = '$q{base_dir}';
 482     if (!magic_number_matches()) {
 483         unless (chdir(\$base_dir)) {
 484             die ("Could not chdir '\$base_dir', aborting\\n");
 485         }
 486         unless (magic_number_matches()) {
 487             die ("Configuration seems to be out of date, please re-run 'perl Build.PL' again.\\n");
 488         }
 489     }
 490     unshift \@INC,
 491         (
 492 $quoted_INC
 493         );
 494 }
 495
 496 close(*DATA) unless eof(*DATA); # ensure no open handles to this script
 497
 498 use $build_package;
 499 Module::Build->VERSION(q{$config_requires});
 500
 501 # Some platforms have problems setting \$^X in shebang contexts, fix it up here
 502 \$^X = Module::Build->find_perl_interpreter;
 503
 504 if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) {
 505     warn "Warning: Build.PL has been altered.  You may need to run 'perl Build.PL' again.\\n";
 506 }
 507
 508 # This should have just enough arguments to be able to bootstrap the rest.
 509 my \$build =
 510     $build_package->resume( properties => { config_dir => '$q{config_dir}',
 511                                               orig_dir   => \$orig_dir, },
 512 );
 513
 514 \$build->dispatch;
 515 EOF
 516 }
 517
 518 1;