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