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