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