lib/Module/Build/Base.pm

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