lib/Module/Build/Base.pm

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