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