lib/Module/Build/Base.pm

   1 # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
   2 # vim:ts=8:sw=2:et:sta:sts=2
   3 package Module::Build::Base;
   4
   5 use strict;
   6 use vars qw($VERSION);
   7 $VERSION = '0.31012';
   8 $VERSION = eval $VERSION;
   9 BEGIN { require 5.00503 }
  10
  11 use Carp;
  12 use Cwd ();
  13 use File::Copy ();
  14 use File::Find ();
  15 use File::Path ();
  16 use File::Basename ();
  17 use File::Spec 0.82 ();
  18 use File::Compare ();
  19 use Module::Build::Dumper ();
  20 use IO::File ();
  21 use Text::ParseWords ();
  22
  23 use Module::Build::ModuleInfo;
  24 use Module::Build::Notes;
  25 use Module::Build::Config;
  26
  27
  28 #################### Constructors ###########################
  29 sub new {
  30   my $self = shift()->_construct(@_);
  31
  32   $self->{invoked_action} = $self->{action} ||= 'Build_PL';
  33   $self->cull_args(@ARGV);
  34
  35   die "Too early to specify a build action '$self->{action}'.  Do 'Build $self->{action}' instead.\n"
  36     if $self->{action} && $self->{action} ne 'Build_PL';
  37
  38   $self->check_manifest;
  39   $self->check_prereq;
  40   $self->check_autofeatures;
  41
  42   $self->dist_name;
  43   $self->dist_version;
  44
  45   $self->_set_install_paths;
  46   $self->_find_nested_builds;
  47
  48   return $self;
  49 }
  50
  51 sub resume {
  52   my $package = shift;
  53   my $self = $package->_construct(@_);
  54   $self->read_config;
  55
  56   # If someone called Module::Build->current() or
  57   # Module::Build->new_from_context() and the correct class to use is
  58   # actually a *subclass* of Module::Build, we may need to load that
  59   # subclass here and re-delegate the resume() method to it.
  60   unless ( UNIVERSAL::isa($package, $self->build_class) ) {
  61     my $build_class = $self->build_class;
  62     my $config_dir = $self->config_dir || '_build';
  63     my $build_lib = File::Spec->catdir( $config_dir, 'lib' );
  64     unshift( @INC, $build_lib );
  65     unless ( $build_class->can('new') ) {
  66       eval "require $build_class; 1" or die "Failed to re-load '$build_class': $@";
  67     }
  68     return $build_class->resume(@_);
  69   }
  70
  71   unless ($self->_perl_is_same($self->{properties}{perl})) {
  72     my $perl = $self->find_perl_interpreter;
  73     $self->log_warn(" * WARNING: Configuration was initially created with '$self->{properties}{perl}',\n".
  74                     "   but we are now using '$perl'.\n");
  75   }
  76
  77   $self->cull_args(@ARGV);
  78
  79   unless ($self->allow_mb_mismatch) {
  80     my $mb_version = $Module::Build::VERSION;
  81     die(" * ERROR: Configuration was initially created with Module::Build version '$self->{properties}{mb_version}',\n".
  82         "   but we are now using version '$mb_version'.  Please re-run the Build.PL or Makefile.PL script,\n".
  83         "   or use --allow_mb_mismatch 1 to skip this version check.\n")
  84     if $mb_version ne $self->{properties}{mb_version};
  85   }
  86
  87   $self->{invoked_action} = $self->{action} ||= 'build';
  88
  89   $self->_set_install_paths;
  90
  91   return $self;
  92 }
  93
  94 sub new_from_context {
  95   my ($package, %args) = @_;
  96
  97   # XXX Read the META.yml and see whether we need to run the Build.PL?
  98
  99   # Run the Build.PL.  We use do() rather than run_perl_script() so
 100   # that it runs in this process rather than a subprocess, because we
 101   # need to make sure that the environment is the same during Build.PL
 102   # as it is during resume() (and thereafter).
 103   {
 104     local @ARGV = $package->unparse_args(\%args);
 105     do './Build.PL';
 106     die $@ if $@;
 107   }
 108   return $package->resume;
 109 }
 110
 111 sub current {
 112   # hmm, wonder what the right thing to do here is
 113   local @ARGV;
 114   return shift()->resume;
 115 }
 116
 117 sub _construct {
 118   my ($package, %input) = @_;
 119
 120   my $args   = delete $input{args}   || {};
 121   my $config = delete $input{config} || {};
 122
 123   my $self = bless {
 124                     args => {%$args},
 125                     config => Module::Build::Config->new(values => $config),
 126                     properties => {
 127                                    base_dir        => $package->cwd,
 128                                    mb_version      => $Module::Build::VERSION,
 129                                    %input,
 130                                   },
 131                     phash => {},
 132                    }, $package;
 133
 134   $self->_set_defaults;
 135   my ($p, $ph) = ($self->{properties}, $self->{phash});
 136
 137   foreach (qw(notes config_data features runtime_params cleanup auto_features)) {
 138     my $file = File::Spec->catfile($self->config_dir, $_);
 139     $ph->{$_} = Module::Build::Notes->new(file => $file);
 140     $ph->{$_}->restore if -e $file;
 141     if (exists $p->{$_}) {
 142       my $vals = delete $p->{$_};
 143       while (my ($k, $v) = each %$vals) {
 144         $self->$_($k, $v);
 145       }
 146     }
 147   }
 148
 149   # The following warning could be unnecessary if the user is running
 150   # an embedded perl, but there aren't too many of those around, and
 151   # embedded perls aren't usually used to install modules, and the
 152   # installation process sometimes needs to run external scripts
 153   # (e.g. to run tests).
 154   $p->{perl} = $self->find_perl_interpreter
 155     or $self->log_warn("Warning: Can't locate your perl binary");
 156
 157   my $blibdir = sub { File::Spec->catdir($p->{blib}, @_) };
 158   $p->{bindoc_dirs} ||= [ $blibdir->("script") ];
 159   $p->{libdoc_dirs} ||= [ $blibdir->("lib"), $blibdir->("arch") ];
 160
 161   $p->{dist_author} = [ $p->{dist_author} ] if defined $p->{dist_author} and not ref $p->{dist_author};
 162
 163   # Synonyms
 164   $p->{requires} = delete $p->{prereq} if defined $p->{prereq};
 165   $p->{script_files} = delete $p->{scripts} if defined $p->{scripts};
 166
 167   # Convert to arrays
 168   for ('extra_compiler_flags', 'extra_linker_flags') {
 169     $p->{$_} = [ $self->split_like_shell($p->{$_}) ] if exists $p->{$_};
 170   }
 171
 172   $self->add_to_cleanup( @{delete $p->{add_to_cleanup}} )
 173     if $p->{add_to_cleanup};
 174
 175   return $self;
 176 }
 177
 178 ################## End constructors #########################
 179
 180 sub log_info {
 181   my $self = shift;
 182   print @_ unless(ref($self) and $self->quiet);
 183 }
 184 sub log_verbose {
 185   my $self = shift;
 186   $self->log_info(@_) if(ref($self) and $self->verbose);
 187 }
 188 sub log_warn {
 189   # Try to make our call stack invisible
 190   shift;
 191   if (@_ and $_[-1] !~ /\n$/) {
 192     my (undef, $file, $line) = caller();
 193     warn @_, " at $file line $line.\n";
 194   } else {
 195     warn @_;
 196   }
 197 }
 198
 199
 200 sub _set_install_paths {
 201   my $self = shift;
 202   my $c = $self->{config};
 203   my $p = $self->{properties};
 204
 205   my @libstyle = $c->get('installstyle') ?
 206       File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5);
 207   my $arch     = $c->get('archname');
 208   my $version  = $c->get('version');
 209
 210   my $bindoc  = $c->get('installman1dir') || undef;
 211   my $libdoc  = $c->get('installman3dir') || undef;
 212
 213   my $binhtml = $c->get('installhtml1dir') || $c->get('installhtmldir') || undef;
 214   my $libhtml = $c->get('installhtml3dir') || $c->get('installhtmldir') || undef;
 215
 216   $p->{install_sets} =
 217     {
 218      core   => {
 219                 lib     => $c->get('installprivlib'),
 220                 arch    => $c->get('installarchlib'),
 221                 bin     => $c->get('installbin'),
 222                 script  => $c->get('installscript'),
 223                 bindoc  => $bindoc,
 224                 libdoc  => $libdoc,
 225                 binhtml => $binhtml,
 226                 libhtml => $libhtml,
 227                },
 228      site   => {
 229                 lib     => $c->get('installsitelib'),
 230                 arch    => $c->get('installsitearch'),
 231                 bin     => $c->get('installsitebin') || $c->get('installbin'),
 232                 script  => $c->get('installsitescript') ||
 233                            $c->get('installsitebin') || $c->get('installscript'),
 234                 bindoc  => $c->get('installsiteman1dir') || $bindoc,
 235                 libdoc  => $c->get('installsiteman3dir') || $libdoc,
 236                 binhtml => $c->get('installsitehtml1dir') || $binhtml,
 237                 libhtml => $c->get('installsitehtml3dir') || $libhtml,
 238                },
 239      vendor => {
 240                 lib     => $c->get('installvendorlib'),
 241                 arch    => $c->get('installvendorarch'),
 242                 bin     => $c->get('installvendorbin') || $c->get('installbin'),
 243                 script  => $c->get('installvendorscript') ||
 244                            $c->get('installvendorbin') || $c->get('installscript'),
 245                 bindoc  => $c->get('installvendorman1dir') || $bindoc,
 246                 libdoc  => $c->get('installvendorman3dir') || $libdoc,
 247                 binhtml => $c->get('installvendorhtml1dir') || $binhtml,
 248                 libhtml => $c->get('installvendorhtml3dir') || $libhtml,
 249                },
 250     };
 251
 252   $p->{original_prefix} =
 253     {
 254      core   => $c->get('installprefixexp') || $c->get('installprefix') ||
 255                $c->get('prefixexp')        || $c->get('prefix') || '',
 256      site   => $c->get('siteprefixexp'),
 257      vendor => $c->get('usevendorprefix') ? $c->get('vendorprefixexp') : '',
 258     };
 259   $p->{original_prefix}{site} ||= $p->{original_prefix}{core};
 260
 261   # Note: you might be tempted to use $Config{installstyle} here
 262   # instead of hard-coding lib/perl5, but that's been considered and
 263   # (at least for now) rejected.  `perldoc Config` has some wisdom
 264   # about it.
 265   $p->{install_base_relpaths} =
 266     {
 267      lib     => ['lib', 'perl5'],
 268      arch    => ['lib', 'perl5', $arch],
 269      bin     => ['bin'],
 270      script  => ['bin'],
 271      bindoc  => ['man', 'man1'],
 272      libdoc  => ['man', 'man3'],
 273      binhtml => ['html'],
 274      libhtml => ['html'],
 275     };
 276
 277   $p->{prefix_relpaths} =
 278     {
 279      core => {
 280               lib        => [@libstyle],
 281               arch       => [@libstyle, $version, $arch],
 282               bin        => ['bin'],
 283               script     => ['bin'],
 284               bindoc     => ['man', 'man1'],
 285               libdoc     => ['man', 'man3'],
 286               binhtml    => ['html'],
 287               libhtml    => ['html'],
 288              },
 289      vendor => {
 290                 lib        => [@libstyle],
 291                 arch       => [@libstyle, $version, $arch],
 292                 bin        => ['bin'],
 293                 script     => ['bin'],
 294                 bindoc     => ['man', 'man1'],
 295                 libdoc     => ['man', 'man3'],
 296                 binhtml    => ['html'],
 297                 libhtml    => ['html'],
 298                },
 299      site => {
 300               lib        => [@libstyle, 'site_perl'],
 301               arch       => [@libstyle, 'site_perl', $version, $arch],
 302               bin        => ['bin'],
 303               script     => ['bin'],
 304               bindoc     => ['man', 'man1'],
 305               libdoc     => ['man', 'man3'],
 306               binhtml    => ['html'],
 307               libhtml    => ['html'],
 308              },
 309     };
 310
 311 }
 312
 313 sub _find_nested_builds {
 314   my $self = shift;
 315   my $r = $self->recurse_into or return;
 316
 317   my ($file, @r);
 318   if (!ref($r) && $r eq 'auto') {
 319     local *DH;
 320     opendir DH, $self->base_dir
 321       or die "Can't scan directory " . $self->base_dir . " for nested builds: $!";
 322     while (defined($file = readdir DH)) {
 323       my $subdir = File::Spec->catdir( $self->base_dir, $file );
 324       next unless -d $subdir;
 325       push @r, $subdir if -e File::Spec->catfile( $subdir, 'Build.PL' );
 326     }
 327   }
 328
 329   $self->recurse_into(\@r);
 330 }
 331
 332 sub cwd {
 333   return Cwd::cwd();
 334 }
 335
 336 sub _quote_args {
 337   # Returns a string that can become [part of] a command line with
 338   # proper quoting so that the subprocess sees this same list of args.
 339   my ($self, @args) = @_;
 340
 341   my @quoted;
 342
 343   for (@args) {
 344     if ( /^[^\s*?!\$<>;\\|'"\[\]\{\}]+$/ ) {
 345       # Looks pretty safe
 346       push @quoted, $_;
 347     } else {
 348       # XXX this will obviously have to improve - is there already a
 349       # core module lying around that does proper quoting?
 350       s/('+)/'"$1"'/g;
 351       push @quoted, qq('$_');
 352     }
 353   }
 354
 355   return join " ", @quoted;
 356 }
 357
 358 sub _backticks {
 359   my ($self, @cmd) = @_;
 360   if ($self->have_forkpipe) {
 361     local *FH;
 362     my $pid = open *FH, "-|";
 363     if ($pid) {
 364       return wantarray ? <FH> : join '', <FH>;
 365     } else {
 366       die "Can't execute @cmd: $!\n" unless defined $pid;
 367       exec { $cmd[0] } @cmd;
 368     }
 369   } else {
 370     my $cmd = $self->_quote_args(@cmd);
 371     return `$cmd`;
 372   }
 373 }
 374
 375 # Tells us whether the construct open($fh, '-|', @command) is
 376 # supported.  It would probably be better to dynamically sense this.
 377 sub have_forkpipe { 1 }
 378
 379 # Determine whether a given binary is the same as the perl
 380 # (configuration) that started this process.
 381 sub _perl_is_same {
 382   my ($self, $perl) = @_;
 383
 384   my @cmd = ($perl);
 385
 386   # When run from the perl core, @INC will include the directories
 387   # where perl is yet to be installed. We need to reference the
 388   # absolute path within the source distribution where it can find
 389   # it's Config.pm This also prevents us from picking up a Config.pm
 390   # from a different configuration that happens to be already
 391   # installed in @INC.
 392   if ($ENV{PERL_CORE}) {
 393     push @cmd, '-I' . File::Spec->catdir(File::Basename::dirname($perl), 'lib');
 394   }
 395
 396   push @cmd, qw(-MConfig=myconfig -e print -e myconfig);
 397   return $self->_backticks(@cmd) eq Config->myconfig;
 398 }
 399
 400 # cache _discover_perl_interpreter() results
 401 {
 402   my $known_perl;
 403   sub find_perl_interpreter {
 404     my $self = shift;
 405
 406     return $known_perl if defined($known_perl);
 407     return $known_perl = $self->_discover_perl_interpreter;
 408   }
 409 }
 410
 411 # Returns the absolute path of the perl interperter used to invoke
 412 # this process. The path is derived from $^X or $Config{perlpath}. On
 413 # some platforms $^X contains the complete absolute path of the
 414 # interpreter, on other it may contain a relative path, or simply
 415 # 'perl'. This can also vary depending on whether a path was supplied
 416 # when perl was invoked. Additionally, the value in $^X may omit the
 417 # executable extension on platforms that use one. It's a fatal error
 418 # if the interpreter can't be found because it can result in undefined
 419 # behavior by routines that depend on it (generating errors or
 420 # invoking the wrong perl.)
 421 sub _discover_perl_interpreter {
 422   my $proto = shift;
 423   my $c     = ref($proto) ? $proto->{config} : 'Module::Build::Config';
 424
 425   my $perl  = $^X;
 426   my $perl_basename = File::Basename::basename($perl);
 427
 428   my @potential_perls;
 429
 430   # Try 1, Check $^X for absolute path
 431   push( @potential_perls, $perl )
 432       if File::Spec->file_name_is_absolute($perl);
 433
 434   # Try 2, Check $^X for a valid relative path
 435   my $abs_perl = File::Spec->rel2abs($perl);
 436   push( @potential_perls, $abs_perl );
 437
 438   # Try 3, Last ditch effort: These two option use hackery to try to locate
 439   # a suitable perl. The hack varies depending on whether we are running
 440   # from an installed perl or an uninstalled perl in the perl source dist.
 441   if ($ENV{PERL_CORE}) {
 442
 443     # Try 3.A, If we are in a perl source tree, running an uninstalled
 444     # perl, we can keep moving up the directory tree until we find our
 445     # binary. We wouldn't do this under any other circumstances.
 446
 447     # CBuilder is also in the core, so it should be available here
 448     require ExtUtils::CBuilder;
 449     my $perl_src = Cwd::realpath( ExtUtils::CBuilder->perl_src );
 450     if ( defined($perl_src) && length($perl_src) ) {
 451       my $uninstperl =
 452         File::Spec->rel2abs(File::Spec->catfile( $perl_src, $perl_basename ));
 453       push( @potential_perls, $uninstperl );
 454     }
 455
 456   } else {
 457
 458     # Try 3.B, First look in $Config{perlpath}, then search the user's
 459     # PATH. We do not want to do either if we are running from an
 460     # uninstalled perl in a perl source tree.
 461
 462     push( @potential_perls, $c->get('perlpath') );
 463
 464     push( @potential_perls,
 465           map File::Spec->catfile($_, $perl_basename), File::Spec->path() );
 466   }
 467
 468   # Now that we've enumerated the potential perls, it's time to test
 469   # them to see if any of them match our configuration, returning the
 470   # absolute path of the first successful match.
 471   my $exe = $c->get('exe_ext');
 472   foreach my $thisperl ( @potential_perls ) {
 473
 474     if (defined $exe) {
 475       $thisperl .= $exe unless $thisperl =~ m/$exe$/i;
 476     }
 477
 478     if ( -f $thisperl && $proto->_perl_is_same($thisperl) ) {
 479       return $thisperl;
 480     }
 481   }
 482
 483   # We've tried all alternatives, and didn't find a perl that matches
 484   # our configuration. Throw an exception, and list alternatives we tried.
 485   my @paths = map File::Basename::dirname($_), @potential_perls;
 486   die "Can't locate the perl binary used to run this script " .
 487       "in (@paths)\n";
 488 }
 489
 490 sub _is_interactive {
 491   return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;   # Pipe?
 492 }
 493
 494 # NOTE this is a blocking operation if(-t STDIN)
 495 sub _is_unattended {
 496   my $self = shift;
 497   return $ENV{PERL_MM_USE_DEFAULT} ||
 498     ( !$self->_is_interactive && eof STDIN );
 499 }
 500
 501 sub _readline {
 502   my $self = shift;
 503   return undef if $self->_is_unattended;
 504
 505   my $answer = <STDIN>;
 506   chomp $answer if defined $answer;
 507   return $answer;
 508 }
 509
 510 sub prompt {
 511   my $self = shift;
 512   my $mess = shift
 513     or die "prompt() called without a prompt message";
 514
 515   # use a list to distinguish a default of undef() from no default
 516   my @def;
 517   @def = (shift) if @_;
 518   # use dispdef for output
 519   my @dispdef = scalar(@def) ?
 520     ('[', (defined($def[0]) ? $def[0] . ' ' : ''), ']') :
 521     (' ', '');
 522
 523   local $|=1;
 524   print "$mess ", @dispdef;
 525
 526   if ( $self->_is_unattended && !@def ) {
 527     die <<EOF;
 528 ERROR: This build seems to be unattended, but there is no default value
 529 for this question.  Aborting.
 530 EOF
 531   }
 532
 533   my $ans = $self->_readline();
 534
 535   if ( !defined($ans)        # Ctrl-D or unattended
 536        or !length($ans) ) {  # User hit return
 537     print "$dispdef[1]\n";
 538     $ans = scalar(@def) ? $def[0] : '';
 539   }
 540
 541   return $ans;
 542 }
 543
 544 sub y_n {
 545   my $self = shift;
 546   my ($mess, $def)  = @_;
 547
 548   die "y_n() called without a prompt message" unless $mess;
 549   die "Invalid default value: y_n() default must be 'y' or 'n'"
 550     if $def && $def !~ /^[yn]/i;
 551
 552   my $answer;
 553   while (1) { # XXX Infinite or a large number followed by an exception ?
 554     $answer = $self->prompt(@_);
 555     return 1 if $answer =~ /^y/i;
 556     return 0 if $answer =~ /^n/i;
 557     local $|=1;
 558     print "Please answer 'y' or 'n'.\n";
 559   }
 560 }
 561
 562 sub current_action { shift->{action} }
 563 sub invoked_action { shift->{invoked_action} }
 564
 565 sub notes        { shift()->{phash}{notes}->access(@_) }
 566 sub config_data  { shift()->{phash}{config_data}->access(@_) }
 567 sub runtime_params { shift->{phash}{runtime_params}->read( @_ ? shift : () ) }  # Read-only
 568 sub auto_features  { shift()->{phash}{auto_features}->access(@_) }
 569
 570 sub features     {
 571   my $self = shift;
 572   my $ph = $self->{phash};
 573
 574   if (@_) {
 575     my $key = shift;
 576     if ($ph->{features}->exists($key)) {
 577       return $ph->{features}->access($key, @_);
 578     }
 579
 580     if (my $info = $ph->{auto_features}->access($key)) {
 581       my $failures = $self->prereq_failures($info);
 582       my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
 583                            keys %$failures ) ? 1 : 0;
 584       return !$disabled;
 585     }
 586
 587     return $ph->{features}->access($key, @_);
 588   }
 589
 590   # No args - get the auto_features & overlay the regular features
 591   my %features;
 592   my %auto_features = $ph->{auto_features}->access();
 593   while (my ($name, $info) = each %auto_features) {
 594     my $failures = $self->prereq_failures($info);
 595     my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
 596                          keys %$failures ) ? 1 : 0;
 597     $features{$name} = $disabled ? 0 : 1;
 598   }
 599   %features = (%features, $ph->{features}->access());
 600
 601   return wantarray ? %features : \%features;
 602 }
 603 BEGIN { *feature = \&features } # Alias
 604
 605 sub _mb_feature {
 606   my $self = shift;
 607
 608   if (($self->module_name || '') eq 'Module::Build') {
 609     # We're building Module::Build itself, so ...::ConfigData isn't
 610     # valid, but $self->features() should be.
 611     return $self->feature(@_);
 612   } else {
 613     require Module::Build::ConfigData;
 614     return Module::Build::ConfigData->feature(@_);
 615   }
 616 }
 617
 618
 619 sub add_build_element {
 620     my ($self, $elem) = @_;
 621     my $elems = $self->build_elements;
 622     push @$elems, $elem unless grep { $_ eq $elem } @$elems;
 623 }
 624
 625 sub ACTION_config_data {
 626   my $self = shift;
 627   return unless $self->has_config_data;
 628
 629   my $module_name = $self->module_name
 630     or die "The config_data feature requires that 'module_name' be set";
 631   my $notes_name = $module_name . '::ConfigData'; # TODO: Customize name ???
 632   my $notes_pm = File::Spec->catfile($self->blib, 'lib', split /::/, "$notes_name.pm");
 633
 634   return if $self->up_to_date(['Build.PL',
 635                                $self->config_file('config_data'),
 636                                $self->config_file('features')
 637                               ], $notes_pm);
 638
 639   $self->log_info("Writing config notes to $notes_pm\n");
 640   File::Path::mkpath(File::Basename::dirname($notes_pm));
 641
 642   Module::Build::Notes->write_config_data
 643       (
 644        file => $notes_pm,
 645        module => $module_name,
 646        config_module => $notes_name,
 647        config_data => scalar $self->config_data,
 648        feature => scalar $self->{phash}{features}->access(),
 649        auto_features => scalar $self->auto_features,
 650       );
 651 }
 652
 653 ########################################################################
 654 { # enclosing these lexicals -- TODO
 655   my %valid_properties = ( __PACKAGE__,  {} );
 656   my %additive_properties;
 657
 658   sub _mb_classes {
 659     my $class = ref($_[0]) || $_[0];
 660     return ($class, $class->mb_parents);
 661   }
 662
 663   sub valid_property {
 664     my ($class, $prop) = @_;
 665     return grep exists( $valid_properties{$_}{$prop} ), $class->_mb_classes;
 666   }
 667
 668   sub valid_properties {
 669     return keys %{ shift->valid_properties_defaults() };
 670   }
 671
 672   sub valid_properties_defaults {
 673     my %out;
 674     for (reverse shift->_mb_classes) {
 675       @out{ keys %{ $valid_properties{$_} } } = map {
 676         $_->()
 677       } values %{ $valid_properties{$_} };
 678     }
 679     return \%out;
 680   }
 681
 682   sub array_properties {
 683     for (shift->_mb_classes) {
 684       return @{$additive_properties{$_}->{ARRAY}}
 685         if exists $additive_properties{$_}->{ARRAY};
 686     }
 687   }
 688
 689   sub hash_properties {
 690     for (shift->_mb_classes) {
 691       return @{$additive_properties{$_}->{'HASH'}}
 692         if exists $additive_properties{$_}->{'HASH'};
 693     }
 694   }
 695
 696   sub add_property {
 697     my ($class, $property) = (shift, shift);
 698     die "Property '$property' already exists"
 699       if $class->valid_property($property);
 700     my %p = @_ == 1 ? ( default => shift ) : @_;
 701
 702     my $type = ref $p{default};
 703     $valid_properties{$class}{$property} = $type eq 'CODE'
 704       ? $p{default}
 705       : sub { $p{default} };
 706
 707     push @{$additive_properties{$class}->{$type}}, $property
 708       if $type;
 709
 710     unless ($class->can($property)) {
 711       # TODO probably should put these in a util package
 712       my $sub = $type eq 'HASH'
 713         ? _make_hash_accessor($property, \%p)
 714         : _make_accessor($property, \%p);
 715       no strict 'refs';
 716       *{"$class\::$property"} = $sub;
 717     }
 718
 719     return $class;
 720   }
 721
 722     sub property_error {
 723       my $self = shift;
 724       die 'ERROR: ', @_;
 725     }
 726
 727   sub _set_defaults {
 728     my $self = shift;
 729
 730     # Set the build class.
 731     $self->{properties}{build_class} ||= ref $self;
 732
 733     # If there was no orig_dir, set to the same as base_dir
 734     $self->{properties}{orig_dir} ||= $self->{properties}{base_dir};
 735
 736     my $defaults = $self->valid_properties_defaults;
 737
 738     foreach my $prop (keys %$defaults) {
 739       $self->{properties}{$prop} = $defaults->{$prop}
 740         unless exists $self->{properties}{$prop};
 741     }
 742
 743     # Copy defaults for arrays any arrays.
 744     for my $prop ($self->array_properties) {
 745       $self->{properties}{$prop} = [@{$defaults->{$prop}}]
 746         unless exists $self->{properties}{$prop};
 747     }
 748     # Copy defaults for arrays any hashes.
 749     for my $prop ($self->hash_properties) {
 750       $self->{properties}{$prop} = {%{$defaults->{$prop}}}
 751         unless exists $self->{properties}{$prop};
 752     }
 753   }
 754
 755 } # end closure
 756 ########################################################################
 757 sub _make_hash_accessor {
 758   my ($property, $p) = @_;
 759   my $check = $p->{check} || sub { 1 };
 760
 761   return sub {
 762     my $self = shift;
 763
 764     # This is only here to deprecate the historic accident of calling
 765     # properties as class methods - I suspect it only happens in our
 766     # test suite.
 767     unless(ref($self)) {
 768       carp("\n$property not a class method (@_)");
 769       return;
 770     }
 771
 772     my $x = $self->{properties};
 773     return $x->{$property} unless @_;
 774
 775     my $prop = $x->{$property};
 776     if ( defined $_[0] && !ref $_[0] ) {
 777       if ( @_ == 1 ) {
 778         return exists $prop->{$_[0]} ? $prop->{$_[0]} : undef;
 779       } elsif ( @_ % 2 == 0 ) {
 780         my %new = (%{ $prop }, @_);
 781         local $_ = \%new;
 782         $x->{$property} = \%new if $check->($self);
 783         return $x->{$property};
 784       } else {
 785         die "Unexpected arguments for property '$property'\n";
 786       }
 787     } else {
 788       die "Unexpected arguments for property '$property'\n"
 789           if defined $_[0] && ref $_[0] ne 'HASH';
 790       local $_ = $_[0];
 791       $x->{$property} = shift if $check->($self);
 792     }
 793   };
 794 }
 795 ########################################################################
 796 sub _make_accessor {
 797   my ($property, $p) = @_;
 798   my $check = $p->{check} || sub { 1 };
 799
 800   return sub {
 801     my $self = shift;
 802
 803     # This is only here to deprecate the historic accident of calling
 804     # properties as class methods - I suspect it only happens in our
 805     # test suite.
 806     unless(ref($self)) {
 807       carp("\n$property not a class method (@_)");
 808       return;
 809     }
 810
 811     my $x = $self->{properties};
 812     return $x->{$property} unless @_;
 813     local $_ = $_[0];
 814     $x->{$property} = shift if $check->($self);
 815     return $x->{$property};
 816   };
 817 }
 818 ########################################################################
 819
 820 # Add the default properties.
 821 __PACKAGE__->add_property(blib => 'blib');
 822 __PACKAGE__->add_property(build_class => 'Module::Build');
 823 __PACKAGE__->add_property(build_elements => [qw(PL support pm xs pod script)]);
 824 __PACKAGE__->add_property(build_script => 'Build');
 825 __PACKAGE__->add_property(build_bat => 0);
 826 __PACKAGE__->add_property(config_dir => '_build');
 827 __PACKAGE__->add_property(include_dirs => []);
 828 __PACKAGE__->add_property(metafile => 'META.yml');
 829 __PACKAGE__->add_property(recurse_into => []);
 830 __PACKAGE__->add_property(use_rcfile => 1);
 831 __PACKAGE__->add_property(create_packlist => 1);
 832 __PACKAGE__->add_property(allow_mb_mismatch => 0);
 833 __PACKAGE__->add_property(config => undef);
 834 __PACKAGE__->add_property(test_file_exts => ['.t']);
 835 __PACKAGE__->add_property(use_tap_harness => 0);
 836 __PACKAGE__->add_property(tap_harness_args => {});
 837 __PACKAGE__->add_property(
 838   'installdirs',
 839   default => 'site',
 840   check   => sub {
 841     return 1 if /^(core|site|vendor)$/;
 842     return shift->property_error(
 843       $_ eq 'perl'
 844       ? 'Perhaps you meant installdirs to be "core" rather than "perl"?'
 845       : 'installdirs must be one of "core", "site", or "vendor"'
 846     );
 847     return shift->property_error("Perhaps you meant 'core'?") if $_ eq 'perl';
 848     return 0;
 849   },
 850 );
 851
 852 {
 853   my $Is_ActivePerl = eval {require ActivePerl::DocTools};
 854   __PACKAGE__->add_property(html_css => $Is_ActivePerl ? 'Active.css' : '');
 855 }
 856
 857 {
 858   my @prereq_action_types = qw(requires build_requires conflicts recommends);
 859   foreach my $type (@prereq_action_types) {
 860     __PACKAGE__->add_property($type => {});
 861   }
 862   __PACKAGE__->add_property(prereq_action_types => \@prereq_action_types);
 863 }
 864
 865 __PACKAGE__->add_property($_ => {}) for qw(
 866   get_options
 867   install_base_relpaths
 868   install_path
 869   install_sets
 870   meta_add
 871   meta_merge
 872   original_prefix
 873   prefix_relpaths
 874   configure_requires
 875 );
 876
 877 __PACKAGE__->add_property($_) for qw(
 878   PL_files
 879   autosplit
 880   base_dir
 881   bindoc_dirs
 882   c_source
 883   create_license
 884   create_makefile_pl
 885   create_readme
 886   debugger
 887   destdir
 888   dist_abstract
 889   dist_author
 890   dist_name
 891   dist_version
 892   dist_version_from
 893   extra_compiler_flags
 894   extra_linker_flags
 895   has_config_data
 896   install_base
 897   libdoc_dirs
 898   license
 899   magic_number
 900   mb_version
 901   module_name
 902   orig_dir
 903   perl
 904   pm_files
 905   pod_files
 906   pollute
 907   prefix
 908   program_name
 909   quiet
 910   recursive_test_files
 911   script_files
 912   scripts
 913   sign
 914   test_files
 915   verbose
 916   xs_files
 917 );
 918
 919 sub config {
 920   my $self = shift;
 921   my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
 922   return $c->all_config unless @_;
 923
 924   my $key = shift;
 925   return $c->get($key) unless @_;
 926
 927   my $val = shift;
 928   return $c->set($key => $val);
 929 }
 930
 931 sub mb_parents {
 932     # Code borrowed from Class::ISA.
 933     my @in_stack = (shift);
 934     my %seen = ($in_stack[0] => 1);
 935
 936     my ($current, @out);
 937     while (@in_stack) {
 938         next unless defined($current = shift @in_stack)
 939           && $current->isa('Module::Build::Base');
 940         push @out, $current;
 941         next if $current eq 'Module::Build::Base';
 942         no strict 'refs';
 943         unshift @in_stack,
 944           map {
 945               my $c = $_; # copy, to avoid being destructive
 946               substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
 947               # Canonize the :: -> main::, ::foo -> main::foo thing.
 948               # Should I ever canonize the Foo'Bar = Foo::Bar thing?
 949               $seen{$c}++ ? () : $c;
 950           } @{"$current\::ISA"};
 951
 952         # I.e., if this class has any parents (at least, ones I've never seen
 953         # before), push them, in order, onto the stack of classes I need to
 954         # explore.
 955     }
 956     shift @out;
 957     return @out;
 958 }
 959
 960 sub extra_linker_flags   { shift->_list_accessor('extra_linker_flags',   @_) }
 961 sub extra_compiler_flags { shift->_list_accessor('extra_compiler_flags', @_) }
 962
 963 sub _list_accessor {
 964   (my $self, local $_) = (shift, shift);
 965   my $p = $self->{properties};
 966   $p->{$_} = [@_] if @_;
 967   $p->{$_} = [] unless exists $p->{$_};
 968   return ref($p->{$_}) ? $p->{$_} : [$p->{$_}];
 969 }
 970
 971 # XXX Problem - if Module::Build is loaded from a different directory,
 972 # it'll look for (and perhaps destroy/create) a _build directory.
 973 sub subclass {
 974   my ($pack, %opts) = @_;
 975
 976   my $build_dir = '_build'; # XXX The _build directory is ostensibly settable by the user.  Shouldn't hard-code here.
 977   $pack->delete_filetree($build_dir) if -e $build_dir;
 978
 979   die "Must provide 'code' or 'class' option to subclass()\n"
 980     unless $opts{code} or $opts{class};
 981
 982   $opts{code}  ||= '';
 983   $opts{class} ||= 'MyModuleBuilder';
 984
 985   my $filename = File::Spec->catfile($build_dir, 'lib', split '::', $opts{class}) . '.pm';
 986   my $filedir  = File::Basename::dirname($filename);
 987   $pack->log_info("Creating custom builder $filename in $filedir\n");
 988
 989   File::Path::mkpath($filedir);
 990   die "Can't create directory $filedir: $!" unless -d $filedir;
 991
 992   my $fh = IO::File->new("> $filename") or die "Can't create $filename: $!";
 993   print $fh <<EOF;
 994 package $opts{class};
 995 use $pack;
 996 \@ISA = qw($pack);
 997 $opts{code}
 998 1;
 999 EOF
1000   close $fh;
1001
1002   unshift @INC, File::Spec->catdir(File::Spec->rel2abs($build_dir), 'lib');
1003   eval "use $opts{class}";
1004   die $@ if $@;
1005
1006   return $opts{class};
1007 }
1008
1009 sub dist_name {
1010   my $self = shift;
1011   my $p = $self->{properties};
1012   return $p->{dist_name} if defined $p->{dist_name};
1013
1014   die "Can't determine distribution name, must supply either 'dist_name' or 'module_name' parameter"
1015     unless $self->module_name;
1016
1017   ($p->{dist_name} = $self->module_name) =~ s/::/-/g;
1018
1019   return $p->{dist_name};
1020 }
1021
1022 sub dist_version_from {
1023   my ($self) = @_;
1024   my $p = $self->{properties};
1025   if ($self->module_name) {
1026     $p->{dist_version_from} ||=
1027         join( '/', 'lib', split(/::/, $self->module_name) ) . '.pm';
1028   }
1029   return $p->{dist_version_from} || undef;
1030 }
1031
1032 sub dist_version {
1033   my ($self) = @_;
1034   my $p = $self->{properties};
1035
1036   return $p->{dist_version} if defined $p->{dist_version};
1037
1038   if ( my $dist_version_from = $self->dist_version_from ) {
1039     my $version_from = File::Spec->catfile( split( qr{/}, $dist_version_from ) );
1040     my $pm_info = Module::Build::ModuleInfo->new_from_file( $version_from )
1041       or die "Can't find file $version_from to determine version";
1042     $p->{dist_version} = $pm_info->version();
1043   }
1044
1045   die ("Can't determine distribution version, must supply either 'dist_version',\n".
1046        "'dist_version_from', or 'module_name' parameter")
1047     unless defined $p->{dist_version};
1048
1049   return $p->{dist_version};
1050 }
1051
1052 sub dist_author   { shift->_pod_parse('author')   }
1053 sub dist_abstract { shift->_pod_parse('abstract') }
1054
1055 sub _pod_parse {
1056   my ($self, $part) = @_;
1057   my $p = $self->{properties};
1058   my $member = "dist_$part";
1059   return $p->{$member} if defined $p->{$member};
1060
1061   my $docfile = $self->_main_docfile
1062     or return;
1063   my $fh = IO::File->new($docfile)
1064     or return;
1065
1066   require Module::Build::PodParser;
1067   my $parser = Module::Build::PodParser->new(fh => $fh);
1068   my $method = "get_$part";
1069   return $p->{$member} = $parser->$method();
1070 }
1071
1072 sub version_from_file { # Method provided for backwards compatability
1073   return Module::Build::ModuleInfo->new_from_file($_[1])->version();
1074 }
1075
1076 sub find_module_by_name { # Method provided for backwards compatability
1077   return Module::Build::ModuleInfo->find_module_by_name(@_[1,2]);
1078 }
1079
1080 sub add_to_cleanup {
1081   my $self = shift;
1082   my %files = map {$self->localize_file_path($_), 1} @_;
1083   $self->{phash}{cleanup}->write(\%files);
1084 }
1085
1086 sub cleanup {
1087   my $self = shift;
1088   my $all = $self->{phash}{cleanup}->read;
1089   return keys %$all;
1090 }
1091
1092 sub config_file {
1093   my $self = shift;
1094   return unless -d $self->config_dir;
1095   return File::Spec->catfile($self->config_dir, @_);
1096 }
1097
1098 sub read_config {
1099   my ($self) = @_;
1100
1101   my $file = $self->config_file('build_params')
1102     or die "Can't find 'build_params' in " . $self->config_dir;
1103   my $fh = IO::File->new($file) or die "Can't read '$file': $!";
1104   my $ref = eval do {local $/; <$fh>};
1105   die if $@;
1106   my $c;
1107   ($self->{args}, $c, $self->{properties}) = @$ref;
1108   $self->{config} = Module::Build::Config->new(values => $c);
1109   close $fh;
1110 }
1111
1112 sub has_config_data {
1113   my $self = shift;
1114   return scalar grep $self->{phash}{$_}->has_data(), qw(config_data features auto_features);
1115 }
1116
1117 sub _write_data {
1118   my ($self, $filename, $data) = @_;
1119
1120   my $file = $self->config_file($filename);
1121   my $fh = IO::File->new("> $file") or die "Can't create '$file': $!";
1122   unless (ref($data)) {  # e.g. magicnum
1123     print $fh $data;
1124     return;
1125   }
1126
1127   print {$fh} Module::Build::Dumper->_data_dump($data);
1128 }
1129
1130 sub write_config {
1131   my ($self) = @_;
1132
1133   File::Path::mkpath($self->{properties}{config_dir});
1134   -d $self->{properties}{config_dir} or die "Can't mkdir $self->{properties}{config_dir}: $!";
1135
1136   my @items = @{ $self->prereq_action_types };
1137   $self->_write_data('prereqs', { map { $_, $self->$_() } @items });
1138   $self->_write_data('build_params', [$self->{args}, $self->{config}->values_set, $self->{properties}]);
1139
1140   # Set a new magic number and write it to a file
1141   $self->_write_data('magicnum', $self->magic_number(int rand 1_000_000));
1142
1143   $self->{phash}{$_}->write() foreach qw(notes cleanup features auto_features config_data runtime_params);
1144 }
1145
1146 sub check_autofeatures {
1147   my ($self) = @_;
1148   my $features = $self->auto_features;
1149
1150   return unless %$features;
1151
1152   $self->log_info("Checking features:\n");
1153
1154   # TODO refactor into ::Util
1155   my $longest = sub {
1156     my @str = @_ or croak("no strings given");
1157
1158     my @len = map({length($_)} @str);
1159     my $max = 0;
1160     my $longest;
1161     for my $i (0..$#len) {
1162       ($max, $longest) = ($len[$i], $str[$i]) if($len[$i] > $max);
1163     }
1164     return($longest);
1165   };
1166   my $max_name_len = length($longest->(keys %$features));
1167
1168   while (my ($name, $info) = each %$features) {
1169     $self->log_info("  $name" . '.' x ($max_name_len - length($name) + 4));
1170
1171     if ( my $failures = $self->prereq_failures($info) ) {
1172       my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
1173                            keys %$failures ) ? 1 : 0;
1174       $self->log_info( $disabled ? "disabled\n" : "enabled\n" );
1175
1176       my $log_text;
1177       while (my ($type, $prereqs) = each %$failures) {
1178         while (my ($module, $status) = each %$prereqs) {
1179           my $required =
1180             ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0;
1181           my $prefix = ($required) ? '-' : '*';
1182           $log_text .= "    $prefix $status->{message}\n";
1183         }
1184       }
1185       $self->log_warn("$log_text") unless $self->quiet;
1186     } else {
1187       $self->log_info("enabled\n");
1188     }
1189   }
1190
1191   $self->log_warn("\n");
1192 }
1193
1194 sub prereq_failures {
1195   my ($self, $info) = @_;
1196
1197   my @types = @{ $self->prereq_action_types };
1198   $info ||= {map {$_, $self->$_()} @types};
1199
1200   my $out;
1201
1202   foreach my $type (@types) {
1203     my $prereqs = $info->{$type};
1204     while ( my ($modname, $spec) = each %$prereqs ) {
1205       my $status = $self->check_installed_status($modname, $spec);
1206
1207       if ($type =~ /^(?:\w+_)?conflicts$/) {
1208         next if !$status->{ok};
1209         $status->{conflicts} = delete $status->{need};
1210         $status->{message} = "$modname ($status->{have}) conflicts with this distribution";
1211
1212       } elsif ($type =~ /^(?:\w+_)?recommends$/) {
1213         next if $status->{ok};
1214         $status->{message} = (!ref($status->{have}) && $status->{have} eq '<none>'
1215                               ? "Optional prerequisite $modname is not installed"
1216                               : "$modname ($status->{have}) is installed, but we prefer to have $spec");
1217       } else {
1218         next if $status->{ok};
1219       }
1220
1221       $out->{$type}{$modname} = $status;
1222     }
1223   }
1224
1225   return $out;
1226 }
1227
1228 # returns a hash of defined prerequisites; i.e. only prereq types with values
1229 sub _enum_prereqs {
1230   my $self = shift;
1231   my %prereqs;
1232   foreach my $type ( @{ $self->prereq_action_types } ) {
1233     if ( $self->can( $type ) ) {
1234       my $prereq = $self->$type() || {};
1235       $prereqs{$type} = $prereq if %$prereq;
1236     }
1237   }
1238   return \%prereqs;
1239 }
1240
1241 sub check_prereq {
1242   my $self = shift;
1243
1244   # If we have XS files, make sure we can process them.
1245   my $xs_files = $self->find_xs_files;
1246   if (keys %$xs_files && !$self->_mb_feature('C_support')) {
1247     $self->log_warn("Warning: this distribution contains XS files, ".
1248                     "but Module::Build is not configured with C_support.  ".
1249                     "Please install ExtUtils::CBuilder to enable C_support.\n");
1250   }
1251
1252   # Check to see if there are any prereqs to check
1253   my $info = $self->_enum_prereqs;
1254   return 1 unless $info;
1255
1256   $self->log_info("Checking prerequisites...\n");
1257
1258   my $failures = $self->prereq_failures($info);
1259
1260   if ( $failures ) {
1261
1262     while (my ($type, $prereqs) = each %$failures) {
1263       while (my ($module, $status) = each %$prereqs) {
1264         my $prefix = ($type =~ /^(?:\w+_)?recommends$/) ? '*' : '- ERROR:';
1265         $self->log_warn(" $prefix $status->{message}\n");
1266       }
1267     }
1268
1269     $self->log_warn(<<EOF);
1270
1271 ERRORS/WARNINGS FOUND IN PREREQUISITES.  You may wish to install the versions
1272 of the modules indicated above before proceeding with this installation
1273
1274 EOF
1275     return 0;
1276
1277   } else {
1278
1279     $self->log_info("Looks good\n\n");
1280     return 1;
1281
1282   }
1283 }
1284
1285 sub perl_version {
1286   my ($self) = @_;
1287   # Check the current perl interpreter
1288   # It's much more convenient to use $] here than $^V, but 'man
1289   # perlvar' says I'm not supposed to.  Bloody tyrant.
1290   return $^V ? $self->perl_version_to_float(sprintf "%vd", $^V) : $];
1291 }
1292
1293 sub perl_version_to_float {
1294   my ($self, $version) = @_;
1295   return $version if grep( /\./, $version ) < 2;
1296   $version =~ s/\./../;
1297   $version =~ s/\.(\d+)/sprintf '%03d', $1/eg;
1298   return $version;
1299 }
1300
1301 sub _parse_conditions {
1302   my ($self, $spec) = @_;
1303
1304   if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores
1305     return (">= $spec");
1306   } else {
1307     return split /\s*,\s*/, $spec;
1308   }
1309 }
1310
1311 sub check_installed_status {
1312   my ($self, $modname, $spec) = @_;
1313   my %status = (need => $spec);
1314
1315   if ($modname eq 'perl') {
1316     $status{have} = $self->perl_version;
1317
1318   } elsif (eval { no strict; $status{have} = ${"${modname}::VERSION"} }) {
1319     # Don't try to load if it's already loaded
1320
1321   } else {
1322     my $pm_info = Module::Build::ModuleInfo->new_from_module( $modname );
1323     unless (defined( $pm_info )) {
1324       @status{ qw(have message) } = ('<none>', "$modname is not installed");
1325       return \%status;
1326     }
1327
1328     $status{have} = $pm_info->version();
1329     if ($spec and !defined($status{have})) {
1330       @status{ qw(have message) } = (undef, "Couldn't find a \$VERSION in prerequisite $modname");
1331       return \%status;
1332     }
1333   }
1334
1335   my @conditions = $self->_parse_conditions($spec);
1336
1337   foreach (@conditions) {
1338     my ($op, $version) = /^\s*  (<=?|>=?|==|!=)  \s*  ([\w.]+)  \s*$/x
1339       or die "Invalid prerequisite condition '$_' for $modname";
1340
1341     $version = $self->perl_version_to_float($version)
1342       if $modname eq 'perl';
1343
1344     next if $op eq '>=' and !$version;  # Module doesn't have to actually define a $VERSION
1345
1346     unless ($self->compare_versions( $status{have}, $op, $version )) {
1347       $status{message} = "$modname ($status{have}) is installed, but we need version $op $version";
1348       return \%status;
1349     }
1350   }
1351
1352   $status{ok} = 1;
1353   return \%status;
1354 }
1355
1356 sub compare_versions {
1357   my $self = shift;
1358   my ($v1, $op, $v2) = @_;
1359   $v1 = Module::Build::Version->new($v1)
1360     unless UNIVERSAL::isa($v1,'Module::Build::Version');
1361
1362   my $eval_str = "\$v1 $op \$v2";
1363   my $result   = eval $eval_str;
1364   $self->log_warn("error comparing versions: '$eval_str' $@") if $@;
1365
1366   return $result;
1367 }
1368
1369 # I wish I could set $! to a string, but I can't, so I use $@
1370 sub check_installed_version {
1371   my ($self, $modname, $spec) = @_;
1372
1373   my $status = $self->check_installed_status($modname, $spec);
1374
1375   if ($status->{ok}) {
1376     return $status->{have} if $status->{have} and "$status->{have}" ne '<none>';
1377     return '0 but true';
1378   }
1379
1380   $@ = $status->{message};
1381   return 0;
1382 }
1383
1384 sub make_executable {
1385   # Perl's chmod() is mapped to useful things on various non-Unix
1386   # platforms, so we use it in the base class even though it looks
1387   # Unixish.
1388
1389   my $self = shift;
1390   foreach (@_) {
1391     my $current_mode = (stat $_)[2];
1392     chmod $current_mode | oct(111), $_;
1393   }
1394 }
1395
1396 sub is_executable {
1397   # We assume this does the right thing on generic platforms, though
1398   # we do some other more specific stuff on Unixish platforms.
1399   my ($self, $file) = @_;
1400   return -x $file;
1401 }
1402
1403 sub _startperl { shift()->config('startperl') }
1404
1405 # Return any directories in @INC which are not in the default @INC for
1406 # this perl.  For example, stuff passed in with -I or loaded with "use lib".
1407 sub _added_to_INC {
1408   my $self = shift;
1409
1410   my %seen;
1411   $seen{$_}++ foreach $self->_default_INC;
1412   return grep !$seen{$_}++, @INC;
1413 }
1414
1415 # Determine the default @INC for this Perl
1416 {
1417   my @default_inc; # Memoize
1418   sub _default_INC {
1419     my $self = shift;
1420     return @default_inc if @default_inc;
1421
1422     local $ENV{PERL5LIB};  # this is not considered part of the default.
1423
1424     my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
1425
1426     my @inc = $self->_backticks($perl, '-le', 'print for @INC');
1427     chomp @inc;
1428
1429     return @default_inc = @inc;
1430   }
1431 }
1432
1433 sub print_build_script {
1434   my ($self, $fh) = @_;
1435
1436   my $build_package = $self->build_class;
1437
1438   my $closedata="";
1439
1440   my %q = map {$_, $self->$_()} qw(config_dir base_dir);
1441
1442   my $case_tolerant = 0+(File::Spec->can('case_tolerant')
1443                          && File::Spec->case_tolerant);
1444   $q{base_dir} = uc $q{base_dir} if $case_tolerant;
1445   $q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish;
1446
1447   $q{magic_numfile} = $self->config_file('magicnum');
1448
1449   my @myINC = $self->_added_to_INC;
1450   for (@myINC, values %q) {
1451     $_ = File::Spec->canonpath( $_ );
1452     s/([\\\'])/\\$1/g;
1453   }
1454
1455   my $quoted_INC = join ",\n", map "     '$_'", @myINC;
1456   my $shebang = $self->_startperl;
1457   my $magic_number = $self->magic_number;
1458
1459   print $fh <<EOF;
1460 $shebang
1461
1462 use strict;
1463 use Cwd;
1464 use File::Basename;
1465 use File::Spec;
1466
1467 sub magic_number_matches {
1468   return 0 unless -e '$q{magic_numfile}';
1469   local *FH;
1470   open FH, '$q{magic_numfile}' or return 0;
1471   my \$filenum = <FH>;
1472   close FH;
1473   return \$filenum == $magic_number;
1474 }
1475
1476 my \$progname;
1477 my \$orig_dir;
1478 BEGIN {
1479   \$^W = 1;  # Use warnings
1480   \$progname = basename(\$0);
1481   \$orig_dir = Cwd::cwd();
1482   my \$base_dir = '$q{base_dir}';
1483   if (!magic_number_matches()) {
1484     unless (chdir(\$base_dir)) {
1485       die ("Couldn't chdir(\$base_dir), aborting\\n");
1486     }
1487     unless (magic_number_matches()) {
1488       die ("Configuration seems to be out of date, please re-run 'perl Build.PL' again.\\n");
1489     }
1490   }
1491   unshift \@INC,
1492     (
1493 $quoted_INC
1494     );
1495 }
1496
1497 close(*DATA) unless eof(*DATA); # ensure no open handles to this script
1498
1499 use $build_package;
1500
1501 # Some platforms have problems setting \$^X in shebang contexts, fix it up here
1502 \$^X = Module::Build->find_perl_interpreter;
1503
1504 if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) {
1505    warn "Warning: Build.PL has been altered.  You may need to run 'perl Build.PL' again.\\n";
1506 }
1507
1508 # This should have just enough arguments to be able to bootstrap the rest.
1509 my \$build = $build_package->resume (
1510   properties => {
1511     config_dir => '$q{config_dir}',
1512     orig_dir => \$orig_dir,
1513   },
1514 );
1515
1516 \$build->dispatch;
1517 EOF
1518 }
1519
1520 sub create_build_script {
1521   my ($self) = @_;
1522   $self->write_config;
1523
1524   my ($build_script, $dist_name, $dist_version)
1525     = map $self->$_(), qw(build_script dist_name dist_version);
1526
1527   if ( $self->delete_filetree($build_script) ) {
1528     $self->log_info("Removed previous script '$build_script'\n\n");
1529   }
1530
1531   $self->log_info("Creating new '$build_script' script for ",
1532                   "'$dist_name' version '$dist_version'\n");
1533   my $fh = IO::File->new(">$build_script") or die "Can't create '$build_script': $!";
1534   $self->print_build_script($fh);
1535   close $fh;
1536
1537   $self->make_executable($build_script);
1538
1539   return 1;
1540 }
1541
1542 sub check_manifest {
1543   my $self = shift;
1544   return unless -e 'MANIFEST';
1545
1546   # Stolen nearly verbatim from MakeMaker.  But ExtUtils::Manifest
1547   # could easily be re-written into a modern Perl dialect.
1548
1549   require ExtUtils::Manifest;  # ExtUtils::Manifest is not warnings clean.
1550   local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
1551
1552   $self->log_info("Checking whether your kit is complete...\n");
1553   if (my @missed = ExtUtils::Manifest::manicheck()) {
1554     $self->log_warn("WARNING: the following files are missing in your kit:\n",
1555                     "\t", join("\n\t", @missed), "\n",
1556                     "Please inform the author.\n\n");
1557   } else {
1558     $self->log_info("Looks good\n\n");
1559   }
1560 }
1561
1562 sub dispatch {
1563   my $self = shift;
1564   local $self->{_completed_actions} = {};
1565
1566   if (@_) {
1567     my ($action, %p) = @_;
1568     my $args = $p{args} ? delete($p{args}) : {};
1569
1570     local $self->{invoked_action} = $action;
1571     local $self->{args} = {%{$self->{args}}, %$args};
1572     local $self->{properties} = {%{$self->{properties}}, %p};
1573     return $self->_call_action($action);
1574   }
1575
1576   die "No build action specified" unless $self->{action};
1577   local $self->{invoked_action} = $self->{action};
1578   $self->_call_action($self->{action});
1579 }
1580
1581 sub _call_action {
1582   my ($self, $action) = @_;
1583
1584   return if $self->{_completed_actions}{$action}++;
1585
1586   local $self->{action} = $action;
1587   my $method = "ACTION_$action";
1588   die "No action '$action' defined, try running the 'help' action.\n" unless $self->can($method);
1589   return $self->$method();
1590 }
1591
1592 # cuts the user-specified options out of the command-line args
1593 sub cull_options {
1594     my $self = shift;
1595     my (@argv) = @_;
1596
1597     # XXX is it even valid to call this as a class method?
1598     return({}, @argv) unless(ref($self)); # no object
1599
1600     my $specs = $self->get_options;
1601     return({}, @argv) unless($specs and %$specs); # no user options
1602
1603     require Getopt::Long;
1604     # XXX Should we let Getopt::Long handle M::B's options? That would
1605     # be easy-ish to add to @specs right here, but wouldn't handle options
1606     # passed without "--" as M::B currently allows. We might be able to
1607     # get around this by setting the "prefix_pattern" Configure option.
1608     my @specs;
1609     my $args = {};
1610     # Construct the specifications for GetOptions.
1611     while (my ($k, $v) = each %$specs) {
1612         # Throw an error if specs conflict with our own.
1613         die "Option specification '$k' conflicts with a " . ref $self
1614           . " option of the same name"
1615           if $self->valid_property($k);
1616         push @specs, $k . (defined $v->{type} ? $v->{type} : '');
1617         push @specs, $v->{store} if exists $v->{store};
1618         $args->{$k} = $v->{default} if exists $v->{default};
1619     }
1620
1621     local @ARGV = @argv; # No other way to dupe Getopt::Long
1622
1623     # Get the options values and return them.
1624     # XXX Add option to allow users to set options?
1625     if ( @specs ) {
1626       Getopt::Long::Configure('pass_through');
1627       Getopt::Long::GetOptions($args, @specs);
1628     }
1629
1630     return $args, @ARGV;
1631 }
1632
1633 sub unparse_args {
1634   my ($self, $args) = @_;
1635   my @out;
1636   while (my ($k, $v) = each %$args) {
1637     push @out, (UNIVERSAL::isa($v, 'HASH')  ? map {+"--$k", "$_=$v->{$_}"} keys %$v :
1638                 UNIVERSAL::isa($v, 'ARRAY') ? map {+"--$k", $_} @$v :
1639                 ("--$k", $v));
1640   }
1641   return @out;
1642 }
1643
1644 sub args {
1645     my $self = shift;
1646     return wantarray ? %{ $self->{args} } : $self->{args} unless @_;
1647     my $key = shift;
1648     $self->{args}{$key} = shift if @_;
1649     return $self->{args}{$key};
1650 }
1651
1652 # allows select parameters (with underscores) to be spoken with dashes
1653 # when used as command-line options
1654 sub _translate_option {
1655   my $self = shift;
1656   my $opt  = shift;
1657
1658   (my $tr_opt = $opt) =~ tr/-/_/;
1659
1660   return $tr_opt if grep $tr_opt =~ /^(?:no_?)?$_$/, qw(
1661     create_license
1662     create_makefile_pl
1663     create_readme
1664     extra_compiler_flags
1665     extra_linker_flags
1666     html_css
1667     install_base
1668     install_path
1669     meta_add
1670     meta_merge
1671     test_files
1672     use_rcfile
1673     use_tap_harness
1674     tap_harness_args
1675   ); # normalize only selected option names
1676
1677   return $opt;
1678 }
1679
1680 sub _read_arg {
1681   my ($self, $args, $key, $val) = @_;
1682
1683   $key = $self->_translate_option($key);
1684
1685   if ( exists $args->{$key} ) {
1686     $args->{$key} = [ $args->{$key} ] unless ref $args->{$key};
1687     push @{$args->{$key}}, $val;
1688   } else {
1689     $args->{$key} = $val;
1690   }
1691 }
1692
1693 # decide whether or not an option requires/has an opterand
1694 sub _optional_arg {
1695   my $self = shift;
1696   my $opt  = shift;
1697   my $argv = shift;
1698
1699   $opt = $self->_translate_option($opt);
1700
1701   my @bool_opts = qw(
1702     build_bat
1703     create_license
1704     create_readme
1705     pollute
1706     quiet
1707     uninst
1708     use_rcfile
1709     verbose
1710     sign
1711     use_tap_harness
1712   );
1713
1714   # inverted boolean options; eg --noverbose or --no-verbose
1715   # converted to proper name & returned with false value (verbose, 0)
1716   if ( grep $opt =~ /^no[-_]?$_$/, @bool_opts ) {
1717     $opt =~ s/^no-?//;
1718     return ($opt, 0);
1719   }
1720
1721   # non-boolean option; return option unchanged along with its argument
1722   return ($opt, shift(@$argv)) unless grep $_ eq $opt, @bool_opts;
1723
1724   # we're punting a bit here, if an option appears followed by a digit
1725   # we take the digit as the argument for the option. If there is
1726   # nothing that looks like a digit, we pretend the option is a flag
1727   # that is being set and has no argument.
1728   my $arg = 1;
1729   $arg = shift(@$argv) if @$argv && $argv->[0] =~ /^\d+$/;
1730
1731   return ($opt, $arg);
1732 }
1733
1734 sub read_args {
1735   my $self = shift;
1736
1737   (my $args, @_) = $self->cull_options(@_);
1738   my %args = %$args;
1739
1740   my $opt_re = qr/[\w\-]+/;
1741
1742   my ($action, @argv);
1743   while (@_) {
1744     local $_ = shift;
1745     if ( /^(?:--)?($opt_re)=(.*)$/ ) {
1746       $self->_read_arg(\%args, $1, $2);
1747     } elsif ( /^--($opt_re)$/ ) {
1748       my($opt, $arg) = $self->_optional_arg($1, \@_);
1749       $self->_read_arg(\%args, $opt, $arg);
1750     } elsif ( /^($opt_re)$/ and !defined($action)) {
1751       $action = $1;
1752     } else {
1753       push @argv, $_;
1754     }
1755   }
1756   $args{ARGV} = \@argv;
1757
1758   for ('extra_compiler_flags', 'extra_linker_flags') {
1759     $args{$_} = [ $self->split_like_shell($args{$_}) ] if exists $args{$_};
1760   }
1761
1762   # Hashify these parameters
1763   for ($self->hash_properties, 'config') {
1764     next unless exists $args{$_};
1765     my %hash;
1766     $args{$_} ||= [];
1767     $args{$_} = [ $args{$_} ] unless ref $args{$_};
1768     foreach my $arg ( @{$args{$_}} ) {
1769       $arg =~ /(\w+)=(.*)/
1770         or die "Malformed '$_' argument: '$arg' should be something like 'foo=bar'";
1771       $hash{$1} = $2;
1772     }
1773     $args{$_} = \%hash;
1774   }
1775
1776   # De-tilde-ify any path parameters
1777   for my $key (qw(prefix install_base destdir)) {
1778     next if !defined $args{$key};
1779     $args{$key} = $self->_detildefy($args{$key});
1780   }
1781
1782   for my $key (qw(install_path)) {
1783     next if !defined $args{$key};
1784
1785     for my $subkey (keys %{$args{$key}}) {
1786       next if !defined $args{$key}{$subkey};
1787       my $subkey_ext = $self->_detildefy($args{$key}{$subkey});
1788       if ( $subkey eq 'html' ) { # translate for compatability
1789         $args{$key}{binhtml} = $subkey_ext;
1790         $args{$key}{libhtml} = $subkey_ext;
1791       } else {
1792         $args{$key}{$subkey} = $subkey_ext;
1793       }
1794     }
1795   }
1796
1797   if ($args{makefile_env_macros}) {
1798     require Module::Build::Compat;
1799     %args = (%args, Module::Build::Compat->makefile_to_build_macros);
1800   }
1801
1802   return \%args, $action;
1803 }
1804
1805 # Default: do nothing.  Overridden for Unix & Windows.
1806 sub _detildefy {}
1807
1808
1809 # merge Module::Build argument lists that have already been parsed
1810 # by read_args(). Takes two references to option hashes and merges
1811 # the contents, giving priority to the first.
1812 sub _merge_arglist {
1813   my( $self, $opts1, $opts2 ) = @_;
1814
1815   my %new_opts = %$opts1;
1816   while (my ($key, $val) = each %$opts2) {
1817     if ( exists( $opts1->{$key} ) ) {
1818       if ( ref( $val ) eq 'HASH' ) {
1819         while (my ($k, $v) = each %$val) {
1820           $new_opts{$key}{$k} = $v unless exists( $opts1->{$key}{$k} );
1821         }
1822       }
1823     } else {
1824       $new_opts{$key} = $val
1825     }
1826   }
1827
1828   return %new_opts;
1829 }
1830
1831 # Look for a home directory on various systems.
1832 sub _home_dir {
1833   my @home_dirs;
1834   push( @home_dirs, $ENV{HOME} ) if $ENV{HOME};
1835
1836   push( @home_dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
1837       if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
1838
1839   my @other_home_envs = qw( USERPROFILE APPDATA WINDIR SYS$LOGIN );
1840   push( @home_dirs, map $ENV{$_}, grep $ENV{$_}, @other_home_envs );
1841
1842   my @real_home_dirs = grep -d, @home_dirs;
1843
1844   return wantarray ? @real_home_dirs : shift( @real_home_dirs );
1845 }
1846
1847 sub _find_user_config {
1848   my $self = shift;
1849   my $file = shift;
1850   foreach my $dir ( $self->_home_dir ) {
1851     my $path = File::Spec->catfile( $dir, $file );
1852     return $path if -e $path;
1853   }
1854   return undef;
1855 }
1856
1857 # read ~/.modulebuildrc returning global options '*' and
1858 # options specific to the currently executing $action.
1859 sub read_modulebuildrc {
1860   my( $self, $action ) = @_;
1861
1862   return () unless $self->use_rcfile;
1863
1864   my $modulebuildrc;
1865   if ( exists($ENV{MODULEBUILDRC}) && $ENV{MODULEBUILDRC} eq 'NONE' ) {
1866     return ();
1867   } elsif ( exists($ENV{MODULEBUILDRC}) && -e $ENV{MODULEBUILDRC} ) {
1868     $modulebuildrc = $ENV{MODULEBUILDRC};
1869   } elsif ( exists($ENV{MODULEBUILDRC}) ) {
1870     $self->log_warn("WARNING: Can't find resource file " .
1871                     "'$ENV{MODULEBUILDRC}' defined in environment.\n" .
1872                     "No options loaded\n");
1873     return ();
1874   } else {
1875     $modulebuildrc = $self->_find_user_config( '.modulebuildrc' );
1876     return () unless $modulebuildrc;
1877   }
1878
1879   my $fh = IO::File->new( $modulebuildrc )
1880       or die "Can't open $modulebuildrc: $!";
1881
1882   my %options; my $buffer = '';
1883   while (defined( my $line = <$fh> )) {
1884     chomp( $line );
1885     $line =~ s/#.*$//;
1886     next unless length( $line );
1887
1888     if ( $line =~ /^\S/ ) {
1889       if ( $buffer ) {
1890         my( $action, $options ) = split( /\s+/, $buffer, 2 );
1891         $options{$action} .= $options . ' ';
1892         $buffer = '';
1893       }
1894       $buffer = $line;
1895     } else {
1896       $buffer .= $line;
1897     }
1898   }
1899
1900   if ( $buffer ) { # anything left in $buffer ?
1901     my( $action, $options ) = split( /\s+/, $buffer, 2 );
1902     $options{$action} .= $options . ' '; # merge if more than one line
1903   }
1904
1905   my ($global_opts) =
1906     $self->read_args( $self->split_like_shell( $options{'*'} || '' ) );
1907   my ($action_opts) =
1908     $self->read_args( $self->split_like_shell( $options{$action} || '' ) );
1909
1910   # specific $action options take priority over global options '*'
1911   return $self->_merge_arglist( $action_opts, $global_opts );
1912 }
1913
1914 # merge the relevant options in ~/.modulebuildrc into Module::Build's
1915 # option list where they do not conflict with commandline options.
1916 sub merge_modulebuildrc {
1917   my( $self, $action, %cmdline_opts ) = @_;
1918   my %rc_opts = $self->read_modulebuildrc( $action || $self->{action} || 'build' );
1919   my %new_opts = $self->_merge_arglist( \%cmdline_opts, \%rc_opts );
1920   $self->merge_args( $action, %new_opts );
1921 }
1922
1923 sub merge_args {
1924   my ($self, $action, %args) = @_;
1925   $self->{action} = $action if defined $action;
1926
1927   my %additive = map { $_ => 1 } $self->hash_properties;
1928
1929   # Extract our 'properties' from $cmd_args, the rest are put in 'args'.
1930   while (my ($key, $val) = each %args) {
1931     $self->{phash}{runtime_params}->access( $key => $val )
1932       if $self->valid_property($key);
1933
1934     if ($key eq 'config') {
1935       $self->config($_ => $val->{$_}) foreach keys %$val;
1936     } else {
1937       my $add_to = $additive{$key}             ? $self->{properties}{$key} :
1938                    $self->valid_property($key) ? $self->{properties}       :
1939                    $self->{args}               ;
1940
1941       if ($additive{$key}) {
1942         $add_to->{$_} = $val->{$_} foreach keys %$val;
1943       } else {
1944         $add_to->{$key} = $val;
1945       }
1946     }
1947   }
1948 }
1949
1950 sub cull_args {
1951   my $self = shift;
1952   my ($args, $action) = $self->read_args(@_);
1953   $self->merge_args($action, %$args);
1954   $self->merge_modulebuildrc( $action, %$args );
1955 }
1956
1957 sub super_classes {
1958   my ($self, $class, $seen) = @_;
1959   $class ||= ref($self) || $self;
1960   $seen  ||= {};
1961
1962   no strict 'refs';
1963   my @super = grep {not $seen->{$_}++} $class, @{ $class . '::ISA' };
1964   return @super, map {$self->super_classes($_,$seen)} @super;
1965 }
1966
1967 sub known_actions {
1968   my ($self) = @_;
1969
1970   my %actions;
1971   no strict 'refs';
1972
1973   foreach my $class ($self->super_classes) {
1974     foreach ( keys %{ $class . '::' } ) {
1975       $actions{$1}++ if /^ACTION_(\w+)/;
1976     }
1977   }
1978
1979   return wantarray ? sort keys %actions : \%actions;
1980 }
1981
1982 sub get_action_docs {
1983   my ($self, $action) = @_;
1984   my $actions = $self->known_actions;
1985   die "No known action '$action'" unless $actions->{$action};
1986
1987   my ($files_found, @docs) = (0);
1988   foreach my $class ($self->super_classes) {
1989     (my $file = $class) =~ s{::}{/}g;
1990     # NOTE: silently skipping relative paths if any chdir() happened
1991     $file = $INC{$file . '.pm'} or next;
1992     my $fh = IO::File->new("< $file") or next;
1993     $files_found++;
1994
1995     # Code below modified from /usr/bin/perldoc
1996
1997     # Skip to ACTIONS section
1998     local $_;
1999     while (<$fh>) {
2000       last if /^=head1 ACTIONS\s/;
2001     }
2002
2003     # Look for our action and determine the style
2004     my $style;
2005     while (<$fh>) {
2006       last if /^=head1 /;
2007
2008       # only item and head2 are allowed (3&4 are not in 5.005)
2009       if(/^=(item|head2)\s+\Q$action\E\b/) {
2010         $style = $1;
2011         push @docs, $_;
2012         last;
2013       }
2014     }
2015     $style or next; # not here
2016
2017     # and the content
2018     if($style eq 'item') {
2019       my ($found, $inlist) = (0, 0);
2020       while (<$fh>) {
2021         if (/^=(item|back)/) {
2022           last unless $inlist;
2023         }
2024         push @docs, $_;
2025         ++$inlist if /^=over/;
2026         --$inlist if /^=back/;
2027       }
2028     }
2029     else { # head2 style
2030       # stop at anything equal or greater than the found level
2031       while (<$fh>) {
2032         last if(/^=(?:head[12]|cut)/);
2033         push @docs, $_;
2034       }
2035     }
2036     # TODO maybe disallow overriding just pod for an action
2037     # TODO and possibly: @docs and last;
2038   }
2039
2040   unless ($files_found) {
2041     $@ = "Couldn't find any documentation to search";
2042     return;
2043   }
2044   unless (@docs) {
2045     $@ = "Couldn't find any docs for action '$action'";
2046     return;
2047   }
2048
2049   return join '', @docs;
2050 }
2051
2052 sub ACTION_prereq_report {
2053   my $self = shift;
2054   $self->log_info( $self->prereq_report );
2055 }
2056
2057 sub prereq_report {
2058   my $self = shift;
2059   my @types = @{ $self->prereq_action_types };
2060   my $info = { map { $_ => $self->$_() } @types };
2061
2062   my $output = '';
2063   foreach my $type (@types) {
2064     my $prereqs = $info->{$type};
2065     next unless %$prereqs;
2066     $output .= "\n$type:\n";
2067     my $mod_len = 2;
2068     my $ver_len = 4;
2069     my %mods;
2070     while ( my ($modname, $spec) = each %$prereqs ) {
2071       my $len  = length $modname;
2072       $mod_len = $len if $len > $mod_len;
2073       $spec    ||= '0';
2074       $len     = length $spec;
2075       $ver_len = $len if $len > $ver_len;
2076
2077       my $mod = $self->check_installed_status($modname, $spec);
2078       $mod->{name} = $modname;
2079       $mod->{ok} ||= 0;
2080       $mod->{ok} = ! $mod->{ok} if $type =~ /^(\w+_)?conflicts$/;
2081
2082       $mods{lc $modname} = $mod;
2083     }
2084
2085     my $space  = q{ } x ($mod_len - 3);
2086     my $vspace = q{ } x ($ver_len - 3);
2087     my $sline  = q{-} x ($mod_len - 3);
2088     my $vline  = q{-} x ($ver_len - 3);
2089     my $disposition = ($type =~ /^(\w+_)?conflicts$/) ?
2090                         'Clash' : 'Need';
2091     $output .=
2092       "    Module $space  $disposition $vspace  Have\n".
2093       "    ------$sline+------$vline-+----------\n";
2094
2095
2096     for my $k (sort keys %mods) {
2097       my $mod = $mods{$k};
2098       my $space  = q{ } x ($mod_len - length $k);
2099       my $vspace = q{ } x ($ver_len - length $mod->{need});
2100       my $f = $mod->{ok} ? ' ' : '!';
2101       $output .=
2102         "  $f $mod->{name} $space     $mod->{need}  $vspace   ".
2103         (defined($mod->{have}) ? $mod->{have} : "")."\n";
2104     }
2105   }
2106   return $output;
2107 }
2108
2109 sub ACTION_help {
2110   my ($self) = @_;
2111   my $actions = $self->known_actions;
2112
2113   if (@{$self->{args}{ARGV}}) {
2114     my $msg = eval {$self->get_action_docs($self->{args}{ARGV}[0], $actions)};
2115     print $@ ? "$@\n" : $msg;
2116     return;
2117   }
2118
2119   print <<EOF;
2120
2121  Usage: $0 <action> arg1=value arg2=value ...
2122  Example: $0 test verbose=1
2123
2124  Actions defined:
2125 EOF
2126
2127   print $self->_action_listing($actions);
2128
2129   print "\nRun `Build help <action>` for details on an individual action.\n";
2130   print "See `perldoc Module::Build` for complete documentation.\n";
2131 }
2132
2133 sub _action_listing {
2134   my ($self, $actions) = @_;
2135
2136   # Flow down columns, not across rows
2137   my @actions = sort keys %$actions;
2138   @actions = map $actions[($_ + ($_ % 2) * @actions) / 2],  0..$#actions;
2139
2140   my $out = '';
2141   while (my ($one, $two) = splice @actions, 0, 2) {
2142     $out .= sprintf("  %-12s                   %-12s\n", $one, $two||'');
2143   }
2144   return $out;
2145 }
2146
2147 sub ACTION_retest {
2148   my ($self) = @_;
2149
2150   # Protect others against our @INC changes
2151   local @INC = @INC;
2152
2153   # Filter out nonsensical @INC entries - some versions of
2154   # Test::Harness will really explode the number of entries here
2155   @INC = grep {ref() || -d} @INC if @INC > 100;
2156
2157   $self->do_tests;
2158 }
2159
2160 sub ACTION_testall {
2161   my ($self) = @_;
2162
2163   my @types;
2164   for my $action (grep { $_ ne 'all' } $self->get_test_types) {
2165     # XXX We can't just dispatch because we get multiple summaries but
2166     # we'll need to dispatch to support custom setup/teardown in the
2167     # action.  To support that, we'll need to call something besides
2168     # Harness::runtests() because we'll need to collect the results in
2169     # parts, then run the summary.
2170     push(@types, $action);
2171     #$self->_call_action( "test$action" );
2172   }
2173   $self->generic_test(types => ['default', @types]);
2174 }
2175
2176 sub get_test_types {
2177   my ($self) = @_;
2178
2179   my $t = $self->{properties}->{test_types};
2180   return ( defined $t ? ( keys %$t ) : () );
2181 }
2182
2183
2184 sub ACTION_test {
2185   my ($self) = @_;
2186   $self->generic_test(type => 'default');
2187 }
2188
2189 sub generic_test {
2190   my $self = shift;
2191   (@_ % 2) and croak('Odd number of elements in argument hash');
2192   my %args = @_;
2193
2194   my $p = $self->{properties};
2195
2196   my @types = (
2197     (exists($args{type})  ? $args{type} : ()),
2198     (exists($args{types}) ? @{$args{types}} : ()),
2199   );
2200   @types or croak "need some types of tests to check";
2201
2202   my %test_types = (
2203     default => $p->{test_file_exts},
2204     (defined($p->{test_types}) ? %{$p->{test_types}} : ()),
2205   );
2206
2207   for my $type (@types) {
2208     croak "$type not defined in test_types!"
2209       unless defined $test_types{ $type };
2210   }
2211
2212   # we use local here because it ends up two method calls deep
2213   local $p->{test_file_exts} = [ map { ref $_ ? @$_ : $_ } @test_types{@types} ];
2214   $self->depends_on('code');
2215
2216   # Protect others against our @INC changes
2217   local @INC = @INC;
2218
2219   # Make sure we test the module in blib/
2220   unshift @INC, (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
2221                  File::Spec->catdir($p->{base_dir}, $self->blib, 'arch'));
2222
2223   # Filter out nonsensical @INC entries - some versions of
2224   # Test::Harness will really explode the number of entries here
2225   @INC = grep {ref() || -d} @INC if @INC > 100;
2226
2227   $self->do_tests;
2228 }
2229
2230 sub do_tests {
2231   my $self = shift;
2232
2233   my $tests = $self->find_test_files;
2234
2235   if(@$tests) {
2236     my $args = $self->tap_harness_args;
2237     if($self->use_tap_harness or ($args and %$args)) {
2238       $self->run_tap_harness($tests);
2239     }
2240     else {
2241       $self->run_test_harness($tests);
2242     }
2243   }
2244   else {
2245     $self->log_info("No tests defined.\n");
2246   }
2247
2248   $self->run_visual_script;
2249 }
2250
2251 sub run_tap_harness {
2252   my ($self, $tests) = @_;
2253
2254   require TAP::Harness;
2255
2256   # TODO allow the test @INC to be set via our API?
2257
2258   TAP::Harness->new({
2259     lib => [@INC],
2260     verbosity => $self->{properties}{verbose},
2261     switches  => [ $self->harness_switches ],
2262     %{ $self->tap_harness_args },
2263   })->runtests(@$tests);
2264 }
2265
2266 sub run_test_harness {
2267     my ($self, $tests) = @_;
2268     require Test::Harness;
2269     my $p = $self->{properties};
2270     my @harness_switches = $self->harness_switches;
2271
2272     # Work around a Test::Harness bug that loses the particular perl
2273     # we're running under.  $self->perl is trustworthy, but $^X isn't.
2274     local $^X = $self->perl;
2275
2276     # Do everything in our power to work with all versions of Test::Harness
2277     local $Test::Harness::switches    = join ' ', grep defined, $Test::Harness::switches, @harness_switches;
2278     local $Test::Harness::Switches    = join ' ', grep defined, $Test::Harness::Switches, @harness_switches;
2279     local $ENV{HARNESS_PERL_SWITCHES} = join ' ', grep defined, $ENV{HARNESS_PERL_SWITCHES}, @harness_switches;
2280
2281     $Test::Harness::switches = undef   unless length $Test::Harness::switches;
2282     $Test::Harness::Switches = undef   unless length $Test::Harness::Switches;
2283     delete $ENV{HARNESS_PERL_SWITCHES} unless length $ENV{HARNESS_PERL_SWITCHES};
2284
2285     local ($Test::Harness::verbose,
2286            $Test::Harness::Verbose,
2287            $ENV{TEST_VERBOSE},
2288            $ENV{HARNESS_VERBOSE}) = ($p->{verbose} || 0) x 4;
2289
2290     Test::Harness::runtests(@$tests);
2291 }
2292
2293 sub run_visual_script {
2294     my $self = shift;
2295     # This will get run and the user will see the output.  It doesn't
2296     # emit Test::Harness-style output.
2297     $self->run_perl_script('visual.pl', '-Mblib='.$self->blib)
2298         if -e 'visual.pl';
2299 }
2300
2301 sub harness_switches {
2302     shift->{properties}{debugger} ? qw(-w -d) : ();
2303 }
2304
2305 sub test_files {
2306   my $self = shift;
2307   my $p = $self->{properties};
2308   if (@_) {
2309     return $p->{test_files} = (@_ == 1 ? shift : [@_]);
2310   }
2311   return $self->find_test_files;
2312 }
2313
2314 sub expand_test_dir {
2315   my ($self, $dir) = @_;
2316   my $exts = $self->{properties}{test_file_exts};
2317
2318   return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts
2319     if $self->recursive_test_files;
2320
2321   return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts;
2322 }
2323
2324 sub ACTION_testdb {
2325   my ($self) = @_;
2326   local $self->{properties}{debugger} = 1;
2327   $self->depends_on('test');
2328 }
2329
2330 sub ACTION_testcover {
2331   my ($self) = @_;
2332
2333   unless (Module::Build::ModuleInfo->find_module_by_name('Devel::Cover')) {
2334     warn("Cannot run testcover action unless Devel::Cover is installed.\n");
2335     return;
2336   }
2337
2338   $self->add_to_cleanup('coverage', 'cover_db');
2339   $self->depends_on('code');
2340
2341   # See whether any of the *.pm files have changed since last time
2342   # testcover was run.  If so, start over.
2343   if (-e 'cover_db') {
2344     my $pm_files = $self->rscan_dir
2345         (File::Spec->catdir($self->blib, 'lib'), file_qr('\.pm$') );
2346     my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/});
2347
2348     $self->do_system(qw(cover -delete))
2349       unless $self->up_to_date($pm_files,         $cover_files)
2350           && $self->up_to_date($self->test_files, $cover_files);
2351   }
2352
2353   local $Test::Harness::switches    =
2354   local $Test::Harness::Switches    =
2355   local $ENV{HARNESS_PERL_SWITCHES} = "-MDevel::Cover";
2356
2357   $self->depends_on('test');
2358   $self->do_system('cover');
2359 }
2360
2361 sub ACTION_code {
2362   my ($self) = @_;
2363
2364   # All installable stuff gets created in blib/ .
2365   # Create blib/arch to keep blib.pm happy
2366   my $blib = $self->blib;
2367   $self->add_to_cleanup($blib);
2368   File::Path::mkpath( File::Spec->catdir($blib, 'arch') );
2369
2370   if (my $split = $self->autosplit) {
2371     $self->autosplit_file($_, $blib) for ref($split) ? @$split : ($split);
2372   }
2373
2374   foreach my $element (@{$self->build_elements}) {
2375     my $method = "process_${element}_files";
2376     $method = "process_files_by_extension" unless $self->can($method);
2377     $self->$method($element);
2378   }
2379
2380   $self->depends_on('config_data');
2381 }
2382
2383 sub ACTION_build {
2384   my $self = shift;
2385   $self->depends_on('code');
2386   $self->depends_on('docs');
2387 }
2388
2389 sub process_files_by_extension {
2390   my ($self, $ext) = @_;
2391
2392   my $method = "find_${ext}_files";
2393   my $files = $self->can($method) ? $self->$method() : $self->_find_file_by_type($ext,  'lib');
2394
2395   while (my ($file, $dest) = each %$files) {
2396     $self->copy_if_modified(from => $file, to => File::Spec->catfile($self->blib, $dest) );
2397   }
2398 }
2399
2400 sub process_support_files {
2401   my $self = shift;
2402   my $p = $self->{properties};
2403   return unless $p->{c_source};
2404
2405   push @{$p->{include_dirs}}, $p->{c_source};
2406
2407   my $files = $self->rscan_dir($p->{c_source}, file_qr('\.c(pp)?$'));
2408   foreach my $file (@$files) {
2409     push @{$p->{objects}}, $self->compile_c($file);
2410   }
2411 }
2412
2413 sub process_PL_files {
2414   my ($self) = @_;
2415   my $files = $self->find_PL_files;
2416
2417   while (my ($file, $to) = each %$files) {
2418     unless ($self->up_to_date( $file, $to )) {
2419       $self->run_perl_script($file, [], [@$to]) or die "$file failed";
2420       $self->add_to_cleanup(@$to);
2421     }
2422   }
2423 }
2424
2425 sub process_xs_files {
2426   my $self = shift;
2427   my $files = $self->find_xs_files;
2428   while (my ($from, $to) = each %$files) {
2429     unless ($from eq $to) {
2430       $self->add_to_cleanup($to);
2431       $self->copy_if_modified( from => $from, to => $to );
2432     }
2433     $self->process_xs($to);
2434   }
2435 }
2436
2437 sub process_pod_files { shift()->process_files_by_extension(shift()) }
2438 sub process_pm_files  { shift()->process_files_by_extension(shift()) }
2439
2440 sub process_script_files {
2441   my $self = shift;
2442   my $files = $self->find_script_files;
2443   return unless keys %$files;
2444
2445   my $script_dir = File::Spec->catdir($self->blib, 'script');
2446   File::Path::mkpath( $script_dir );
2447
2448   foreach my $file (keys %$files) {
2449     my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
2450     $self->fix_shebang_line($result) unless $self->is_vmsish;
2451     $self->make_executable($result);
2452   }
2453 }
2454
2455 sub find_PL_files {
2456   my $self = shift;
2457   if (my $files = $self->{properties}{PL_files}) {
2458     # 'PL_files' is given as a Unix file spec, so we localize_file_path().
2459
2460     if (UNIVERSAL::isa($files, 'ARRAY')) {
2461       return { map {$_, [/^(.*)\.PL$/]}
2462                map $self->localize_file_path($_),
2463                @$files };
2464
2465     } elsif (UNIVERSAL::isa($files, 'HASH')) {
2466       my %out;
2467       while (my ($file, $to) = each %$files) {
2468         $out{ $self->localize_file_path($file) } = [ map $self->localize_file_path($_),
2469                                                      ref $to ? @$to : ($to) ];
2470       }
2471       return \%out;
2472
2473     } else {
2474       die "'PL_files' must be a hash reference or array reference";
2475     }
2476   }
2477
2478   return unless -d 'lib';
2479   return { map {$_, [/^(.*)\.PL$/i ]} @{ $self->rscan_dir('lib',
2480                                                           file_qr('\.PL$')) } };
2481 }
2482
2483 sub find_pm_files  { shift->_find_file_by_type('pm',  'lib') }
2484 sub find_pod_files { shift->_find_file_by_type('pod', 'lib') }
2485 sub find_xs_files  { shift->_find_file_by_type('xs',  'lib') }
2486
2487 sub find_script_files {
2488   my $self = shift;
2489   if (my $files = $self->script_files) {
2490     # Always given as a Unix file spec.  Values in the hash are
2491     # meaningless, but we preserve if present.
2492     return { map {$self->localize_file_path($_), $files->{$_}} keys %$files };
2493   }
2494
2495   # No default location for script files
2496   return {};
2497 }
2498
2499 sub find_test_files {
2500   my $self = shift;
2501   my $p = $self->{properties};
2502
2503   if (my $files = $p->{test_files}) {
2504     $files = [keys %$files] if UNIVERSAL::isa($files, 'HASH');
2505     $files = [map { -d $_ ? $self->expand_test_dir($_) : $_ }
2506               map glob,
2507               $self->split_like_shell($files)];
2508
2509     # Always given as a Unix file spec.
2510     return [ map $self->localize_file_path($_), @$files ];
2511
2512   } else {
2513     # Find all possible tests in t/ or test.pl
2514     my @tests;
2515     push @tests, 'test.pl'                          if -e 'test.pl';
2516     push @tests, $self->expand_test_dir('t')        if -e 't' and -d _;
2517     return \@tests;
2518   }
2519 }
2520
2521 sub _find_file_by_type {
2522   my ($self, $type, $dir) = @_;
2523
2524   if (my $files = $self->{properties}{"${type}_files"}) {
2525     # Always given as a Unix file spec
2526     return { map $self->localize_file_path($_), %$files };
2527   }
2528
2529   return {} unless -d $dir;
2530   return { map {$_, $_}
2531            map $self->localize_file_path($_),
2532            grep !/\.\#/,
2533            @{ $self->rscan_dir($dir, file_qr("\\.$type\$")) } };
2534 }
2535
2536 sub localize_file_path {
2537   my ($self, $path) = @_;
2538   return File::Spec->catfile( split m{/}, $path );
2539 }
2540
2541 sub localize_dir_path {
2542   my ($self, $path) = @_;
2543   return File::Spec->catdir( split m{/}, $path );
2544 }
2545
2546 sub fix_shebang_line { # Adapted from fixin() in ExtUtils::MM_Unix 1.35
2547   my ($self, @files) = @_;
2548   my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
2549
2550   my ($does_shbang) = $c->get('sharpbang') =~ /^\s*\#\!/;
2551   for my $file (@files) {
2552     my $FIXIN = IO::File->new($file) or die "Can't process '$file': $!";
2553     local $/ = "\n";
2554     chomp(my $line = <$FIXIN>);
2555     next unless $line =~ s/^\s*\#!\s*//;     # Not a shbang file.
2556
2557     my ($cmd, $arg) = (split(' ', $line, 2), '');
2558     next unless $cmd =~ /perl/i;
2559     my $interpreter = $self->{properties}{perl};
2560
2561     $self->log_verbose("Changing sharpbang in $file to $interpreter");
2562     my $shb = '';
2563     $shb .= $c->get('sharpbang')."$interpreter $arg\n" if $does_shbang;
2564
2565     # I'm not smart enough to know the ramifications of changing the
2566     # embedded newlines here to \n, so I leave 'em in.
2567     $shb .= qq{
2568 eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
2569     if 0; # not running under some shell
2570 } unless $self->is_windowsish; # this won't work on win32, so don't
2571
2572     my $FIXOUT = IO::File->new(">$file.new")
2573       or die "Can't create new $file: $!\n";
2574
2575     # Print out the new #! line (or equivalent).
2576     local $\;
2577     undef $/; # Was localized above
2578     print $FIXOUT $shb, <$FIXIN>;
2579     close $FIXIN;
2580     close $FIXOUT;
2581
2582     rename($file, "$file.bak")
2583       or die "Can't rename $file to $file.bak: $!";
2584
2585     rename("$file.new", $file)
2586       or die "Can't rename $file.new to $file: $!";
2587
2588     $self->delete_filetree("$file.bak")
2589       or $self->log_warn("Couldn't clean up $file.bak, leaving it there");
2590
2591     $self->do_system($c->get('eunicefix'), $file) if $c->get('eunicefix') ne ':';
2592   }
2593 }
2594
2595
2596 sub ACTION_testpod {
2597   my $self = shift;
2598   $self->depends_on('docs');
2599
2600   eval q{use Test::Pod 0.95; 1}
2601     or die "The 'testpod' action requires Test::Pod version 0.95";
2602
2603   my @files = sort keys %{$self->_find_pods($self->libdoc_dirs)},
2604                    keys %{$self->_find_pods
2605                              ($self->bindoc_dirs,
2606                               exclude => [ file_qr('\.bat$') ])}
2607     or die "Couldn't find any POD files to test\n";
2608
2609   { package Module::Build::PodTester;  # Don't want to pollute the main namespace
2610     Test::Pod->import( tests => scalar @files );
2611     pod_file_ok($_) foreach @files;
2612   }
2613 }
2614
2615 sub ACTION_testpodcoverage {
2616   my $self = shift;
2617
2618   $self->depends_on('docs');
2619
2620   eval q{use Test::Pod::Coverage 1.00; 1}
2621     or die "The 'testpodcoverage' action requires ",
2622            "Test::Pod::Coverage version 1.00";
2623
2624   # TODO this needs test coverage!
2625
2626   # XXX work-around a bug in Test::Pod::Coverage previous to v1.09
2627   # Make sure we test the module in blib/
2628   local @INC = @INC;
2629   my $p = $self->{properties};
2630   unshift(@INC,
2631     # XXX any reason to include arch?
2632     File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
2633     #File::Spec->catdir($p->{base_dir}, $self->blib, 'arch')
2634   );
2635
2636   all_pod_coverage_ok();
2637 }
2638
2639 sub ACTION_docs {
2640   my $self = shift;
2641
2642   $self->depends_on('code');
2643   $self->depends_on('manpages', 'html');
2644 }
2645
2646 # Given a file type, will return true if the file type would normally
2647 # be installed when neither install-base nor prefix has been set.
2648 # I.e. it will be true only if the path is set from Config.pm or
2649 # set explicitly by the user via install-path.
2650 sub _is_default_installable {
2651   my $self = shift;
2652   my $type = shift;
2653   return ( $self->install_destination($type) &&
2654            ( $self->install_path($type) ||
2655              $self->install_sets($self->installdirs)->{$type} )
2656          ) ? 1 : 0;
2657 }
2658
2659 sub ACTION_manpages {
2660   my $self = shift;
2661
2662   return unless $self->_mb_feature('manpage_support');
2663
2664   $self->depends_on('code');
2665
2666   foreach my $type ( qw(bin lib) ) {
2667     my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
2668                                    exclude => [ file_qr('\.bat$') ] );
2669     next unless %$files;
2670
2671     my $sub = $self->can("manify_${type}_pods");
2672     next unless defined( $sub );
2673
2674     if ( $self->invoked_action eq 'manpages' ) {
2675       $self->$sub();
2676     } elsif ( $self->_is_default_installable("${type}doc") ) {
2677       $self->$sub();
2678     }
2679   }
2680
2681 }
2682
2683 sub manify_bin_pods {
2684   my $self    = shift;
2685
2686   my $files   = $self->_find_pods( $self->{properties}{bindoc_dirs},
2687                                    exclude => [ file_qr('\.bat$') ] );
2688   return unless keys %$files;
2689
2690   my $mandir = File::Spec->catdir( $self->blib, 'bindoc' );
2691   File::Path::mkpath( $mandir, 0, oct(777) );
2692
2693   require Pod::Man;
2694   foreach my $file (keys %$files) {
2695     # Pod::Simple based parsers only support one document per instance.
2696     # This is expected to change in a future version (Pod::Simple > 3.03).
2697     my $parser  = Pod::Man->new( section => 1 ); # binaries go in section 1
2698     my $manpage = $self->man1page_name( $file ) . '.' .
2699                   $self->config( 'man1ext' );
2700     my $outfile = File::Spec->catfile($mandir, $manpage);
2701     next if $self->up_to_date( $file, $outfile );
2702     $self->log_info("Manifying $file -> $outfile\n");
2703     $parser->parse_from_file( $file, $outfile );
2704     $files->{$file} = $outfile;
2705   }
2706 }
2707
2708 sub manify_lib_pods {
2709   my $self    = shift;
2710
2711   my $files   = $self->_find_pods($self->{properties}{libdoc_dirs});
2712   return unless keys %$files;
2713
2714   my $mandir = File::Spec->catdir( $self->blib, 'libdoc' );
2715   File::Path::mkpath( $mandir, 0, oct(777) );
2716
2717   require Pod::Man;
2718   while (my ($file, $relfile) = each %$files) {
2719     # Pod::Simple based parsers only support one document per instance.
2720     # This is expected to change in a future version (Pod::Simple > 3.03).
2721     my $parser  = Pod::Man->new( section => 3 ); # libraries go in section 3
2722     my $manpage = $self->man3page_name( $relfile ) . '.' .
2723                   $self->config( 'man3ext' );
2724     my $outfile = File::Spec->catfile( $mandir, $manpage);
2725     next if $self->up_to_date( $file, $outfile );
2726     $self->log_info("Manifying $file -> $outfile\n");
2727     $parser->parse_from_file( $file, $outfile );
2728     $files->{$file} = $outfile;
2729   }
2730 }
2731
2732 sub _find_pods {
2733   my ($self, $dirs, %args) = @_;
2734   my %files;
2735   foreach my $spec (@$dirs) {
2736     my $dir = $self->localize_dir_path($spec);
2737     next unless -e $dir;
2738
2739     FILE: foreach my $file ( @{ $self->rscan_dir( $dir ) } ) {
2740       foreach my $regexp ( @{ $args{exclude} } ) {
2741         next FILE if $file =~ $regexp;
2742       }
2743       $files{$file} = File::Spec->abs2rel($file, $dir) if $self->contains_pod( $file )
2744     }
2745   }
2746   return \%files;
2747 }
2748
2749 sub contains_pod {
2750   my ($self, $file) = @_;
2751   return '' unless -T $file;  # Only look at text files
2752
2753   my $fh = IO::File->new( $file ) or die "Can't open $file: $!";
2754   while (my $line = <$fh>) {
2755     return 1 if $line =~ /^\=(?:head|pod|item)/;
2756   }
2757
2758   return '';
2759 }
2760
2761 sub ACTION_html {
2762   my $self = shift;
2763
2764   return unless $self->_mb_feature('HTML_support');
2765
2766   $self->depends_on('code');
2767
2768   foreach my $type ( qw(bin lib) ) {
2769     my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
2770                                    exclude =>
2771                                         [ file_qr('\.(?:bat|com|html)$') ] );
2772     next unless %$files;
2773
2774     if ( $self->invoked_action eq 'html' ) {
2775       $self->htmlify_pods( $type );
2776     } elsif ( $self->_is_default_installable("${type}html") ) {
2777       $self->htmlify_pods( $type );
2778     }
2779   }
2780
2781 }
2782
2783
2784 # 1) If it's an ActiveState perl install, we need to run
2785 #    ActivePerl::DocTools->UpdateTOC;
2786 # 2) Links to other modules are not being generated
2787 sub htmlify_pods {
2788   my $self = shift;
2789   my $type = shift;
2790   my $htmldir = shift || File::Spec->catdir($self->blib, "${type}html");
2791
2792   require Module::Build::PodParser;
2793   require Pod::Html;
2794
2795   $self->add_to_cleanup('pod2htm*');
2796
2797   my $pods = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
2798                                 exclude => [ file_qr('\.(?:bat|com|html)$') ] );
2799   return unless %$pods;  # nothing to do
2800
2801   unless ( -d $htmldir ) {
2802     File::Path::mkpath($htmldir, 0, oct(755))
2803       or die "Couldn't mkdir $htmldir: $!";
2804   }
2805
2806   my @rootdirs = ($type eq 'bin') ? qw(bin) :
2807       $self->installdirs eq 'core' ? qw(lib) : qw(site lib);
2808
2809   my $podpath = join ':',
2810                 map  $_->[1],
2811                 grep -e $_->[0],
2812                 map  [File::Spec->catdir($self->blib, $_), $_],
2813                 qw( script lib );
2814
2815   foreach my $pod ( keys %$pods ) {
2816
2817     my ($name, $path) = File::Basename::fileparse($pods->{$pod},
2818                                                  file_qr('\.(?:pm|plx?|pod)$'));
2819     my @dirs = File::Spec->splitdir( File::Spec->canonpath( $path ) );
2820     pop( @dirs ) if $dirs[-1] eq File::Spec->curdir;
2821
2822     my $fulldir = File::Spec->catfile($htmldir, @rootdirs, @dirs);
2823     my $outfile = File::Spec->catfile($fulldir, "${name}.html");
2824     my $infile  = File::Spec->abs2rel($pod);
2825
2826     next if $self->up_to_date($infile, $outfile);
2827
2828     unless ( -d $fulldir ){
2829       File::Path::mkpath($fulldir, 0, oct(755))
2830         or die "Couldn't mkdir $fulldir: $!";
2831     }
2832
2833     my $path2root = join( '/', ('..') x (@rootdirs+@dirs) );
2834     my $htmlroot = join( '/',
2835                          ($path2root,
2836                           $self->installdirs eq 'core' ? () : qw(site) ) );
2837
2838     my $fh = IO::File->new($infile) or die "Can't read $infile: $!";
2839     my $abstract = Module::Build::PodParser->new(fh => $fh)->get_abstract();
2840
2841     my $title = join( '::', (@dirs, $name) );
2842     $title .= " - $abstract" if $abstract;
2843
2844     my @opts = (
2845                 '--flush',
2846                 "--title=$title",
2847                 "--podpath=$podpath",
2848                 "--infile=$infile",
2849                 "--outfile=$outfile",
2850                 '--podroot=' . $self->blib,
2851                 "--htmlroot=$htmlroot",
2852                );
2853
2854     if ( eval{Pod::Html->VERSION(1.03)} ) {
2855       push( @opts, ('--header', '--backlink=Back to Top') );
2856       push( @opts, "--css=$path2root/" . $self->html_css) if $self->html_css;
2857     }
2858
2859     $self->log_info("HTMLifying $infile -> $outfile\n");
2860     $self->log_verbose("pod2html @opts\n");
2861     Pod::Html::pod2html(@opts); # or warn "pod2html @opts failed: $!";
2862   }
2863
2864 }
2865
2866 # Adapted from ExtUtils::MM_Unix
2867 sub man1page_name {
2868   my $self = shift;
2869   return File::Basename::basename( shift );
2870 }
2871
2872 # Adapted from ExtUtils::MM_Unix and Pod::Man
2873 # Depending on M::B's dependency policy, it might make more sense to refactor
2874 # Pod::Man::begin_pod() to extract a name() methods, and use them...
2875 #    -spurkis
2876 sub man3page_name {
2877   my $self = shift;
2878   my ($vol, $dirs, $file) = File::Spec->splitpath( shift );
2879   my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) );
2880
2881   # Remove known exts from the base name
2882   $file =~ s/\.p(?:od|m|l)\z//i;
2883
2884   return join( $self->manpage_separator, @dirs, $file );
2885 }
2886
2887 sub manpage_separator {
2888   return '::';
2889 }
2890
2891 # For systems that don't have 'diff' executable, should use Algorithm::Diff
2892 sub ACTION_diff {
2893   my $self = shift;
2894   $self->depends_on('build');
2895   my $local_lib = File::Spec->rel2abs('lib');
2896   my @myINC = grep {$_ ne $local_lib} @INC;
2897
2898   # The actual install destination might not be in @INC, so check there too.
2899   push @myINC, map $self->install_destination($_), qw(lib arch);
2900
2901   my @flags = @{$self->{args}{ARGV}};
2902   @flags = $self->split_like_shell($self->{args}{flags} || '') unless @flags;
2903
2904   my $installmap = $self->install_map;
2905   delete $installmap->{read};
2906   delete $installmap->{write};
2907
2908   my $text_suffix = file_qr('\.(pm|pod)$');
2909
2910   while (my $localdir = each %$installmap) {
2911     my @localparts = File::Spec->splitdir($localdir);
2912     my $files = $self->rscan_dir($localdir, sub {-f});
2913
2914     foreach my $file (@$files) {
2915       my @parts = File::Spec->splitdir($file);
2916       @parts = @parts[@localparts .. $#parts]; # Get rid of blib/lib or similar
2917
2918       my $installed = Module::Build::ModuleInfo->find_module_by_name(
2919                         join('::', @parts), \@myINC );
2920       if (not $installed) {
2921         print "Only in lib: $file\n";
2922         next;
2923       }
2924
2925       my $status = File::Compare::compare($installed, $file);
2926       next if $status == 0;  # Files are the same
2927       die "Can't compare $installed and $file: $!" if $status == -1;
2928
2929       if ($file =~ $text_suffix) {
2930         $self->do_system('diff', @flags, $installed, $file);
2931       } else {
2932         print "Binary files $file and $installed differ\n";
2933       }
2934     }
2935   }
2936 }
2937
2938 sub ACTION_pure_install {
2939   shift()->depends_on('install');
2940 }
2941
2942 sub ACTION_install {
2943   my ($self) = @_;
2944   require ExtUtils::Install;
2945   $self->depends_on('build');
2946   ExtUtils::Install::install($self->install_map, !$self->quiet, 0, $self->{args}{uninst}||0);
2947 }
2948
2949 sub ACTION_fakeinstall {
2950   my ($self) = @_;
2951   require ExtUtils::Install;
2952   $self->depends_on('build');
2953   ExtUtils::Install::install($self->install_map, !$self->quiet, 1, $self->{args}{uninst}||0);
2954 }
2955
2956 sub ACTION_versioninstall {
2957   my ($self) = @_;
2958
2959   die "You must have only.pm 0.25 or greater installed for this operation: $@\n"
2960     unless eval { require only; 'only'->VERSION(0.25); 1 };
2961
2962   $self->depends_on('build');
2963
2964   my %onlyargs = map {exists($self->{args}{$_}) ? ($_ => $self->{args}{$_}) : ()}
2965     qw(version versionlib);
2966   only::install::install(%onlyargs);
2967 }
2968
2969 sub ACTION_clean {
2970   my ($self) = @_;
2971   foreach my $item (map glob($_), $self->cleanup) {
2972     $self->delete_filetree($item);
2973   }
2974 }
2975
2976 sub ACTION_realclean {
2977   my ($self) = @_;
2978   $self->depends_on('clean');
2979   $self->delete_filetree($self->config_dir, $self->build_script);
2980 }
2981
2982 sub ACTION_ppd {
2983   my ($self) = @_;
2984   require Module::Build::PPMMaker;
2985   my $ppd = Module::Build::PPMMaker->new();
2986   my $file = $ppd->make_ppd(%{$self->{args}}, build => $self);
2987   $self->add_to_cleanup($file);
2988 }
2989
2990 sub ACTION_ppmdist {
2991   my ($self) = @_;
2992
2993   $self->depends_on( 'build' );
2994
2995   my $ppm = $self->ppm_name;
2996   $self->delete_filetree( $ppm );
2997   $self->log_info( "Creating $ppm\n" );
2998   $self->add_to_cleanup( $ppm, "$ppm.tar.gz" );
2999
3000   my %types = ( # translate types/dirs to those expected by ppm
3001     lib     => 'lib',
3002     arch    => 'arch',
3003     bin     => 'bin',
3004     script  => 'script',
3005     bindoc  => 'man1',
3006     libdoc  => 'man3',
3007     binhtml => undef,
3008     libhtml => undef,
3009   );
3010
3011   foreach my $type ($self->install_types) {
3012     next if exists( $types{$type} ) && !defined( $types{$type} );
3013
3014     my $dir = File::Spec->catdir( $self->blib, $type );
3015     next unless -e $dir;
3016
3017     my $files = $self->rscan_dir( $dir );
3018     foreach my $file ( @$files ) {
3019       next unless -f $file;
3020       my $rel_file =
3021         File::Spec->abs2rel( File::Spec->rel2abs( $file ),
3022                              File::Spec->rel2abs( $dir  ) );
3023       my $to_file  =
3024         File::Spec->catfile( $ppm, 'blib',
3025                             exists( $types{$type} ) ? $types{$type} : $type,
3026                             $rel_file );
3027       $self->copy_if_modified( from => $file, to => $to_file );
3028     }
3029   }
3030
3031   foreach my $type ( qw(bin lib) ) {
3032     local $self->{properties}{html_css} = 'Active.css';
3033     $self->htmlify_pods( $type, File::Spec->catdir($ppm, 'blib', 'html') );
3034   }
3035
3036   # create a tarball;
3037   # the directory tar'ed must be blib so we need to do a chdir first
3038   my $target = File::Spec->catfile( File::Spec->updir, $ppm );
3039   $self->_do_in_dir( $ppm, sub { $self->make_tarball( 'blib', $target ) } );
3040
3041   $self->depends_on( 'ppd' );
3042
3043   $self->delete_filetree( $ppm );
3044 }
3045
3046 sub ACTION_pardist {
3047   my ($self) = @_;
3048
3049   # Need PAR::Dist
3050   if ( not eval { require PAR::Dist; PAR::Dist->VERSION(0.17) } ) {
3051     $self->log_warn(
3052       "In order to create .par distributions, you need to\n"
3053       . "install PAR::Dist first."
3054     );
3055     return();
3056   }
3057
3058   $self->depends_on( 'build' );
3059
3060   return PAR::Dist::blib_to_par(
3061     name => $self->dist_name,
3062     version => $self->dist_version,
3063   );
3064 }
3065
3066 sub ACTION_dist {
3067   my ($self) = @_;
3068
3069   $self->depends_on('distdir');
3070
3071   my $dist_dir = $self->dist_dir;
3072
3073   $self->make_tarball($dist_dir);
3074   $self->delete_filetree($dist_dir);
3075 }
3076
3077 sub ACTION_distcheck {
3078   my ($self) = @_;
3079
3080   require ExtUtils::Manifest;
3081   local $^W; # ExtUtils::Manifest is not warnings clean.
3082   my ($missing, $extra) = ExtUtils::Manifest::fullcheck();
3083
3084   return unless @$missing || @$extra;
3085
3086   my $msg = "MANIFEST appears to be out of sync with the distribution\n";
3087   if ( $self->invoked_action eq 'distcheck' ) {
3088     die $msg;
3089   } else {
3090     warn $msg;
3091   }
3092 }
3093
3094 sub _add_to_manifest {
3095   my ($self, $manifest, $lines) = @_;
3096   $lines = [$lines] unless ref $lines;
3097
3098   my $existing_files = $self->_read_manifest($manifest);
3099   return unless defined( $existing_files );
3100
3101   @$lines = grep {!exists $existing_files->{$_}} @$lines
3102     or return;
3103
3104   my $mode = (stat $manifest)[2];
3105   chmod($mode | oct(222), $manifest) or die "Can't make $manifest writable: $!";
3106
3107   my $fh = IO::File->new("< $manifest") or die "Can't read $manifest: $!";
3108   my $last_line = (<$fh>)[-1] || "\n";
3109   my $has_newline = $last_line =~ /\n$/;
3110   $fh->close;
3111
3112   $fh = IO::File->new(">> $manifest") or die "Can't write to $manifest: $!";
3113   print $fh "\n" unless $has_newline;
3114   print $fh map "$_\n", @$lines;
3115   close $fh;
3116   chmod($mode, $manifest);
3117
3118   $self->log_info(map "Added to $manifest: $_\n", @$lines);
3119 }
3120
3121 sub _sign_dir {
3122   my ($self, $dir) = @_;
3123
3124   unless (eval { require Module::Signature; 1 }) {
3125     $self->log_warn("Couldn't load Module::Signature for 'distsign' action:\n $@\n");
3126     return;
3127   }
3128
3129   # Add SIGNATURE to the MANIFEST
3130   {
3131     my $manifest = File::Spec->catfile($dir, 'MANIFEST');
3132     die "Signing a distribution requires a MANIFEST file" unless -e $manifest;
3133     $self->_add_to_manifest($manifest, "SIGNATURE    Added here by Module::Build");
3134   }
3135
3136   # Would be nice if Module::Signature took a directory argument.
3137
3138   $self->_do_in_dir($dir, sub {local $Module::Signature::Quiet = 1; Module::Signature::sign()});
3139 }
3140
3141 sub _do_in_dir {
3142   my ($self, $dir, $do) = @_;
3143
3144   my $start_dir = $self->cwd;
3145   chdir $dir or die "Can't chdir() to $dir: $!";
3146   eval {$do->()};
3147   my @err = $@ ? ($@) : ();
3148   chdir $start_dir or push @err, "Can't chdir() back to $start_dir: $!";
3149   die join "\n", @err if @err;
3150 }
3151
3152 sub ACTION_distsign {
3153   my ($self) = @_;
3154   {
3155     local $self->{properties}{sign} = 0;  # We'll sign it ourselves
3156     $self->depends_on('distdir') unless -d $self->dist_dir;
3157   }
3158   $self->_sign_dir($self->dist_dir);
3159 }
3160
3161 sub ACTION_skipcheck {
3162   my ($self) = @_;
3163
3164   require ExtUtils::Manifest;
3165   local $^W; # ExtUtils::Manifest is not warnings clean.
3166   ExtUtils::Manifest::skipcheck();
3167 }
3168
3169 sub ACTION_distclean {
3170   my ($self) = @_;
3171
3172   $self->depends_on('realclean');
3173   $self->depends_on('distcheck');
3174 }
3175
3176 sub do_create_makefile_pl {
3177   my $self = shift;
3178   require Module::Build::Compat;
3179   $self->log_info("Creating Makefile.PL\n");
3180   Module::Build::Compat->create_makefile_pl($self->create_makefile_pl, $self, @_);
3181   $self->_add_to_manifest('MANIFEST', 'Makefile.PL');
3182 }
3183
3184 sub do_create_license {
3185   my $self = shift;
3186   $self->log_info("Creating LICENSE file");
3187
3188   my $l = $self->license
3189     or die "No license specified";
3190
3191   my $key = $self->valid_licenses->{$l}
3192     or die "'$l' isn't a license key we know about";
3193   my $class = "Software::License::$key";
3194
3195   eval "use $class; 1"
3196     or die "Can't load Software::License to create LICENSE file: $@";
3197
3198   $self->delete_filetree('LICENSE');
3199
3200   my $author = join " & ", @{ $self->dist_author };
3201   my $license = $class->new({holder => $author});
3202   my $fh = IO::File->new('> LICENSE')
3203     or die "Can't write LICENSE file: $!";
3204   print $fh $license->fulltext;
3205   close $fh;
3206
3207   $self->_add_to_manifest('MANIFEST', 'LICENSE');
3208 }
3209
3210 sub do_create_readme {
3211   my $self = shift;
3212   $self->delete_filetree('README');
3213
3214   my $docfile = $self->_main_docfile;
3215   unless ( $docfile ) {
3216     $self->log_warn(<<EOF);
3217 Cannot create README: can't determine which file contains documentation;
3218 Must supply either 'dist_version_from', or 'module_name' parameter.
3219 EOF
3220     return;
3221   }
3222
3223   if ( eval {require Pod::Readme; 1} ) {
3224     $self->log_info("Creating README using Pod::Readme\n");
3225
3226     my $parser = Pod::Readme->new;
3227     $parser->parse_from_file($docfile, 'README', @_);
3228
3229   } elsif ( eval {require Pod::Text; 1} ) {
3230     $self->log_info("Creating README using Pod::Text\n");
3231
3232     my $fh = IO::File->new('> README');
3233     if ( defined($fh) ) {
3234       local $^W = 0;
3235       no strict "refs";
3236
3237       # work around bug in Pod::Text 3.01, which expects
3238       # Pod::Simple::parse_file to take input and output filehandles
3239       # when it actually only takes an input filehandle
3240
3241       my $old_parse_file;
3242       $old_parse_file = \&{"Pod::Simple::parse_file"}
3243         and
3244       local *{"Pod::Simple::parse_file"} = sub {
3245         my $self = shift;
3246         $self->output_fh($_[1]) if $_[1];
3247         $self->$old_parse_file($_[0]);
3248       }
3249         if $Pod::Text::VERSION
3250           == 3.01; # Split line to avoid evil version-finder
3251
3252       Pod::Text::pod2text( $docfile, $fh );
3253
3254       $fh->close;
3255     } else {
3256       $self->log_warn(
3257         "Cannot create 'README' file: Can't open file for writing\n" );
3258       return;
3259     }
3260
3261   } else {
3262     $self->log_warn("Can't load Pod::Readme or Pod::Text to create README\n");
3263     return;
3264   }
3265
3266   $self->_add_to_manifest('MANIFEST', 'README');
3267 }
3268
3269 sub _main_docfile {
3270   my $self = shift;
3271   if ( my $pm_file = $self->dist_version_from ) {
3272     (my $pod_file = $pm_file) =~ s/.pm$/.pod/;
3273     return (-e $pod_file ? $pod_file : $pm_file);
3274   } else {
3275     return undef;
3276   }
3277 }
3278
3279 sub ACTION_distdir {
3280   my ($self) = @_;
3281
3282   $self->depends_on('distmeta');
3283
3284   my $dist_files = $self->_read_manifest('MANIFEST')
3285     or die "Can't create distdir without a MANIFEST file - run 'manifest' action first";
3286   delete $dist_files->{SIGNATURE};  # Don't copy, create a fresh one
3287   die "No files found in MANIFEST - try running 'manifest' action?\n"
3288     unless ($dist_files and keys %$dist_files);
3289   my $metafile = $self->metafile;
3290   $self->log_warn("*** Did you forget to add $metafile to the MANIFEST?\n")
3291     unless exists $dist_files->{$metafile};
3292
3293   my $dist_dir = $self->dist_dir;
3294   $self->delete_filetree($dist_dir);
3295   $self->log_info("Creating $dist_dir\n");
3296   $self->add_to_cleanup($dist_dir);
3297
3298   foreach my $file (keys %$dist_files) {
3299     my $new = $self->copy_if_modified(from => $file, to_dir => $dist_dir, verbose => 0);
3300   }
3301
3302   $self->_sign_dir($dist_dir) if $self->{properties}{sign};
3303 }
3304
3305 sub ACTION_disttest {
3306   my ($self) = @_;
3307
3308   $self->depends_on('distdir');
3309
3310   $self->_do_in_dir
3311     ( $self->dist_dir,
3312       sub {
3313         # XXX could be different names for scripts
3314
3315         $self->run_perl_script('Build.PL') # XXX Should this be run w/ --nouse-rcfile
3316           or die "Error executing 'Build.PL' in dist directory: $!";
3317         $self->run_perl_script('Build')
3318           or die "Error executing 'Build' in dist directory: $!";
3319         $self->run_perl_script('Build', [], ['test'])
3320           or die "Error executing 'Build test' in dist directory";
3321       });
3322 }
3323
3324 sub _write_default_maniskip {
3325   my $self = shift;
3326   my $file = shift || 'MANIFEST.SKIP';
3327   my $fh = IO::File->new("> $file")
3328     or die "Can't open $file: $!";
3329
3330   # This is derived from MakeMaker's default MANIFEST.SKIP file with
3331   # some new entries
3332
3333   print $fh <<'EOF';
3334 # Avoid version control files.
3335 \bRCS\b
3336 \bCVS\b
3337 ,v$
3338 \B\.svn\b
3339 \B\.cvsignore$
3340
3341 # Avoid Makemaker generated and utility files.
3342 \bMakefile$
3343 \bblib
3344 \bMakeMaker-\d
3345 \bpm_to_blib$
3346 \bblibdirs$
3347 ^MANIFEST\.SKIP$
3348
3349 # Avoid VMS specific Makmaker generated files
3350 \bDescrip.MMS$
3351 \bDESCRIP.MMS$
3352 \bdescrip.mms$
3353
3354 # Avoid Module::Build generated and utility files.
3355 \bBuild$
3356 \bBuild.bat$
3357 \b_build
3358 \bBuild.COM$
3359 \bBUILD.COM$
3360 \bbuild.com$
3361
3362 # Avoid Devel::Cover generated files
3363 \bcover_db
3364
3365 # Avoid temp and backup files.
3366 ~$
3367 \.tmp$
3368 \.old$
3369 \.bak$
3370 \#$
3371 \.#
3372 \.rej$
3373
3374 # Avoid OS-specific files/dirs
3375 #   Mac OSX metadata
3376 \B\.DS_Store
3377 #   Mac OSX SMB mount metadata files
3378 \B\._
3379 # Avoid archives of this distribution
3380 EOF
3381
3382   # Skip, for example, 'Module-Build-0.27.tar.gz'
3383   print $fh '\b'.$self->dist_name.'-[\d\.\_]+'."\n";
3384
3385   $fh->close();
3386 }
3387
3388 sub ACTION_manifest {
3389   my ($self) = @_;
3390
3391   my $maniskip = 'MANIFEST.SKIP';
3392   unless ( -e 'MANIFEST' || -e $maniskip ) {
3393     $self->log_warn("File '$maniskip' does not exist: Creating a default '$maniskip'\n");
3394     $self->_write_default_maniskip($maniskip);
3395   }
3396
3397   require ExtUtils::Manifest;  # ExtUtils::Manifest is not warnings clean.
3398   local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
3399   ExtUtils::Manifest::mkmanifest();
3400 }
3401
3402 # Case insenstive regex for files
3403 sub file_qr {
3404     return File::Spec->case_tolerant ? qr($_[0])i : qr($_[0]);
3405 }
3406
3407 sub dist_dir {
3408   my ($self) = @_;
3409   return "$self->{properties}{dist_name}-$self->{properties}{dist_version}";
3410 }
3411
3412 sub ppm_name {
3413   my $self = shift;
3414   return 'PPM-' . $self->dist_dir;
3415 }
3416
3417 sub _files_in {
3418   my ($self, $dir) = @_;
3419   return unless -d $dir;
3420
3421   local *DH;
3422   opendir DH, $dir or die "Can't read directory $dir: $!";
3423
3424   my @files;
3425   while (defined (my $file = readdir DH)) {
3426     my $full_path = File::Spec->catfile($dir, $file);
3427     next if -d $full_path;
3428     push @files, $full_path;
3429   }
3430   return @files;
3431 }
3432
3433 sub script_files {
3434   my $self = shift;
3435
3436   for ($self->{properties}{script_files}) {
3437     $_ = shift if @_;
3438     next unless $_;
3439
3440     # Always coerce into a hash
3441     return $_ if UNIVERSAL::isa($_, 'HASH');
3442     return $_ = { map {$_,1} @$_ } if UNIVERSAL::isa($_, 'ARRAY');
3443
3444     die "'script_files' must be a hashref, arrayref, or string" if ref();
3445
3446     return $_ = { map {$_,1} $self->_files_in( $_ ) } if -d $_;
3447     return $_ = {$_ => 1};
3448   }
3449
3450   return $_ = { map {$_,1} $self->_files_in('bin') };
3451 }
3452 BEGIN { *scripts = \&script_files; }
3453
3454 {
3455   my %licenses = (
3456     perl         => 'Perl_5',
3457     apache       => 'Apache_2_0',
3458     artistic     => 'Artistic_1_0',
3459     artistic_2   => 'Artistic_2_0',
3460     lgpl         => 'LGPL_2_1',
3461     lgpl2        => 'LGPL_2_1',
3462     lgpl3        => 'LGPL_3_0',
3463     bsd          => 'BSD',
3464     gpl          => 'GPL_1',
3465     gpl2         => 'GPL_2',
3466     gpl3         => 'GPL_3',
3467     mit          => 'MIT',
3468     mozilla      => 'Mozilla_1_1',
3469     open_source  => undef,
3470     unrestricted => undef,
3471     restrictive  => undef,
3472     unknown      => undef,
3473   );
3474
3475   # TODO - would be nice to not have these here, since they're more
3476   # properly stored only in Software::License
3477   my %license_urls = (
3478     perl         => 'http://dev.perl.org/licenses/',
3479     apache       => 'http://apache.org/licenses/LICENSE-2.0',
3480     artistic     => 'http://opensource.org/licenses/artistic-license.php',
3481     artistic_2   => 'http://opensource.org/licenses/artistic-license-2.0.php',
3482     lgpl         => 'http://opensource.org/licenses/lgpl-license.php',
3483     lgpl2        => 'http://opensource.org/licenses/lgpl-2.1.php',
3484     lgpl3        => 'http://opensource.org/licenses/lgpl-3.0.html',
3485     bsd          => 'http://opensource.org/licenses/bsd-license.php',
3486     gpl          => 'http://opensource.org/licenses/gpl-license.php',
3487     gpl2         => 'http://opensource.org/licenses/gpl-2.0.php',
3488     gpl3         => 'http://opensource.org/licenses/gpl-3.0.html',
3489     mit          => 'http://opensource.org/licenses/mit-license.php',
3490     mozilla      => 'http://opensource.org/licenses/mozilla1.1.php',
3491     open_source  => undef,
3492     unrestricted => undef,
3493     restrictive  => undef,
3494     unknown      => undef,
3495   );
3496   sub valid_licenses {
3497     return \%licenses;
3498   }
3499   sub _license_url {
3500     return $license_urls{$_[1]};
3501   }
3502 }
3503
3504 sub _hash_merge {
3505   my ($self, $h, $k, $v) = @_;
3506   if (ref $h->{$k} eq 'ARRAY') {
3507     push @{$h->{$k}}, ref $v ? @$v : $v;
3508   } elsif (ref $h->{$k} eq 'HASH') {
3509     $h->{$k}{$_} = $v->{$_} foreach keys %$v;
3510   } else {
3511     $h->{$k} = $v;
3512   }
3513 }
3514
3515 sub ACTION_distmeta {
3516   my ($self) = @_;
3517
3518   $self->do_create_makefile_pl if $self->create_makefile_pl;
3519   $self->do_create_readme if $self->create_readme;
3520   $self->do_create_license if $self->create_license;
3521   $self->do_create_metafile;
3522 }
3523
3524 sub do_create_metafile {
3525   my $self = shift;
3526   return if $self->{wrote_metadata};
3527
3528   my $p = $self->{properties};
3529   my $metafile = $self->metafile;
3530
3531   unless ($p->{license}) {
3532     $self->log_warn("No license specified, setting license = 'unknown'\n");
3533     $p->{license} = 'unknown';
3534   }
3535   unless (exists $self->valid_licenses->{ $p->{license} }) {
3536     die "Unknown license type '$p->{license}'";
3537   }
3538
3539   # If we're in the distdir, the metafile may exist and be non-writable.
3540   $self->delete_filetree($metafile);
3541   $self->log_info("Creating $metafile\n");
3542
3543   # Since we're building ourself, we have to do some special stuff
3544   # here: the ConfigData module is found in blib/lib.
3545   local @INC = @INC;
3546   if (($self->module_name || '') eq 'Module::Build') {
3547     $self->depends_on('config_data');
3548     push @INC, File::Spec->catdir($self->blib, 'lib');
3549   }
3550
3551   $self->write_metafile;
3552 }
3553
3554 sub write_metafile {
3555   my $self = shift;
3556   my $metafile = $self->metafile;
3557
3558   if ($self->_mb_feature('YAML_support')) {
3559     require YAML;
3560     require YAML::Node;
3561
3562     # We use YAML::Node to get the order nice in the YAML file.
3563     $self->prepare_metadata( my $node = YAML::Node->new({}) );
3564
3565     # YAML API changed after version 0.30
3566     my $yaml_sub = $YAML::VERSION le '0.30' ? \&YAML::StoreFile : \&YAML::DumpFile;
3567     $self->{wrote_metadata} = $yaml_sub->($metafile, $node );
3568
3569   } else {
3570     require Module::Build::YAML;
3571     my (%node, @order_keys);
3572     $self->prepare_metadata(\%node, \@order_keys);
3573     $node{_order} = \@order_keys;
3574     &Module::Build::YAML::DumpFile($metafile, \%node);
3575     $self->{wrote_metadata} = 1;
3576   }
3577
3578   $self->_add_to_manifest('MANIFEST', $metafile);
3579 }
3580
3581 sub prepare_metadata {
3582   my ($self, $node, $keys) = @_;
3583   my $p = $self->{properties};
3584
3585   # A little helper sub
3586   my $add_node = sub {
3587     my ($name, $val) = @_;
3588     $node->{$name} = $val;
3589     push @$keys, $name if $keys;
3590   };
3591
3592   foreach (qw(dist_name dist_version dist_author dist_abstract license)) {
3593     (my $name = $_) =~ s/^dist_//;
3594     $add_node->($name, $self->$_());
3595     die "ERROR: Missing required field '$_' for META.yml\n"
3596       unless defined($node->{$name}) && length($node->{$name});
3597   }
3598   $node->{version} = '' . $node->{version}; # Stringify version objects
3599
3600   if (defined( my $l = $self->license )) {
3601     die "Unknown license string '$l'"
3602       unless exists $self->valid_licenses->{ $self->license };
3603
3604     if (my $key = $self->valid_licenses->{ $self->license }) {
3605       my $class = "Software::License::$key";
3606       if (eval "use $class; 1") {
3607         # S::L requires a 'holder' key
3608         $node->{resources}{license} = $class->new({holder=>"nobody"})->url;
3609       } else {
3610         $node->{resources}{license} = $self->_license_url($key);
3611       }
3612     }
3613   }
3614
3615   if (exists $p->{configure_requires}) {
3616     foreach my $spec (keys %{$p->{configure_requires}}) {
3617       warn ("Warning: $spec is listed in 'configure_requires', but ".
3618             "it is not found in any of the other prereq fields.\n")
3619         unless grep exists $p->{$_}{$spec},
3620                grep !/conflicts$/, @{$self->prereq_action_types};
3621     }
3622   }
3623
3624   foreach ( 'configure_requires', @{$self->prereq_action_types} ) {
3625     if (exists $p->{$_} and keys %{ $p->{$_} }) {
3626       $add_node->($_, $p->{$_});
3627     }
3628   }
3629
3630   if (exists $p->{dynamic_config}) {
3631     $add_node->('dynamic_config', $p->{dynamic_config});
3632   }
3633   my $pkgs = eval { $self->find_dist_packages };
3634   if ($@) {
3635     $self->log_warn("$@\nWARNING: Possible missing or corrupt 'MANIFEST' file.\n" .
3636                     "Nothing to enter for 'provides' field in META.yml\n");
3637   } else {
3638     $node->{provides} = $pkgs if %$pkgs;
3639   }
3640 ;
3641   if (exists $p->{no_index}) {
3642     $add_node->('no_index', $p->{no_index});
3643   }
3644
3645   $add_node->('generated_by', "Module::Build version $Module::Build::VERSION");
3646
3647   $add_node->('meta-spec',
3648               {version => '1.2',
3649                url     => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
3650               });
3651
3652   while (my($k, $v) = each %{$self->meta_add}) {
3653     $add_node->($k, $v);
3654   }
3655
3656   while (my($k, $v) = each %{$self->meta_merge}) {
3657     $self->_hash_merge($node, $k, $v);
3658   }
3659
3660   return $node;
3661 }
3662
3663 sub _read_manifest {
3664   my ($self, $file) = @_;
3665   return undef unless -e $file;
3666
3667   require ExtUtils::Manifest;  # ExtUtils::Manifest is not warnings clean.
3668   local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
3669   return scalar ExtUtils::Manifest::maniread($file);
3670 }
3671
3672 sub find_dist_packages {
3673   my $self = shift;
3674
3675   # Only packages in .pm files are candidates for inclusion here.
3676   # Only include things in the MANIFEST, not things in developer's
3677   # private stock.
3678
3679   my $manifest = $self->_read_manifest('MANIFEST')
3680     or die "Can't find dist packages without a MANIFEST file - run 'manifest' action first";
3681
3682   # Localize
3683   my %dist_files = map { $self->localize_file_path($_) => $_ }
3684                        keys %$manifest;
3685
3686   my @pm_files = grep {exists $dist_files{$_}} keys %{ $self->find_pm_files };
3687
3688   # First, we enumerate all packages & versions,
3689   # seperating into primary & alternative candidates
3690   my( %prime, %alt );
3691   foreach my $file (@pm_files) {
3692     next if $dist_files{$file} =~ m{^t/};  # Skip things in t/
3693
3694     my @path = split( /\//, $dist_files{$file} );
3695     (my $prime_package = join( '::', @path[1..$#path] )) =~ s/\.pm$//;
3696
3697     my $pm_info = Module::Build::ModuleInfo->new_from_file( $file );
3698
3699     foreach my $package ( $pm_info->packages_inside ) {
3700       next if $package eq 'main';  # main can appear numerous times, ignore
3701       next if grep /^_/, split( /::/, $package ); # private package, ignore
3702
3703       my $version = $pm_info->version( $package );
3704
3705       if ( $package eq $prime_package ) {
3706         if ( exists( $prime{$package} ) ) {
3707           # M::B::ModuleInfo will handle this conflict
3708           die "Unexpected conflict in '$package'; multiple versions found.\n";
3709         } else {
3710           $prime{$package}{file} = $dist_files{$file};
3711           $prime{$package}{version} = $version if defined( $version );
3712         }
3713       } else {
3714         push( @{$alt{$package}}, {
3715                                   file    => $dist_files{$file},
3716                                   version => $version,
3717                                  } );
3718       }
3719     }
3720   }
3721
3722   # Then we iterate over all the packages found above, identifying conflicts
3723   # and selecting the "best" candidate for recording the file & version
3724   # for each package.
3725   foreach my $package ( keys( %alt ) ) {
3726     my $result = $self->_resolve_module_versions( $alt{$package} );
3727
3728     if ( exists( $prime{$package} ) ) { # primary package selected
3729
3730       if ( $result->{err} ) {
3731         # Use the selected primary package, but there are conflicting
3732         # errors amoung multiple alternative packages that need to be
3733         # reported
3734         $self->log_warn(
3735           "Found conflicting versions for package '$package'\n" .
3736           "  $prime{$package}{file} ($prime{$package}{version})\n" .
3737           $result->{err}
3738         );
3739
3740       } elsif ( defined( $result->{version} ) ) {
3741         # There is a primary package selected, and exactly one
3742         # alternative package
3743
3744         if ( exists( $prime{$package}{version} ) &&
3745              defined( $prime{$package}{version} ) ) {
3746           # Unless the version of the primary package agrees with the
3747           # version of the alternative package, report a conflict
3748           if ( $self->compare_versions( $prime{$package}{version}, '!=',
3749                                         $result->{version} ) ) {
3750             $self->log_warn(
3751               "Found conflicting versions for package '$package'\n" .
3752               "  $prime{$package}{file} ($prime{$package}{version})\n" .
3753               "  $result->{file} ($result->{version})\n"
3754             );
3755           }
3756
3757         } else {
3758           # The prime package selected has no version so, we choose to
3759           # use any alternative package that does have a version
3760           $prime{$package}{file}    = $result->{file};
3761           $prime{$package}{version} = $result->{version};
3762         }
3763
3764       } else {
3765         # no alt package found with a version, but we have a prime
3766         # package so we use it whether it has a version or not
3767       }
3768
3769     } else { # No primary package was selected, use the best alternative
3770
3771       if ( $result->{err} ) {
3772         $self->log_warn(
3773           "Found conflicting versions for package '$package'\n" .
3774           $result->{err}
3775         );
3776       }
3777
3778       # Despite possible conflicting versions, we choose to record
3779       # something rather than nothing
3780       $prime{$package}{file}    = $result->{file};
3781       $prime{$package}{version} = $result->{version}
3782           if defined( $result->{version} );
3783     }
3784   }
3785
3786   # Stringify versions.  Can't use exists() here because of bug in YAML::Node.
3787   for (grep defined $_->{version}, values %prime) {
3788     $_->{version} = '' . $_->{version};
3789   }
3790
3791   return \%prime;
3792 }
3793
3794 # seperate out some of the conflict resolution logic from
3795 # $self->find_dist_packages(), above, into a helper function.
3796 #
3797 sub _resolve_module_versions {
3798   my $self = shift;
3799
3800   my $packages = shift;
3801
3802   my( $file, $version );
3803   my $err = '';
3804     foreach my $p ( @$packages ) {
3805       if ( defined( $p->{version} ) ) {
3806         if ( defined( $version ) ) {
3807           if ( $self->compare_versions( $version, '!=', $p->{version} ) ) {
3808             $err .= "  $p->{file} ($p->{version})\n";
3809           } else {
3810             # same version declared multiple times, ignore
3811           }
3812         } else {
3813           $file    = $p->{file};
3814           $version = $p->{version};
3815         }
3816       }
3817       $file ||= $p->{file} if defined( $p->{file} );
3818     }
3819
3820   if ( $err ) {
3821     $err = "  $file ($version)\n" . $err;
3822   }
3823
3824   my %result = (
3825     file    => $file,
3826     version => $version,
3827     err     => $err
3828   );
3829
3830   return \%result;
3831 }
3832
3833 sub make_tarball {
3834   my ($self, $dir, $file) = @_;
3835   $file ||= $dir;
3836
3837   $self->log_info("Creating $file.tar.gz\n");
3838
3839   if ($self->{args}{tar}) {
3840     my $tar_flags = $self->verbose ? 'cvf' : 'cf';
3841     $self->do_system($self->split_like_shell($self->{args}{tar}), $tar_flags, "$file.tar", $dir);
3842     $self->do_system($self->split_like_shell($self->{args}{gzip}), "$file.tar") if $self->{args}{gzip};
3843   } else {
3844     require Archive::Tar;
3845
3846     # Archive::Tar versions >= 1.09 use the following to enable a compatibility
3847     # hack so that the resulting archive is compatible with older clients.
3848     $Archive::Tar::DO_NOT_USE_PREFIX = 0;
3849
3850     my $files = $self->rscan_dir($dir);
3851     my $tar   = Archive::Tar->new;
3852     $tar->add_files(@$files);
3853     for my $f ($tar->get_files) {
3854       $f->mode($f->mode & ~022); # chmod go-w
3855     }
3856     $tar->write("$file.tar.gz", 1);
3857   }
3858 }
3859
3860 sub install_path {
3861   my $self = shift;
3862   my( $type, $value ) = ( @_, '<empty>' );
3863
3864   Carp::croak( 'Type argument missing' )
3865     unless defined( $type );
3866
3867   my $map = $self->{properties}{install_path};
3868   return $map unless @_;
3869
3870   # delete existing value if $value is literal undef()
3871   unless ( defined( $value ) ) {
3872     delete( $map->{$type} );
3873     return undef;
3874   }
3875
3876   # return existing value if no new $value is given
3877   if ( $value eq '<empty>' ) {
3878     return undef unless exists $map->{$type};
3879     return $map->{$type};
3880   }
3881
3882   # set value if $value is a valid relative path
3883   return $map->{$type} = $value;
3884 }
3885
3886 sub install_base_relpaths {
3887   # Usage: install_base_relpaths(), install_base_relpaths('lib'),
3888   #   or install_base_relpaths('lib' => $value);
3889   my $self = shift;
3890   my $map = $self->{properties}{install_base_relpaths};
3891   return $map unless @_;
3892   return $self->_relpaths($map, @_);
3893 }
3894
3895
3896 # Translated from ExtUtils::MM_Any::init_INSTALL_from_PREFIX
3897 sub prefix_relative {
3898   my ($self, $type) = @_;
3899   my $installdirs = $self->installdirs;
3900
3901   my $relpath = $self->install_sets($installdirs)->{$type};
3902
3903   return $self->_prefixify($relpath,
3904                            $self->original_prefix($installdirs),
3905                            $type,
3906                           );
3907 }
3908
3909 sub _relpaths {
3910   my $self = shift;
3911   my( $map, $type, $value ) = ( @_, '<empty>' );
3912
3913   Carp::croak( 'Type argument missing' )
3914     unless defined( $type );
3915
3916   my @value = ();
3917
3918   # delete existing value if $value is literal undef()
3919   unless ( defined( $value ) ) {
3920     delete( $map->{$type} );
3921     return undef;
3922   }
3923
3924   # return existing value if no new $value is given
3925   elsif ( $value eq '<empty>' ) {
3926     return undef unless exists $map->{$type};
3927     @value = @{ $map->{$type} };
3928   }
3929
3930   # set value if $value is a valid relative path
3931   else {
3932     Carp::croak( "Value must be a relative path" )
3933       if File::Spec::Unix->file_name_is_absolute($value);
3934
3935     @value = split( /\//, $value );
3936     $map->{$type} = \@value;
3937   }
3938
3939   return File::Spec->catdir( @value );
3940 }
3941
3942 # Defaults to use in case the config install paths cannot be prefixified.
3943 sub prefix_relpaths {
3944   # Usage: prefix_relpaths('site'), prefix_relpaths('site', 'lib'),
3945   #   or prefix_relpaths('site', 'lib' => $value);
3946   my $self = shift;
3947   my $installdirs = shift || $self->installdirs;
3948   my $map = $self->{properties}{prefix_relpaths}{$installdirs};
3949   return $map unless @_;
3950   return $self->_relpaths($map, @_);
3951 }
3952
3953
3954 # Translated from ExtUtils::MM_Unix::prefixify()
3955 sub _prefixify {
3956   my($self, $path, $sprefix, $type) = @_;
3957
3958   my $rprefix = $self->prefix;
3959   $rprefix .= '/' if $sprefix =~ m|/$|;
3960
3961   $self->log_verbose("  prefixify $path from $sprefix to $rprefix\n")
3962     if defined( $path ) && length( $path );
3963
3964   if( !defined( $path ) || ( length( $path ) == 0 ) ) {
3965     $self->log_verbose("  no path to prefixify, falling back to default.\n");
3966     return $self->_prefixify_default( $type, $rprefix );
3967   } elsif( !File::Spec->file_name_is_absolute($path) ) {
3968     $self->log_verbose("    path is relative, not prefixifying.\n");
3969   } elsif( $sprefix eq $rprefix ) {
3970     $self->log_verbose("  no new prefix.\n");
3971   } elsif( $path !~ s{^\Q$sprefix\E\b}{}s ) {
3972     $self->log_verbose("    cannot prefixify, falling back to default.\n");
3973     return $self->_prefixify_default( $type, $rprefix );
3974   }
3975
3976   $self->log_verbose("    now $path in $rprefix\n");
3977
3978   return $path;
3979 }
3980
3981 sub _prefixify_default {
3982   my $self = shift;
3983   my $type = shift;
3984   my $rprefix = shift;
3985
3986   my $default = $self->prefix_relpaths($self->installdirs, $type);
3987   if( !$default ) {
3988     $self->log_verbose("    no default install location for type '$type', using prefix '$rprefix'.\n");
3989     return $rprefix;
3990   } else {
3991     return $default;
3992   }
3993 }
3994
3995 sub install_destination {
3996   my ($self, $type) = @_;
3997
3998   return $self->install_path($type) if $self->install_path($type);
3999
4000   if ( $self->install_base ) {
4001     my $relpath = $self->install_base_relpaths($type);
4002     return $relpath ? File::Spec->catdir($self->install_base, $relpath) : undef;
4003   }
4004
4005   if ( $self->prefix ) {
4006     my $relpath = $self->prefix_relative($type);
4007     return $relpath ? File::Spec->catdir($self->prefix, $relpath) : undef;
4008   }
4009
4010   return $self->install_sets($self->installdirs)->{$type};
4011 }
4012
4013 sub install_types {
4014   my $self = shift;
4015
4016   my %types;
4017   if ( $self->install_base ) {
4018     %types = %{$self->install_base_relpaths};
4019   } elsif ( $self->prefix ) {
4020     %types = %{$self->prefix_relpaths};
4021   } else {
4022     %types = %{$self->install_sets($self->installdirs)};
4023   }
4024
4025   %types = (%types, %{$self->install_path});
4026
4027   return sort keys %types;
4028 }
4029
4030 sub install_map {
4031   my ($self, $blib) = @_;
4032   $blib ||= $self->blib;
4033
4034   my( %map, @skipping );
4035   foreach my $type ($self->install_types) {
4036     my $localdir = File::Spec->catdir( $blib, $type );
4037     next unless -e $localdir;
4038
4039     if (my $dest = $self->install_destination($type)) {
4040       $map{$localdir} = $dest;
4041     } else {
4042       push( @skipping, $type );
4043     }
4044   }
4045
4046   $self->log_warn(
4047     "WARNING: Can't figure out install path for types: @skipping\n" .
4048     "Files will not be installed.\n"
4049   ) if @skipping;
4050
4051   # Write the packlist into the same place as ExtUtils::MakeMaker.
4052   if ($self->create_packlist and my $module_name = $self->module_name) {
4053     my $archdir = $self->install_destination('arch');
4054     my @ext = split /::/, $module_name;
4055     $map{write} = File::Spec->catfile($archdir, 'auto', @ext, '.packlist');
4056   }
4057
4058   # Handle destdir
4059   if (length(my $destdir = $self->destdir || '')) {
4060     foreach (keys %map) {
4061       # Need to remove volume from $map{$_} using splitpath, or else
4062       # we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
4063       # VMS will always have the file separate than the path.
4064       my ($volume, $path, $file) = File::Spec->splitpath( $map{$_}, 1 );
4065
4066       # catdir needs a list of directories, or it will create something
4067       # crazy like volume:[Foo.Bar.volume.Baz.Quux]
4068       my @dirs = File::Spec->splitdir($path);
4069
4070       # First merge the directories
4071       $path = File::Spec->catdir($destdir, @dirs);
4072
4073       # Then put the file back on if there is one.
4074       if ($file ne '') {
4075           $map{$_} = File::Spec->catfile($path, $file)
4076       } else {
4077           $map{$_} = $path;
4078       }
4079     }
4080   }
4081
4082   $map{read} = '';  # To keep ExtUtils::Install quiet
4083
4084   return \%map;
4085 }
4086
4087 sub depends_on {
4088   my $self = shift;
4089   foreach my $action (@_) {
4090     $self->_call_action($action);
4091   }
4092 }
4093
4094 sub rscan_dir {
4095   my ($self, $dir, $pattern) = @_;
4096   my @result;
4097   local $_; # find() can overwrite $_, so protect ourselves
4098   my $subr = !$pattern ? sub {push @result, $File::Find::name} :
4099              !ref($pattern) || (ref $pattern eq 'Regexp') ? sub {push @result, $File::Find::name if /$pattern/} :
4100              ref($pattern) eq 'CODE' ? sub {push @result, $File::Find::name if $pattern->()} :
4101              die "Unknown pattern type";
4102
4103   File::Find::find({wanted => $subr, no_chdir => 1}, $dir);
4104   return \@result;
4105 }
4106
4107 sub delete_filetree {
4108   my $self = shift;
4109   my $deleted = 0;
4110   foreach (@_) {
4111     next unless -e $_;
4112     $self->log_info("Deleting $_\n");
4113     File::Path::rmtree($_, 0, 0);
4114     die "Couldn't remove '$_': $!\n" if -e $_;
4115     $deleted++;
4116   }
4117   return $deleted;
4118 }
4119
4120 sub autosplit_file {
4121   my ($self, $file, $to) = @_;
4122   require AutoSplit;
4123   my $dir = File::Spec->catdir($to, 'lib', 'auto');
4124   AutoSplit::autosplit($file, $dir);
4125 }
4126
4127 sub cbuilder {
4128   # Returns a CBuilder object
4129
4130   my $self = shift;
4131   my $p = $self->{properties};
4132   return $p->{_cbuilder} if $p->{_cbuilder};
4133   die "Module::Build is not configured with C_support"
4134           unless $self->_mb_feature('C_support');
4135
4136   require ExtUtils::CBuilder;
4137   return $p->{_cbuilder} = ExtUtils::CBuilder->new(
4138     config => $self->config,
4139     ($self->quiet ? (quiet => 1 ) : ()),
4140   );
4141 }
4142
4143 sub have_c_compiler {
4144   my ($self) = @_;
4145
4146   my $p = $self->{properties};
4147   return $p->{have_compiler} if defined $p->{have_compiler};
4148
4149   $self->log_verbose("Checking if compiler tools configured... ");
4150   my $b = eval { $self->cbuilder };
4151   my $have = $b && $b->have_compiler;
4152   $self->log_verbose($have ? "ok.\n" : "failed.\n");
4153   return $p->{have_compiler} = $have;
4154 }
4155
4156 sub compile_c {
4157   my ($self, $file, %args) = @_;
4158   my $b = $self->cbuilder;
4159
4160   my $obj_file = $b->object_file($file);
4161   $self->add_to_cleanup($obj_file);
4162   return $obj_file if $self->up_to_date($file, $obj_file);
4163
4164   $b->compile(source => $file,
4165               defines => $args{defines},
4166               object_file => $obj_file,
4167               include_dirs => $self->include_dirs,
4168               extra_compiler_flags => $self->extra_compiler_flags,
4169              );
4170
4171   return $obj_file;
4172 }
4173
4174 sub link_c {
4175   my ($self, $to, $file_base) = @_;
4176   my $p = $self->{properties}; # For convenience
4177
4178   my $spec = $self->_infer_xs_spec($file_base);
4179
4180   $self->add_to_cleanup($spec->{lib_file});
4181
4182   my $objects = $p->{objects} || [];
4183
4184   return $spec->{lib_file}
4185     if $self->up_to_date([$spec->{obj_file}, @$objects],
4186                          $spec->{lib_file});
4187
4188   my $module_name = $self->module_name;
4189   $module_name  ||= $spec->{module_name};
4190
4191   $self->cbuilder->link(
4192     module_name => $module_name,
4193     objects     => [$spec->{obj_file}, @$objects],
4194     lib_file    => $spec->{lib_file},
4195     extra_linker_flags => $p->{extra_linker_flags} );
4196
4197   return $spec->{lib_file};
4198 }
4199
4200 sub compile_xs {
4201   my ($self, $file, %args) = @_;
4202
4203   $self->log_info("$file -> $args{outfile}\n");
4204
4205   if (eval {require ExtUtils::ParseXS; 1}) {
4206
4207     ExtUtils::ParseXS::process_file(
4208                                     filename => $file,
4209                                     prototypes => 0,
4210                                     output => $args{outfile},
4211                                    );
4212   } else {
4213     # Ok, I give up.  Just use backticks.
4214
4215     my $xsubpp = Module::Build::ModuleInfo->find_module_by_name('ExtUtils::xsubpp')
4216       or die "Can't find ExtUtils::xsubpp in INC (@INC)";
4217
4218     my @typemaps;
4219     push @typemaps, Module::Build::ModuleInfo->find_module_by_name(
4220         'ExtUtils::typemap', \@INC
4221     );
4222     my $lib_typemap = Module::Build::ModuleInfo->find_module_by_name(
4223         'typemap', [File::Basename::dirname($file)]
4224     );
4225     push @typemaps, $lib_typemap if $lib_typemap;
4226     @typemaps = map {+'-typemap', $_} @typemaps;
4227
4228     my $cf = $self->{config};
4229     my $perl = $self->{properties}{perl};
4230
4231     my @command = ($perl, "-I".$cf->get('installarchlib'), "-I".$cf->get('installprivlib'), $xsubpp, '-noprototypes',
4232                    @typemaps, $file);
4233
4234     $self->log_info("@command\n");
4235     my $fh = IO::File->new("> $args{outfile}") or die "Couldn't write $args{outfile}: $!";
4236     print {$fh} $self->_backticks(@command);
4237     close $fh;
4238   }
4239 }
4240
4241 sub split_like_shell {
4242   my ($self, $string) = @_;
4243
4244   return () unless defined($string);
4245   return @$string if UNIVERSAL::isa($string, 'ARRAY');
4246   $string =~ s/^\s+|\s+$//g;
4247   return () unless length($string);
4248
4249   return Text::ParseWords::shellwords($string);
4250 }
4251
4252 sub oneliner {
4253   # Returns a string that the shell can evaluate as a perl command.
4254   # This should be avoided whenever possible, since "the shell" really
4255   # means zillions of shells on zillions of platforms and it's really
4256   # hard to get it right all the time.
4257
4258   # Some of this code is stolen with permission from ExtUtils::MakeMaker.
4259
4260   my($self, $cmd, $switches, $args) = @_;
4261   $switches = [] unless defined $switches;
4262   $args = [] unless defined $args;
4263
4264   # Strip leading and trailing newlines
4265   $cmd =~ s{^\n+}{};
4266   $cmd =~ s{\n+$}{};
4267
4268   my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
4269   return $self->_quote_args($perl, @$switches, '-e', $cmd, @$args);
4270 }
4271
4272 sub run_perl_script {
4273   my ($self, $script, $preargs, $postargs) = @_;
4274   foreach ($preargs, $postargs) {
4275     $_ = [ $self->split_like_shell($_) ] unless ref();
4276   }
4277   return $self->run_perl_command([@$preargs, $script, @$postargs]);
4278 }
4279
4280 sub run_perl_command {
4281   # XXX Maybe we should accept @args instead of $args?  Must resolve
4282   # this before documenting.
4283   my ($self, $args) = @_;
4284   $args = [ $self->split_like_shell($args) ] unless ref($args);
4285   my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
4286
4287   # Make sure our local additions to @INC are propagated to the subprocess
4288   local $ENV{PERL5LIB} = join $self->config('path_sep'), $self->_added_to_INC;
4289
4290   return $self->do_system($perl, @$args);
4291 }
4292
4293 # Infer various data from the path of the input filename
4294 # that is needed to create output files.
4295 # The input filename is expected to be of the form:
4296 #   lib/Module/Name.ext or Module/Name.ext
4297 sub _infer_xs_spec {
4298   my $self = shift;
4299   my $file = shift;
4300
4301   my $cf = $self->{config};
4302
4303   my %spec;
4304
4305   my( $v, $d, $f ) = File::Spec->splitpath( $file );
4306   my @d = File::Spec->splitdir( $d );
4307   (my $file_base = $f) =~ s/\.[^.]+$//i;
4308
4309   $spec{base_name} = $file_base;
4310
4311   $spec{src_dir} = File::Spec->catpath( $v, $d, '' );
4312
4313   # the module name
4314   shift( @d ) while @d && ($d[0] eq 'lib' || $d[0] eq '');
4315   pop( @d ) while @d && $d[-1] eq '';
4316   $spec{module_name} = join( '::', (@d, $file_base) );
4317
4318   $spec{archdir} = File::Spec->catdir($self->blib, 'arch', 'auto',
4319                                       @d, $file_base);
4320
4321   $spec{bs_file} = File::Spec->catfile($spec{archdir}, "${file_base}.bs");
4322
4323   $spec{lib_file} = File::Spec->catfile($spec{archdir},
4324                                         "${file_base}.".$cf->get('dlext'));
4325
4326   $spec{c_file} = File::Spec->catfile( $spec{src_dir},
4327                                        "${file_base}.c" );
4328
4329   $spec{obj_file} = File::Spec->catfile( $spec{src_dir},
4330                                          "${file_base}".$cf->get('obj_ext') );
4331
4332   return \%spec;
4333 }
4334
4335 sub process_xs {
4336   my ($self, $file) = @_;
4337
4338   my $spec = $self->_infer_xs_spec($file);
4339
4340   # File name, minus the suffix
4341   (my $file_base = $file) =~ s/\.[^.]+$//;
4342
4343   # .xs -> .c
4344   $self->add_to_cleanup($spec->{c_file});
4345
4346   unless ($self->up_to_date($file, $spec->{c_file})) {
4347     $self->compile_xs($file, outfile => $spec->{c_file});
4348   }
4349
4350   # .c -> .o
4351   my $v = $self->dist_version;
4352   $self->compile_c($spec->{c_file},
4353                    defines => {VERSION => qq{"$v"}, XS_VERSION => qq{"$v"}});
4354
4355   # archdir
4356   File::Path::mkpath($spec->{archdir}, 0, oct(777)) unless -d $spec->{archdir};
4357
4358   # .xs -> .bs
4359   $self->add_to_cleanup($spec->{bs_file});
4360   unless ($self->up_to_date($file, $spec->{bs_file})) {
4361     require ExtUtils::Mkbootstrap;
4362     $self->log_info("ExtUtils::Mkbootstrap::Mkbootstrap('$spec->{bs_file}')\n");
4363     ExtUtils::Mkbootstrap::Mkbootstrap($spec->{bs_file});  # Original had $BSLOADLIBS - what's that?
4364     {my $fh = IO::File->new(">> $spec->{bs_file}")}  # create
4365     utime((time)x2, $spec->{bs_file});  # touch
4366   }
4367
4368   # .o -> .(a|bundle)
4369   $self->link_c($spec->{archdir}, $file_base);
4370 }
4371
4372 sub do_system {
4373   my ($self, @cmd) = @_;
4374   $self->log_info("@cmd\n");
4375
4376   # Some systems proliferate huge PERL5LIBs, try to ameliorate:
4377   my %seen;
4378   my $sep = $self->config('path_sep');
4379   local $ENV{PERL5LIB} =
4380     ( !exists($ENV{PERL5LIB}) ? '' :
4381       length($ENV{PERL5LIB}) < 500
4382       ? $ENV{PERL5LIB}
4383       : join $sep, grep { ! $seen{$_}++ and -d $_ } split($sep, $ENV{PERL5LIB})
4384     );
4385
4386   my $status = system(@cmd);
4387   if ($status and $! =~ /Argument list too long/i) {
4388     my $env_entries = '';
4389     foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
4390     warn "'Argument list' was 'too long', env lengths are $env_entries";
4391   }
4392   return !$status;
4393 }
4394
4395 sub copy_if_modified {
4396   my $self = shift;
4397   my %args = (@_ > 3
4398               ? ( @_ )
4399               : ( from => shift, to_dir => shift, flatten => shift )
4400              );
4401   $args{verbose} = !$self->quiet
4402     unless exists $args{verbose};
4403
4404   my $file = $args{from};
4405   unless (defined $file and length $file) {
4406     die "No 'from' parameter given to copy_if_modified";
4407   }
4408
4409   my $to_path;
4410   if (defined $args{to} and length $args{to}) {
4411     $to_path = $args{to};
4412   } elsif (defined $args{to_dir} and length $args{to_dir}) {
4413     $to_path = File::Spec->catfile( $args{to_dir}, $args{flatten}
4414                                     ? File::Basename::basename($file)
4415                                     : $file );
4416   } else {
4417     die "No 'to' or 'to_dir' parameter given to copy_if_modified";
4418   }
4419
4420   return if $self->up_to_date($file, $to_path); # Already fresh
4421
4422   {
4423     local $self->{properties}{quiet} = 1;
4424     $self->delete_filetree($to_path); # delete destination if exists
4425   }
4426
4427   # Create parent directories
4428   File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777));
4429
4430   $self->log_info("Copying $file -> $to_path\n") if $args{verbose};
4431
4432   if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite
4433     chmod 0666, $to_path;
4434     File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!";
4435   } else {
4436     File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!";
4437   }
4438
4439   # mode is read-only + (executable if source is executable)
4440   my $mode = oct(444) | ( $self->is_executable($file) ? oct(111) : 0 );
4441   chmod( $mode, $to_path );
4442
4443   return $to_path;
4444 }
4445
4446 sub up_to_date {
4447   my ($self, $source, $derived) = @_;
4448   $source  = [$source]  unless ref $source;
4449   $derived = [$derived] unless ref $derived;
4450
4451   return 0 if grep {not -e} @$derived;
4452
4453   my $most_recent_source = time / (24*60*60);
4454   foreach my $file (@$source) {
4455     unless (-e $file) {
4456       $self->log_warn("Can't find source file $file for up-to-date check");
4457       next;
4458     }
4459     $most_recent_source = -M _ if -M _ < $most_recent_source;
4460   }
4461
4462   foreach my $derived (@$derived) {
4463     return 0 if -M $derived > $most_recent_source;
4464   }
4465   return 1;
4466 }
4467
4468 sub dir_contains {
4469   my ($self, $first, $second) = @_;
4470   # File::Spec doesn't have an easy way to check whether one directory
4471   # is inside another, unfortunately.
4472
4473   ($first, $second) = map File::Spec->canonpath($_), ($first, $second);
4474   my @first_dirs = File::Spec->splitdir($first);
4475   my @second_dirs = File::Spec->splitdir($second);
4476
4477   return 0 if @second_dirs < @first_dirs;
4478
4479   my $is_same = ( File::Spec->case_tolerant
4480                   ? sub {lc(shift()) eq lc(shift())}
4481                   : sub {shift() eq shift()} );
4482
4483   while (@first_dirs) {
4484     return 0 unless $is_same->(shift @first_dirs, shift @second_dirs);
4485   }
4486
4487   return 1;
4488 }
4489
4490 1;
4491 __END__
4492
4493
4494 =head1 NAME
4495
4496 Module::Build::Base - Default methods for Module::Build
4497
4498 =head1 SYNOPSIS
4499
4500   Please see the Module::Build documentation.
4501
4502 =head1 DESCRIPTION
4503
4504 The C<Module::Build::Base> module defines the core functionality of
4505 C<Module::Build>.  Its methods may be overridden by any of the
4506 platform-dependent modules in the C<Module::Build::Platform::>
4507 namespace, but the intention here is to make this base module as
4508 platform-neutral as possible.  Nicely enough, Perl has several core
4509 tools available in the C<File::> namespace for doing this, so the task
4510 isn't very difficult.
4511
4512 Please see the C<Module::Build> documentation for more details.
4513
4514 =head1 AUTHOR
4515
4516 Ken Williams <kwilliams@cpan.org>
4517
4518 =head1 COPYRIGHT
4519
4520 Copyright (c) 2001-2006 Ken Williams.  All rights reserved.
4521
4522 This library is free software; you can redistribute it and/or
4523 modify it under the same terms as Perl itself.
4524
4525 =head1 SEE ALSO
4526
4527 perl(1), Module::Build(3)
4528
4529 =cut