This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Module-Build to CPAN version 0.4008
[perl5.git] / cpan / Module-Build / lib / Module / Build / Base.pm
CommitLineData
738349a8
SH
1# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
2# vim:ts=8:sw=2:et:sta:sts=2
bb4e9162
YST
3package Module::Build::Base;
4
5use strict;
7a827510 6use vars qw($VERSION);
1ce5ed3e
SH
7use warnings;
8
6e4bdc3f 9$VERSION = '0.4008';
7a827510 10$VERSION = eval $VERSION;
1ce5ed3e 11BEGIN { require 5.006001 }
dc8021d3
SP
12
13use Carp;
738349a8 14use Cwd ();
bb4e9162
YST
15use File::Copy ();
16use File::Find ();
17use File::Path ();
18use File::Basename ();
19use File::Spec 0.82 ();
20use File::Compare ();
7a827510 21use Module::Build::Dumper ();
bb4e9162 22use Text::ParseWords ();
bb4e9162
YST
23
24use Module::Build::ModuleInfo;
25use Module::Build::Notes;
77e96e88 26use Module::Build::Config;
613f422f 27use Module::Build::Version;
bb4e9162
YST
28
29
30#################### Constructors ###########################
31sub new {
32 my $self = shift()->_construct(@_);
33
34 $self->{invoked_action} = $self->{action} ||= 'Build_PL';
35 $self->cull_args(@ARGV);
613f422f 36
bb4e9162
YST
37 die "Too early to specify a build action '$self->{action}'. Do 'Build $self->{action}' instead.\n"
38 if $self->{action} && $self->{action} ne 'Build_PL';
39
bb4e9162 40 $self->check_manifest;
613f422f 41 $self->auto_require;
58fa6946
CBW
42
43 # All checks must run regardless if one fails, so no short circuiting!
44 if( grep { !$_ } $self->check_prereq, $self->check_autofeatures ) {
613f422f
DG
45 $self->log_warn(<<EOF);
46
47ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions
48of the modules indicated above before proceeding with this installation
49
50EOF
51 unless (
52 $self->dist_name eq 'Module-Build' ||
53 $ENV{PERL5_CPANPLUS_IS_RUNNING} || $ENV{PERL5_CPAN_IS_RUNNING}
54 ) {
55 $self->log_warn(
56 "Run 'Build installdeps' to install missing prerequisites.\n\n"
57 );
58 }
59 }
60
61 # record for later use in resume;
62 $self->{properties}{_added_to_INC} = [ $self->_added_to_INC ];
63
64 $self->set_bundle_inc;
bb4e9162 65
7a827510
RGS
66 $self->dist_name;
67 $self->dist_version;
7cf8bfc0 68 $self->release_status;
613f422f 69 $self->_guess_module_name unless $self->module_name;
7a827510 70
bb4e9162
YST
71 $self->_find_nested_builds;
72
73 return $self;
74}
75
76sub resume {
77 my $package = shift;
78 my $self = $package->_construct(@_);
79 $self->read_config;
80
08fc25ad
DG
81 my @added_earlier = @{ $self->{properties}{_added_to_INC} || [] };
82
83 @INC = ($self->_added_to_INC, @added_earlier, $self->_default_INC);
613f422f 84
bb4e9162
YST
85 # If someone called Module::Build->current() or
86 # Module::Build->new_from_context() and the correct class to use is
87 # actually a *subclass* of Module::Build, we may need to load that
88 # subclass here and re-delegate the resume() method to it.
89 unless ( UNIVERSAL::isa($package, $self->build_class) ) {
90 my $build_class = $self->build_class;
91 my $config_dir = $self->config_dir || '_build';
92 my $build_lib = File::Spec->catdir( $config_dir, 'lib' );
93 unshift( @INC, $build_lib );
94 unless ( $build_class->can('new') ) {
95 eval "require $build_class; 1" or die "Failed to re-load '$build_class': $@";
96 }
97 return $build_class->resume(@_);
98 }
99
100 unless ($self->_perl_is_same($self->{properties}{perl})) {
101 my $perl = $self->find_perl_interpreter;
7cf8bfc0
DG
102 die(<<"DIEFATAL");
103* FATAL ERROR: Perl interpreter mismatch. Configuration was initially
104 created with '$self->{properties}{perl}'
105 but we are now using '$perl'. You must
106 run 'Build realclean' or 'make realclean' and re-configure.
107DIEFATAL
bb4e9162 108 }
613f422f 109
bb4e9162 110 $self->cull_args(@ARGV);
0ec9ad96
SP
111
112 unless ($self->allow_mb_mismatch) {
113 my $mb_version = $Module::Build::VERSION;
7dc9e1b4
DG
114 if ( $mb_version ne $self->{properties}{mb_version} ) {
115 $self->log_warn(<<"MISMATCH");
7cf8bfc0 116* WARNING: Configuration was initially created with Module::Build
7dc9e1b4
DG
117 version '$self->{properties}{mb_version}' but we are now using version '$mb_version'.
118 If errors occur, you must re-run the Build.PL or Makefile.PL script.
119MISMATCH
120 }
0ec9ad96 121 }
613f422f 122
bb4e9162 123 $self->{invoked_action} = $self->{action} ||= 'build';
738349a8 124
bb4e9162
YST
125 return $self;
126}
127
128sub new_from_context {
129 my ($package, %args) = @_;
613f422f
DG
130
131 $package->run_perl_script('Build.PL',[],[$package->unparse_args(\%args)]);
bb4e9162
YST
132 return $package->resume;
133}
134
135sub current {
136 # hmm, wonder what the right thing to do here is
137 local @ARGV;
138 return shift()->resume;
139}
140
141sub _construct {
142 my ($package, %input) = @_;
143
144 my $args = delete $input{args} || {};
145 my $config = delete $input{config} || {};
146
147 my $self = bless {
58fa6946
CBW
148 args => {%$args},
149 config => Module::Build::Config->new(values => $config),
150 properties => {
151 base_dir => $package->cwd,
152 mb_version => $Module::Build::VERSION,
153 %input,
154 },
155 phash => {},
156 stash => {}, # temporary caching, not stored in _build
157 }, $package;
bb4e9162
YST
158
159 $self->_set_defaults;
77e96e88 160 my ($p, $ph) = ($self->{properties}, $self->{phash});
bb4e9162
YST
161
162 foreach (qw(notes config_data features runtime_params cleanup auto_features)) {
163 my $file = File::Spec->catfile($self->config_dir, $_);
164 $ph->{$_} = Module::Build::Notes->new(file => $file);
165 $ph->{$_}->restore if -e $file;
166 if (exists $p->{$_}) {
167 my $vals = delete $p->{$_};
168 while (my ($k, $v) = each %$vals) {
58fa6946 169 $self->$_($k, $v);
bb4e9162
YST
170 }
171 }
172 }
173
174 # The following warning could be unnecessary if the user is running
175 # an embedded perl, but there aren't too many of those around, and
176 # embedded perls aren't usually used to install modules, and the
177 # installation process sometimes needs to run external scripts
178 # (e.g. to run tests).
179 $p->{perl} = $self->find_perl_interpreter
180 or $self->log_warn("Warning: Can't locate your perl binary");
181
182 my $blibdir = sub { File::Spec->catdir($p->{blib}, @_) };
183 $p->{bindoc_dirs} ||= [ $blibdir->("script") ];
184 $p->{libdoc_dirs} ||= [ $blibdir->("lib"), $blibdir->("arch") ];
185
186 $p->{dist_author} = [ $p->{dist_author} ] if defined $p->{dist_author} and not ref $p->{dist_author};
187
188 # Synonyms
189 $p->{requires} = delete $p->{prereq} if defined $p->{prereq};
190 $p->{script_files} = delete $p->{scripts} if defined $p->{scripts};
191
23837600 192 # Convert to from shell strings to arrays
bb4e9162
YST
193 for ('extra_compiler_flags', 'extra_linker_flags') {
194 $p->{$_} = [ $self->split_like_shell($p->{$_}) ] if exists $p->{$_};
195 }
196
23837600
DG
197 # Convert to arrays
198 for ('include_dirs') {
199 $p->{$_} = [ $p->{$_} ] if exists $p->{$_} && !ref $p->{$_}
200 }
201
bb4e9162
YST
202 $self->add_to_cleanup( @{delete $p->{add_to_cleanup}} )
203 if $p->{add_to_cleanup};
204
205 return $self;
206}
207
208################## End constructors #########################
209
15cb7b9d
SH
210sub log_info {
211 my $self = shift;
7cf8bfc0 212 print @_ if ref($self) && ( $self->verbose || ! $self->quiet );
15cb7b9d
SH
213}
214sub log_verbose {
215 my $self = shift;
7cf8bfc0 216 print @_ if ref($self) && $self->verbose;
15cb7b9d 217}
4085a377
DG
218sub log_debug {
219 my $self = shift;
7cf8bfc0 220 print @_ if ref($self) && $self->debug;
4085a377
DG
221}
222
bb4e9162
YST
223sub log_warn {
224 # Try to make our call stack invisible
225 shift;
226 if (@_ and $_[-1] !~ /\n$/) {
227 my (undef, $file, $line) = caller();
228 warn @_, " at $file line $line.\n";
229 } else {
230 warn @_;
231 }
232}
233
234
cdbde1c3
DG
235# install paths must be generated when requested to be sure all changes
236# to config (from various sources) are included
237sub _default_install_paths {
bb4e9162 238 my $self = shift;
77e96e88 239 my $c = $self->{config};
cdbde1c3 240 my $p = {};
bb4e9162 241
77e96e88
RGS
242 my @libstyle = $c->get('installstyle') ?
243 File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5);
244 my $arch = $c->get('archname');
245 my $version = $c->get('version');
bb4e9162 246
77e96e88
RGS
247 my $bindoc = $c->get('installman1dir') || undef;
248 my $libdoc = $c->get('installman3dir') || undef;
bb4e9162 249
77e96e88
RGS
250 my $binhtml = $c->get('installhtml1dir') || $c->get('installhtmldir') || undef;
251 my $libhtml = $c->get('installhtml3dir') || $c->get('installhtmldir') || undef;
bb4e9162
YST
252
253 $p->{install_sets} =
254 {
255 core => {
58fa6946
CBW
256 lib => $c->get('installprivlib'),
257 arch => $c->get('installarchlib'),
258 bin => $c->get('installbin'),
259 script => $c->get('installscript'),
260 bindoc => $bindoc,
261 libdoc => $libdoc,
262 binhtml => $binhtml,
263 libhtml => $libhtml,
264 },
bb4e9162 265 site => {
58fa6946
CBW
266 lib => $c->get('installsitelib'),
267 arch => $c->get('installsitearch'),
268 bin => $c->get('installsitebin') || $c->get('installbin'),
269 script => $c->get('installsitescript') ||
270 $c->get('installsitebin') || $c->get('installscript'),
271 bindoc => $c->get('installsiteman1dir') || $bindoc,
272 libdoc => $c->get('installsiteman3dir') || $libdoc,
273 binhtml => $c->get('installsitehtml1dir') || $binhtml,
274 libhtml => $c->get('installsitehtml3dir') || $libhtml,
275 },
bb4e9162 276 vendor => {
58fa6946
CBW
277 lib => $c->get('installvendorlib'),
278 arch => $c->get('installvendorarch'),
279 bin => $c->get('installvendorbin') || $c->get('installbin'),
280 script => $c->get('installvendorscript') ||
281 $c->get('installvendorbin') || $c->get('installscript'),
282 bindoc => $c->get('installvendorman1dir') || $bindoc,
283 libdoc => $c->get('installvendorman3dir') || $libdoc,
284 binhtml => $c->get('installvendorhtml1dir') || $binhtml,
285 libhtml => $c->get('installvendorhtml3dir') || $libhtml,
286 },
bb4e9162
YST
287 };
288
289 $p->{original_prefix} =
290 {
77e96e88
RGS
291 core => $c->get('installprefixexp') || $c->get('installprefix') ||
292 $c->get('prefixexp') || $c->get('prefix') || '',
293 site => $c->get('siteprefixexp'),
294 vendor => $c->get('usevendorprefix') ? $c->get('vendorprefixexp') : '',
bb4e9162
YST
295 };
296 $p->{original_prefix}{site} ||= $p->{original_prefix}{core};
297
298 # Note: you might be tempted to use $Config{installstyle} here
299 # instead of hard-coding lib/perl5, but that's been considered and
300 # (at least for now) rejected. `perldoc Config` has some wisdom
301 # about it.
302 $p->{install_base_relpaths} =
303 {
304 lib => ['lib', 'perl5'],
305 arch => ['lib', 'perl5', $arch],
306 bin => ['bin'],
307 script => ['bin'],
308 bindoc => ['man', 'man1'],
309 libdoc => ['man', 'man3'],
310 binhtml => ['html'],
311 libhtml => ['html'],
312 };
313
314 $p->{prefix_relpaths} =
315 {
316 core => {
58fa6946
CBW
317 lib => [@libstyle],
318 arch => [@libstyle, $version, $arch],
319 bin => ['bin'],
320 script => ['bin'],
321 bindoc => ['man', 'man1'],
322 libdoc => ['man', 'man3'],
323 binhtml => ['html'],
324 libhtml => ['html'],
325 },
bb4e9162 326 vendor => {
58fa6946
CBW
327 lib => [@libstyle],
328 arch => [@libstyle, $version, $arch],
329 bin => ['bin'],
330 script => ['bin'],
331 bindoc => ['man', 'man1'],
332 libdoc => ['man', 'man3'],
333 binhtml => ['html'],
334 libhtml => ['html'],
335 },
bb4e9162 336 site => {
58fa6946
CBW
337 lib => [@libstyle, 'site_perl'],
338 arch => [@libstyle, 'site_perl', $version, $arch],
339 bin => ['bin'],
340 script => ['bin'],
341 bindoc => ['man', 'man1'],
342 libdoc => ['man', 'man3'],
343 binhtml => ['html'],
344 libhtml => ['html'],
345 },
bb4e9162 346 };
cdbde1c3 347 return $p
bb4e9162
YST
348}
349
350sub _find_nested_builds {
351 my $self = shift;
352 my $r = $self->recurse_into or return;
353
354 my ($file, @r);
355 if (!ref($r) && $r eq 'auto') {
356 local *DH;
357 opendir DH, $self->base_dir
358 or die "Can't scan directory " . $self->base_dir . " for nested builds: $!";
359 while (defined($file = readdir DH)) {
360 my $subdir = File::Spec->catdir( $self->base_dir, $file );
361 next unless -d $subdir;
362 push @r, $subdir if -e File::Spec->catfile( $subdir, 'Build.PL' );
363 }
364 }
365
366 $self->recurse_into(\@r);
367}
368
369sub cwd {
bb4e9162
YST
370 return Cwd::cwd();
371}
372
a314697d
RS
373sub _quote_args {
374 # Returns a string that can become [part of] a command line with
375 # proper quoting so that the subprocess sees this same list of args.
376 my ($self, @args) = @_;
377
a314697d
RS
378 my @quoted;
379
380 for (@args) {
738349a8 381 if ( /^[^\s*?!\$<>;\\|'"\[\]\{\}]+$/ ) {
a314697d
RS
382 # Looks pretty safe
383 push @quoted, $_;
384 } else {
385 # XXX this will obviously have to improve - is there already a
386 # core module lying around that does proper quoting?
738349a8
SH
387 s/('+)/'"$1"'/g;
388 push @quoted, qq('$_');
a314697d
RS
389 }
390 }
391
392 return join " ", @quoted;
393}
394
395sub _backticks {
a314697d 396 my ($self, @cmd) = @_;
dc8021d3 397 if ($self->have_forkpipe) {
a314697d 398 local *FH;
77e96e88 399 my $pid = open *FH, "-|";
dc8021d3
SP
400 if ($pid) {
401 return wantarray ? <FH> : join '', <FH>;
402 } else {
403 die "Can't execute @cmd: $!\n" unless defined $pid;
404 exec { $cmd[0] } @cmd;
405 }
a314697d
RS
406 } else {
407 my $cmd = $self->_quote_args(@cmd);
408 return `$cmd`;
409 }
410}
411
738349a8
SH
412# Tells us whether the construct open($fh, '-|', @command) is
413# supported. It would probably be better to dynamically sense this.
dc8021d3 414sub have_forkpipe { 1 }
a314697d
RS
415
416# Determine whether a given binary is the same as the perl
417# (configuration) that started this process.
bb4e9162
YST
418sub _perl_is_same {
419 my ($self, $perl) = @_;
a314697d
RS
420
421 my @cmd = ($perl);
422
423 # When run from the perl core, @INC will include the directories
424 # where perl is yet to be installed. We need to reference the
425 # absolute path within the source distribution where it can find
426 # it's Config.pm This also prevents us from picking up a Config.pm
427 # from a different configuration that happens to be already
428 # installed in @INC.
429 if ($ENV{PERL_CORE}) {
430 push @cmd, '-I' . File::Spec->catdir(File::Basename::dirname($perl), 'lib');
431 }
432
433 push @cmd, qw(-MConfig=myconfig -e print -e myconfig);
434 return $self->_backticks(@cmd) eq Config->myconfig;
bb4e9162
YST
435}
436
7a827510
RGS
437# cache _discover_perl_interpreter() results
438{
439 my $known_perl;
440 sub find_perl_interpreter {
441 my $self = shift;
442
443 return $known_perl if defined($known_perl);
444 return $known_perl = $self->_discover_perl_interpreter;
445 }
446}
447
23837600 448# Returns the absolute path of the perl interpreter used to invoke
a314697d
RS
449# this process. The path is derived from $^X or $Config{perlpath}. On
450# some platforms $^X contains the complete absolute path of the
451# interpreter, on other it may contain a relative path, or simply
452# 'perl'. This can also vary depending on whether a path was supplied
453# when perl was invoked. Additionally, the value in $^X may omit the
454# executable extension on platforms that use one. It's a fatal error
455# if the interpreter can't be found because it can result in undefined
456# behavior by routines that depend on it (generating errors or
7a827510
RGS
457# invoking the wrong perl.)
458sub _discover_perl_interpreter {
bb4e9162 459 my $proto = shift;
77e96e88 460 my $c = ref($proto) ? $proto->{config} : 'Module::Build::Config';
bb4e9162 461
a314697d
RS
462 my $perl = $^X;
463 my $perl_basename = File::Basename::basename($perl);
464
465 my @potential_perls;
466
467 # Try 1, Check $^X for absolute path
468 push( @potential_perls, $perl )
469 if File::Spec->file_name_is_absolute($perl);
470
471 # Try 2, Check $^X for a valid relative path
472 my $abs_perl = File::Spec->rel2abs($perl);
473 push( @potential_perls, $abs_perl );
47f13fd5 474
a314697d
RS
475 # Try 3, Last ditch effort: These two option use hackery to try to locate
476 # a suitable perl. The hack varies depending on whether we are running
477 # from an installed perl or an uninstalled perl in the perl source dist.
47f13fd5 478 if ($ENV{PERL_CORE}) {
a314697d
RS
479
480 # Try 3.A, If we are in a perl source tree, running an uninstalled
481 # perl, we can keep moving up the directory tree until we find our
482 # binary. We wouldn't do this under any other circumstances.
483
47f13fd5
SP
484 # CBuilder is also in the core, so it should be available here
485 require ExtUtils::CBuilder;
738349a8 486 my $perl_src = Cwd::realpath( ExtUtils::CBuilder->perl_src );
a314697d
RS
487 if ( defined($perl_src) && length($perl_src) ) {
488 my $uninstperl =
489 File::Spec->rel2abs(File::Spec->catfile( $perl_src, $perl_basename ));
490 push( @potential_perls, $uninstperl );
491 }
492
493 } else {
494
7a827510 495 # Try 3.B, First look in $Config{perlpath}, then search the user's
a314697d
RS
496 # PATH. We do not want to do either if we are running from an
497 # uninstalled perl in a perl source tree.
498
77e96e88 499 push( @potential_perls, $c->get('perlpath') );
a314697d
RS
500
501 push( @potential_perls,
502 map File::Spec->catfile($_, $perl_basename), File::Spec->path() );
47f13fd5
SP
503 }
504
a314697d
RS
505 # Now that we've enumerated the potential perls, it's time to test
506 # them to see if any of them match our configuration, returning the
507 # absolute path of the first successful match.
77e96e88 508 my $exe = $c->get('exe_ext');
a314697d
RS
509 foreach my $thisperl ( @potential_perls ) {
510
7a827510 511 if (defined $exe) {
a314697d
RS
512 $thisperl .= $exe unless $thisperl =~ m/$exe$/i;
513 }
514
515 if ( -f $thisperl && $proto->_perl_is_same($thisperl) ) {
516 return $thisperl;
517 }
bb4e9162 518 }
a314697d
RS
519
520 # We've tried all alternatives, and didn't find a perl that matches
521 # our configuration. Throw an exception, and list alternatives we tried.
522 my @paths = map File::Basename::dirname($_), @potential_perls;
523 die "Can't locate the perl binary used to run this script " .
524 "in (@paths)\n";
bb4e9162
YST
525}
526
613f422f
DG
527# Adapted from IPC::Cmd::can_run()
528sub find_command {
58fa6946 529 my ($self, $command) = @_;
613f422f 530
58fa6946
CBW
531 if( File::Spec->file_name_is_absolute($command) ) {
532 return $self->_maybe_command($command);
613f422f 533
58fa6946
CBW
534 } else {
535 for my $dir ( File::Spec->path ) {
536 my $abs = File::Spec->catfile($dir, $command);
537 return $abs if $abs = $self->_maybe_command($abs);
613f422f 538 }
58fa6946 539 }
613f422f
DG
540}
541
542# Copied from ExtUtils::MM_Unix::maybe_command
543sub _maybe_command {
58fa6946
CBW
544 my($self,$file) = @_;
545 return $file if -x $file && ! -d $file;
546 return;
613f422f
DG
547}
548
bb4e9162
YST
549sub _is_interactive {
550 return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe?
551}
552
7253302f 553# NOTE this is a blocking operation if(-t STDIN)
dc8021d3
SP
554sub _is_unattended {
555 my $self = shift;
7253302f
SP
556 return $ENV{PERL_MM_USE_DEFAULT} ||
557 ( !$self->_is_interactive && eof STDIN );
dc8021d3
SP
558}
559
560sub _readline {
561 my $self = shift;
562 return undef if $self->_is_unattended;
563
564 my $answer = <STDIN>;
565 chomp $answer if defined $answer;
566 return $answer;
567}
568
bb4e9162
YST
569sub prompt {
570 my $self = shift;
dc8021d3
SP
571 my $mess = shift
572 or die "prompt() called without a prompt message";
573
7253302f
SP
574 # use a list to distinguish a default of undef() from no default
575 my @def;
576 @def = (shift) if @_;
577 # use dispdef for output
578 my @dispdef = scalar(@def) ?
579 ('[', (defined($def[0]) ? $def[0] . ' ' : ''), ']') :
580 (' ', '');
581
582 local $|=1;
583 print "$mess ", @dispdef;
584
585 if ( $self->_is_unattended && !@def ) {
dc8021d3
SP
586 die <<EOF;
587ERROR: This build seems to be unattended, but there is no default value
588for this question. Aborting.
589EOF
590 }
dc8021d3
SP
591
592 my $ans = $self->_readline();
593
b3dfda33
SP
594 if ( !defined($ans) # Ctrl-D or unattended
595 or !length($ans) ) { # User hit return
7253302f
SP
596 print "$dispdef[1]\n";
597 $ans = scalar(@def) ? $def[0] : '';
bb4e9162 598 }
dc8021d3 599
bb4e9162
YST
600 return $ans;
601}
602
603sub y_n {
604 my $self = shift;
dc8021d3
SP
605 my ($mess, $def) = @_;
606
607 die "y_n() called without a prompt message" unless $mess;
608 die "Invalid default value: y_n() default must be 'y' or 'n'"
609 if $def && $def !~ /^[yn]/i;
610
bb4e9162 611 my $answer;
dc8021d3 612 while (1) { # XXX Infinite or a large number followed by an exception ?
bb4e9162
YST
613 $answer = $self->prompt(@_);
614 return 1 if $answer =~ /^y/i;
615 return 0 if $answer =~ /^n/i;
dc8021d3 616 local $|=1;
bb4e9162
YST
617 print "Please answer 'y' or 'n'.\n";
618 }
619}
620
621sub current_action { shift->{action} }
622sub invoked_action { shift->{invoked_action} }
623
624sub notes { shift()->{phash}{notes}->access(@_) }
625sub config_data { shift()->{phash}{config_data}->access(@_) }
626sub runtime_params { shift->{phash}{runtime_params}->read( @_ ? shift : () ) } # Read-only
627sub auto_features { shift()->{phash}{auto_features}->access(@_) }
628
629sub features {
630 my $self = shift;
631 my $ph = $self->{phash};
632
633 if (@_) {
634 my $key = shift;
635 if ($ph->{features}->exists($key)) {
636 return $ph->{features}->access($key, @_);
637 }
638
639 if (my $info = $ph->{auto_features}->access($key)) {
613f422f
DG
640 my $disabled;
641 for my $type ( @{$self->prereq_action_types} ) {
642 next if $type eq 'description' || $type eq 'recommends' || ! exists $info->{$type};
643 my $prereqs = $info->{$type};
644 for my $modname ( sort keys %$prereqs ) {
645 my $spec = $prereqs->{$modname};
646 my $status = $self->check_installed_status($modname, $spec);
647 if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; }
648 if ( ! eval "require $modname; 1" ) { return 0; }
649 }
650 }
651 return 1;
bb4e9162
YST
652 }
653
654 return $ph->{features}->access($key, @_);
655 }
656
657 # No args - get the auto_features & overlay the regular features
658 my %features;
659 my %auto_features = $ph->{auto_features}->access();
660 while (my ($name, $info) = each %auto_features) {
661 my $failures = $self->prereq_failures($info);
662 my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
58fa6946 663 keys %$failures ) ? 1 : 0;
bb4e9162
YST
664 $features{$name} = $disabled ? 0 : 1;
665 }
666 %features = (%features, $ph->{features}->access());
667
668 return wantarray ? %features : \%features;
669}
7a827510 670BEGIN { *feature = \&features } # Alias
bb4e9162
YST
671
672sub _mb_feature {
673 my $self = shift;
613f422f 674
bb4e9162
YST
675 if (($self->module_name || '') eq 'Module::Build') {
676 # We're building Module::Build itself, so ...::ConfigData isn't
677 # valid, but $self->features() should be.
678 return $self->feature(@_);
679 } else {
680 require Module::Build::ConfigData;
681 return Module::Build::ConfigData->feature(@_);
682 }
683}
684
613f422f
DG
685sub _warn_mb_feature_deps {
686 my $self = shift;
687 my $name = shift;
688 $self->log_warn(
689 "The '$name' feature is not available. Please install missing\n" .
690 "feature dependencies and try again.\n".
691 $self->_feature_deps_msg($name) . "\n"
692 );
693}
bb4e9162
YST
694
695sub add_build_element {
696 my ($self, $elem) = @_;
697 my $elems = $self->build_elements;
698 push @$elems, $elem unless grep { $_ eq $elem } @$elems;
699}
700
701sub ACTION_config_data {
702 my $self = shift;
703 return unless $self->has_config_data;
613f422f 704
bb4e9162
YST
705 my $module_name = $self->module_name
706 or die "The config_data feature requires that 'module_name' be set";
707 my $notes_name = $module_name . '::ConfigData'; # TODO: Customize name ???
708 my $notes_pm = File::Spec->catfile($self->blib, 'lib', split /::/, "$notes_name.pm");
709
710 return if $self->up_to_date(['Build.PL',
58fa6946
CBW
711 $self->config_file('config_data'),
712 $self->config_file('features')
713 ], $notes_pm);
bb4e9162 714
613f422f 715 $self->log_verbose("Writing config notes to $notes_pm\n");
bb4e9162
YST
716 File::Path::mkpath(File::Basename::dirname($notes_pm));
717
718 Module::Build::Notes->write_config_data
58fa6946
CBW
719 (
720 file => $notes_pm,
721 module => $module_name,
722 config_module => $notes_name,
723 config_data => scalar $self->config_data,
724 feature => scalar $self->{phash}{features}->access(),
725 auto_features => scalar $self->auto_features,
726 );
bb4e9162
YST
727}
728
15cb7b9d 729########################################################################
613f422f 730{ # enclosing these lexicals -- TODO
15cb7b9d
SH
731 my %valid_properties = ( __PACKAGE__, {} );
732 my %additive_properties;
bb4e9162 733
15cb7b9d
SH
734 sub _mb_classes {
735 my $class = ref($_[0]) || $_[0];
736 return ($class, $class->mb_parents);
737 }
738
739 sub valid_property {
740 my ($class, $prop) = @_;
741 return grep exists( $valid_properties{$_}{$prop} ), $class->_mb_classes;
742 }
743
744 sub valid_properties {
745 return keys %{ shift->valid_properties_defaults() };
746 }
bb4e9162 747
15cb7b9d
SH
748 sub valid_properties_defaults {
749 my %out;
613f422f
DG
750 for my $class (reverse shift->_mb_classes) {
751 @out{ keys %{ $valid_properties{$class} } } = map {
15cb7b9d 752 $_->()
613f422f 753 } values %{ $valid_properties{$class} };
bb4e9162 754 }
15cb7b9d
SH
755 return \%out;
756 }
bb4e9162 757
15cb7b9d 758 sub array_properties {
46de787b 759 map { exists $additive_properties{$_}->{ARRAY} ? @{$additive_properties{$_}->{ARRAY}} : () } shift->_mb_classes;
15cb7b9d 760 }
bb4e9162 761
15cb7b9d 762 sub hash_properties {
46de787b 763 map { exists $additive_properties{$_}->{HASH} ? @{$additive_properties{$_}->{HASH}} : () } shift->_mb_classes;
15cb7b9d 764 }
bb4e9162 765
15cb7b9d
SH
766 sub add_property {
767 my ($class, $property) = (shift, shift);
768 die "Property '$property' already exists"
769 if $class->valid_property($property);
770 my %p = @_ == 1 ? ( default => shift ) : @_;
771
772 my $type = ref $p{default};
613f422f
DG
773 $valid_properties{$class}{$property} =
774 $type eq 'CODE' ? $p{default} :
775 $type eq 'HASH' ? sub { return { %{ $p{default} } } } :
776 $type eq 'ARRAY'? sub { return [ @{ $p{default} } ] } :
777 sub { return $p{default} } ;
15cb7b9d
SH
778
779 push @{$additive_properties{$class}->{$type}}, $property
780 if $type;
781
782 unless ($class->can($property)) {
783 # TODO probably should put these in a util package
784 my $sub = $type eq 'HASH'
785 ? _make_hash_accessor($property, \%p)
786 : _make_accessor($property, \%p);
787 no strict 'refs';
788 *{"$class\::$property"} = $sub;
bb4e9162
YST
789 }
790
15cb7b9d
SH
791 return $class;
792 }
793
46de787b
CBW
794 sub property_error {
795 my $self = shift;
796 die 'ERROR: ', @_;
797 }
bb4e9162 798
15cb7b9d
SH
799 sub _set_defaults {
800 my $self = shift;
bb4e9162 801
15cb7b9d
SH
802 # Set the build class.
803 $self->{properties}{build_class} ||= ref $self;
bb4e9162 804
15cb7b9d
SH
805 # If there was no orig_dir, set to the same as base_dir
806 $self->{properties}{orig_dir} ||= $self->{properties}{base_dir};
bb4e9162 807
15cb7b9d 808 my $defaults = $self->valid_properties_defaults;
bb4e9162 809
15cb7b9d
SH
810 foreach my $prop (keys %$defaults) {
811 $self->{properties}{$prop} = $defaults->{$prop}
812 unless exists $self->{properties}{$prop};
bb4e9162
YST
813 }
814
15cb7b9d
SH
815 # Copy defaults for arrays any arrays.
816 for my $prop ($self->array_properties) {
817 $self->{properties}{$prop} = [@{$defaults->{$prop}}]
818 unless exists $self->{properties}{$prop};
819 }
820 # Copy defaults for arrays any hashes.
821 for my $prop ($self->hash_properties) {
822 $self->{properties}{$prop} = {%{$defaults->{$prop}}}
823 unless exists $self->{properties}{$prop};
824 }
825 }
bb4e9162 826
46de787b 827} # end enclosure
15cb7b9d
SH
828########################################################################
829sub _make_hash_accessor {
830 my ($property, $p) = @_;
831 my $check = $p->{check} || sub { 1 };
bb4e9162 832
15cb7b9d
SH
833 return sub {
834 my $self = shift;
bb4e9162 835
15cb7b9d
SH
836 # This is only here to deprecate the historic accident of calling
837 # properties as class methods - I suspect it only happens in our
838 # test suite.
839 unless(ref($self)) {
840 carp("\n$property not a class method (@_)");
841 return;
842 }
843
844 my $x = $self->{properties};
845 return $x->{$property} unless @_;
846
847 my $prop = $x->{$property};
848 if ( defined $_[0] && !ref $_[0] ) {
849 if ( @_ == 1 ) {
850 return exists $prop->{$_[0]} ? $prop->{$_[0]} : undef;
851 } elsif ( @_ % 2 == 0 ) {
852 my %new = (%{ $prop }, @_);
853 local $_ = \%new;
854 $x->{$property} = \%new if $check->($self);
855 return $x->{$property};
856 } else {
857 die "Unexpected arguments for property '$property'\n";
bb4e9162 858 }
15cb7b9d
SH
859 } else {
860 die "Unexpected arguments for property '$property'\n"
861 if defined $_[0] && ref $_[0] ne 'HASH';
862 local $_ = $_[0];
863 $x->{$property} = shift if $check->($self);
bb4e9162 864 }
15cb7b9d
SH
865 };
866}
867########################################################################
868sub _make_accessor {
869 my ($property, $p) = @_;
870 my $check = $p->{check} || sub { 1 };
871
872 return sub {
873 my $self = shift;
bb4e9162 874
15cb7b9d
SH
875 # This is only here to deprecate the historic accident of calling
876 # properties as class methods - I suspect it only happens in our
877 # test suite.
878 unless(ref($self)) {
879 carp("\n$property not a class method (@_)");
880 return;
881 }
882
883 my $x = $self->{properties};
884 return $x->{$property} unless @_;
885 local $_ = $_[0];
886 $x->{$property} = shift if $check->($self);
887 return $x->{$property};
888 };
bb4e9162 889}
15cb7b9d 890########################################################################
bb4e9162
YST
891
892# Add the default properties.
23837600 893__PACKAGE__->add_property(auto_configure_requires => 1);
bb4e9162
YST
894__PACKAGE__->add_property(blib => 'blib');
895__PACKAGE__->add_property(build_class => 'Module::Build');
613f422f 896__PACKAGE__->add_property(build_elements => [qw(PL support pm xs share_dir pod script)]);
bb4e9162
YST
897__PACKAGE__->add_property(build_script => 'Build');
898__PACKAGE__->add_property(build_bat => 0);
613f422f
DG
899__PACKAGE__->add_property(bundle_inc => []);
900__PACKAGE__->add_property(bundle_inc_preload => []);
bb4e9162 901__PACKAGE__->add_property(config_dir => '_build');
a7c7ab1e 902__PACKAGE__->add_property(dynamic_config => 1);
bb4e9162 903__PACKAGE__->add_property(include_dirs => []);
613f422f 904__PACKAGE__->add_property(license => 'unknown');
bb4e9162 905__PACKAGE__->add_property(metafile => 'META.yml');
613f422f 906__PACKAGE__->add_property(mymetafile => 'MYMETA.yml');
a7c7ab1e
DG
907__PACKAGE__->add_property(metafile2 => 'META.json');
908__PACKAGE__->add_property(mymetafile2 => 'MYMETA.json');
bb4e9162
YST
909__PACKAGE__->add_property(recurse_into => []);
910__PACKAGE__->add_property(use_rcfile => 1);
a314697d 911__PACKAGE__->add_property(create_packlist => 1);
0ec9ad96 912__PACKAGE__->add_property(allow_mb_mismatch => 0);
77e96e88 913__PACKAGE__->add_property(config => undef);
738349a8
SH
914__PACKAGE__->add_property(test_file_exts => ['.t']);
915__PACKAGE__->add_property(use_tap_harness => 0);
613f422f 916__PACKAGE__->add_property(cpan_client => 'cpan');
738349a8 917__PACKAGE__->add_property(tap_harness_args => {});
ee76e757
CBW
918__PACKAGE__->add_property(pureperl_only => 0);
919__PACKAGE__->add_property(allow_pureperl => 0);
15cb7b9d
SH
920__PACKAGE__->add_property(
921 'installdirs',
922 default => 'site',
923 check => sub {
924 return 1 if /^(core|site|vendor)$/;
925 return shift->property_error(
926 $_ eq 'perl'
927 ? 'Perhaps you meant installdirs to be "core" rather than "perl"?'
928 : 'installdirs must be one of "core", "site", or "vendor"'
929 );
930 return shift->property_error("Perhaps you meant 'core'?") if $_ eq 'perl';
931 return 0;
932 },
933);
bb4e9162
YST
934
935{
7cf8bfc0 936 __PACKAGE__->add_property(html_css => '');
bb4e9162
YST
937}
938
939{
ee76e757 940 my @prereq_action_types = qw(requires build_requires test_requires conflicts recommends);
bb4e9162
YST
941 foreach my $type (@prereq_action_types) {
942 __PACKAGE__->add_property($type => {});
943 }
944 __PACKAGE__->add_property(prereq_action_types => \@prereq_action_types);
945}
946
947__PACKAGE__->add_property($_ => {}) for qw(
bb4e9162
YST
948 get_options
949 install_base_relpaths
950 install_path
951 install_sets
952 meta_add
953 meta_merge
954 original_prefix
955 prefix_relpaths
7a827510 956 configure_requires
bb4e9162
YST
957);
958
959__PACKAGE__->add_property($_) for qw(
960 PL_files
961 autosplit
962 base_dir
963 bindoc_dirs
964 c_source
15cb7b9d 965 create_license
bb4e9162
YST
966 create_makefile_pl
967 create_readme
968 debugger
969 destdir
970 dist_abstract
971 dist_author
972 dist_name
7cf8bfc0 973 dist_suffix
bb4e9162
YST
974 dist_version
975 dist_version_from
976 extra_compiler_flags
977 extra_linker_flags
978 has_config_data
979 install_base
980 libdoc_dirs
bb4e9162
YST
981 magic_number
982 mb_version
983 module_name
613f422f 984 needs_compiler
bb4e9162
YST
985 orig_dir
986 perl
987 pm_files
988 pod_files
989 pollute
990 prefix
738349a8 991 program_name
bb4e9162
YST
992 quiet
993 recursive_test_files
7cf8bfc0 994 release_status
bb4e9162
YST
995 script_files
996 scripts
613f422f 997 share_dir
738349a8 998 sign
bb4e9162
YST
999 test_files
1000 verbose
4085a377 1001 debug
bb4e9162 1002 xs_files
46de787b 1003 extra_manify_args
bb4e9162
YST
1004);
1005
77e96e88
RGS
1006sub 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}
bb4e9162
YST
1017
1018sub 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
1047sub extra_linker_flags { shift->_list_accessor('extra_linker_flags', @_) }
1048sub extra_compiler_flags { shift->_list_accessor('extra_compiler_flags', @_) }
1049
1050sub _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.
1060sub 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';
613f422f 1071
bb4e9162
YST
1072 my $filename = File::Spec->catfile($build_dir, 'lib', split '::', $opts{class}) . '.pm';
1073 my $filedir = File::Basename::dirname($filename);
613f422f
DG
1074 $pack->log_verbose("Creating custom builder $filename in $filedir\n");
1075
bb4e9162
YST
1076 File::Path::mkpath($filedir);
1077 die "Can't create directory $filedir: $!" unless -d $filedir;
613f422f 1078
46de787b 1079 open(my $fh, '>', $filename) or die "Can't create $filename: $!";
bb4e9162
YST
1080 print $fh <<EOF;
1081package $opts{class};
1082use $pack;
1083\@ISA = qw($pack);
1084$opts{code}
10851;
1086EOF
1087 close $fh;
613f422f 1088
bb4e9162
YST
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
613f422f
DG
1096sub _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 {
53fc1c7e 1105 my $mod_path = my $mod_name = $p->{dist_name};
613f422f
DG
1106 $mod_name =~ s{-}{::}g;
1107 $mod_path =~ s{-}{/}g;
1108 $mod_path .= ".pm";
53fc1c7e 1109 if ( -e $mod_path || -e "lib/$mod_path" ) {
613f422f
DG
1110 $p->{module_name} = $mod_name;
1111 }
1112 else {
1113 $self->log_warn( << 'END_WARN' );
1114No 'module_name' was provided and it could not be inferred
1115from other properties. This will prevent a packlist from
1116being written for this file. Please set either 'module_name'
1117or 'dist_version_from' in Build.PL.
1118END_WARN
1119 }
1120 }
1121}
1122
bb4e9162
YST
1123sub dist_name {
1124 my $self = shift;
1125 my $p = $self->{properties};
46de787b
CBW
1126 my $me = 'dist_name';
1127 return $p->{$me} if defined $p->{$me};
613f422f 1128
bb4e9162 1129 die "Can't determine distribution name, must supply either 'dist_name' or 'module_name' parameter"
47f13fd5 1130 unless $self->module_name;
613f422f 1131
46de787b 1132 ($p->{$me} = $self->module_name) =~ s/::/-/g;
613f422f 1133
46de787b 1134 return $p->{$me};
bb4e9162
YST
1135}
1136
7cf8bfc0
DG
1137sub release_status {
1138 my ($self) = @_;
46de787b 1139 my $me = 'release_status';
7cf8bfc0
DG
1140 my $p = $self->{properties};
1141
46de787b
CBW
1142 if ( ! defined $p->{$me} ) {
1143 $p->{$me} = $self->_is_dev_version ? 'testing' : 'stable';
7cf8bfc0
DG
1144 }
1145
46de787b
CBW
1146 unless ( $p->{$me} =~ qr/\A(?:stable|testing|unstable)\z/ ) {
1147 die "Illegal value '$p->{$me}' for $me\n";
7cf8bfc0
DG
1148 }
1149
46de787b 1150 if ( $p->{$me} eq 'stable' && $self->_is_dev_version ) {
7cf8bfc0 1151 my $version = $self->dist_version;
46de787b 1152 die "Illegal value '$p->{$me}' with version '$version'\n";
7cf8bfc0 1153 }
46de787b 1154 return $p->{$me};
7cf8bfc0
DG
1155}
1156
1157sub dist_suffix {
1158 my ($self) = @_;
1159 my $p = $self->{properties};
46de787b
CBW
1160 my $me = 'dist_suffix';
1161
1162 return $p->{$me} if defined $p->{$me};
7cf8bfc0
DG
1163
1164 if ( $self->release_status eq 'stable' ) {
46de787b 1165 $p->{$me} = "";
7cf8bfc0
DG
1166 }
1167 else {
1168 # non-stable release but non-dev version number needs '-TRIAL' appended
46de787b 1169 $p->{$me} = $self->_is_dev_version ? "" : "TRIAL" ;
7cf8bfc0
DG
1170 }
1171
46de787b 1172 return $p->{$me};
7cf8bfc0
DG
1173}
1174
47f13fd5 1175sub dist_version_from {
bb4e9162
YST
1176 my ($self) = @_;
1177 my $p = $self->{properties};
46de787b
CBW
1178 my $me = 'dist_version_from';
1179
bb4e9162 1180 if ($self->module_name) {
46de787b 1181 $p->{$me} ||=
58fa6946 1182 join( '/', 'lib', split(/::/, $self->module_name) ) . '.pm';
bb4e9162 1183 }
46de787b 1184 return $p->{$me} || undef;
bb4e9162
YST
1185}
1186
1187sub dist_version {
1188 my ($self) = @_;
1189 my $p = $self->{properties};
46de787b 1190 my $me = 'dist_version';
bb4e9162 1191
46de787b 1192 return $p->{$me} if defined $p->{$me};
bb4e9162 1193
47f13fd5
SP
1194 if ( my $dist_version_from = $self->dist_version_from ) {
1195 my $version_from = File::Spec->catfile( split( qr{/}, $dist_version_from ) );
bb4e9162
YST
1196 my $pm_info = Module::Build::ModuleInfo->new_from_file( $version_from )
1197 or die "Can't find file $version_from to determine version";
46de787b
CBW
1198 #$p->{$me} is undef here
1199 $p->{$me} = $self->normalize_version( $pm_info->version() );
1200 unless (defined $p->{$me}) {
7cf8bfc0
DG
1201 die "Can't determine distribution version from $version_from";
1202 }
bb4e9162
YST
1203 }
1204
1205 die ("Can't determine distribution version, must supply either 'dist_version',\n".
1206 "'dist_version_from', or 'module_name' parameter")
46de787b 1207 unless defined $p->{$me};
bb4e9162 1208
46de787b 1209 return $p->{$me};
bb4e9162
YST
1210}
1211
7cf8bfc0
DG
1212sub _is_dev_version {
1213 my ($self) = @_;
1214 my $dist_version = $self->dist_version;
1215 my $version_obj = eval { Module::Build::Version->new( $dist_version ) };
1216 # assume it's normal if the version string is fatal -- in this case
1217 # the author might be doing something weird so should play along and
1218 # assume they'll specify all necessary behavior
1219 return $@ ? 0 : $version_obj->is_alpha;
1220}
1221
bb4e9162
YST
1222sub dist_author { shift->_pod_parse('author') }
1223sub dist_abstract { shift->_pod_parse('abstract') }
1224
1225sub _pod_parse {
1226 my ($self, $part) = @_;
1227 my $p = $self->{properties};
1228 my $member = "dist_$part";
1229 return $p->{$member} if defined $p->{$member};
613f422f 1230
bb4e9162
YST
1231 my $docfile = $self->_main_docfile
1232 or return;
46de787b 1233 open(my $fh, '<', $docfile)
bb4e9162 1234 or return;
613f422f 1235
bb4e9162
YST
1236 require Module::Build::PodParser;
1237 my $parser = Module::Build::PodParser->new(fh => $fh);
1238 my $method = "get_$part";
1239 return $p->{$member} = $parser->$method();
1240}
1241
23837600 1242sub version_from_file { # Method provided for backwards compatibility
bb4e9162
YST
1243 return Module::Build::ModuleInfo->new_from_file($_[1])->version();
1244}
1245
23837600 1246sub find_module_by_name { # Method provided for backwards compatibility
bb4e9162
YST
1247 return Module::Build::ModuleInfo->find_module_by_name(@_[1,2]);
1248}
1249
7cf8bfc0
DG
1250{
1251 # $unlink_list_for_pid{$$} = [ ... ]
1252 my %unlink_list_for_pid;
1253
1254 sub _unlink_on_exit {
1255 my $self = shift;
1256 for my $f ( @_ ) {
1257 push @{$unlink_list_for_pid{$$}}, $f if -f $f;
1258 }
1259 return 1;
1260 }
1261
1262 END {
1263 for my $f ( map glob($_), @{ $unlink_list_for_pid{$$} || [] } ) {
1264 next unless -e $f;
1265 File::Path::rmtree($f, 0, 0);
1266 }
1267 }
1268}
1269
bb4e9162
YST
1270sub add_to_cleanup {
1271 my $self = shift;
1272 my %files = map {$self->localize_file_path($_), 1} @_;
1273 $self->{phash}{cleanup}->write(\%files);
1274}
1275
1276sub cleanup {
1277 my $self = shift;
1278 my $all = $self->{phash}{cleanup}->read;
1279 return keys %$all;
1280}
1281
1282sub config_file {
1283 my $self = shift;
1284 return unless -d $self->config_dir;
1285 return File::Spec->catfile($self->config_dir, @_);
1286}
1287
1288sub read_config {
1289 my ($self) = @_;
613f422f 1290
bb4e9162 1291 my $file = $self->config_file('build_params')
7253302f 1292 or die "Can't find 'build_params' in " . $self->config_dir;
46de787b 1293 open(my $fh, '<', $file) or die "Can't read '$file': $!";
bb4e9162
YST
1294 my $ref = eval do {local $/; <$fh>};
1295 die if $@;
46de787b 1296 close $fh;
77e96e88
RGS
1297 my $c;
1298 ($self->{args}, $c, $self->{properties}) = @$ref;
1299 $self->{config} = Module::Build::Config->new(values => $c);
bb4e9162
YST
1300}
1301
1302sub has_config_data {
1303 my $self = shift;
1304 return scalar grep $self->{phash}{$_}->has_data(), qw(config_data features auto_features);
1305}
1306
1307sub _write_data {
1308 my ($self, $filename, $data) = @_;
613f422f 1309
bb4e9162 1310 my $file = $self->config_file($filename);
46de787b 1311 open(my $fh, '>', $file) or die "Can't create '$file': $!";
7a827510
RGS
1312 unless (ref($data)) { # e.g. magicnum
1313 print $fh $data;
1314 return;
1315 }
1316
1317 print {$fh} Module::Build::Dumper->_data_dump($data);
46de787b 1318 close $fh;
bb4e9162
YST
1319}
1320
1321sub write_config {
1322 my ($self) = @_;
613f422f 1323
bb4e9162
YST
1324 File::Path::mkpath($self->{properties}{config_dir});
1325 -d $self->{properties}{config_dir} or die "Can't mkdir $self->{properties}{config_dir}: $!";
613f422f 1326
bb4e9162
YST
1327 my @items = @{ $self->prereq_action_types };
1328 $self->_write_data('prereqs', { map { $_, $self->$_() } @items });
77e96e88 1329 $self->_write_data('build_params', [$self->{args}, $self->{config}->values_set, $self->{properties}]);
bb4e9162
YST
1330
1331 # Set a new magic number and write it to a file
1332 $self->_write_data('magicnum', $self->magic_number(int rand 1_000_000));
1333
1334 $self->{phash}{$_}->write() foreach qw(notes cleanup features auto_features config_data runtime_params);
1335}
1336
613f422f
DG
1337{
1338 # packfile map -- keys are guts of regular expressions; If they match,
1339 # values are module names corresponding to the packlist
1340 my %packlist_map = (
1341 '^File::Spec' => 'Cwd',
1342 '^Devel::AssertOS' => 'Devel::CheckOS',
1343 );
1344
1345 sub _find_packlist {
1346 my ($self, $inst, $mod) = @_;
1347 my $lookup = $mod;
1348 my $packlist = eval { $inst->packlist($lookup) };
1349 if ( ! $packlist ) {
1350 # try from packlist_map
1351 while ( my ($re, $new_mod) = each %packlist_map ) {
1352 if ( $mod =~ qr/$re/ ) {
1353 $lookup = $new_mod;
1354 $packlist = eval { $inst->packlist($lookup) };
1355 last;
1356 }
1357 }
1358 }
1359 return $packlist ? $lookup : undef;
1360 }
1361
1362 sub set_bundle_inc {
1363 my $self = shift;
1364
1365 my $bundle_inc = $self->{properties}{bundle_inc};
1366 my $bundle_inc_preload = $self->{properties}{bundle_inc_preload};
1367 # We're in author mode if inc::latest is loaded, but not from cwd
1368 return unless inc::latest->can('loaded_modules');
1369 require ExtUtils::Installed;
1370 # ExtUtils::Installed is buggy about finding additions to default @INC
53fc1c7e
DG
1371 my $inst = eval { ExtUtils::Installed->new(extra_libs => [@INC]) };
1372 if ($@) {
1373 $self->log_warn( << "EUI_ERROR" );
1374Bundling in inc/ is disabled because ExtUtils::Installed could not
1375create a list of your installed modules. Here is the error:
1376$@
1377EUI_ERROR
1378 return;
1379 }
613f422f
DG
1380 my @bundle_list = map { [ $_, 0 ] } inc::latest->loaded_modules;
1381
1382 # XXX TODO: Need to get ordering of prerequisites correct so they are
1383 # are loaded in the right order. Use an actual tree?!
1384
1385 while( @bundle_list ) {
1386 my ($mod, $prereq) = @{ shift @bundle_list };
1387
1388 # XXX TODO: Append prereqs to list
1389 # skip if core or already in bundle or preload lists
1390 # push @bundle_list, [$_, 1] for prereqs()
1391
1392 # Locate packlist for bundling
1393 my $lookup = $self->_find_packlist($inst,$mod);
1394 if ( ! $lookup ) {
1395 # XXX Really needs a more helpful error message here
1396 die << "NO_PACKLIST";
1397Could not find a packlist for '$mod'. If it's a core module, try
1398force installing it from CPAN.
1399NO_PACKLIST
1400 }
1401 else {
1402 push @{ $prereq ? $bundle_inc_preload : $bundle_inc }, $lookup;
1403 }
1404 }
1405 } # sub check_bundling
1406}
1407
bb4e9162
YST
1408sub check_autofeatures {
1409 my ($self) = @_;
1410 my $features = $self->auto_features;
bb4e9162 1411
613f422f 1412 return 1 unless %$features;
bb4e9162 1413
15cb7b9d
SH
1414 # TODO refactor into ::Util
1415 my $longest = sub {
1416 my @str = @_ or croak("no strings given");
1417
1418 my @len = map({length($_)} @str);
1419 my $max = 0;
1420 my $longest;
1421 for my $i (0..$#len) {
1422 ($max, $longest) = ($len[$i], $str[$i]) if($len[$i] > $max);
1423 }
1424 return($longest);
1425 };
1426 my $max_name_len = length($longest->(keys %$features));
bb4e9162 1427
613f422f
DG
1428 my ($num_disabled, $log_text) = (0, "\nChecking optional features...\n");
1429 for my $name ( sort keys %$features ) {
1430 $log_text .= $self->_feature_deps_msg($name, $max_name_len);
1431 }
1432
1433 $num_disabled = () = $log_text =~ /disabled/g;
1434
1435 # warn user if features disabled
1436 if ( $num_disabled ) {
1437 $self->log_warn( $log_text );
1438 return 0;
1439 }
1440 else {
1441 $self->log_verbose( $log_text );
1442 return 1;
1443 }
1444}
1445
1446sub _feature_deps_msg {
1447 my ($self, $name, $max_name_len) = @_;
1448 $max_name_len ||= length $name;
1449 my $features = $self->auto_features;
1450 my $info = $features->{$name};
1451 my $feature_text = "$name" . '.' x ($max_name_len - length($name) + 4);
bb4e9162 1452
613f422f 1453 my ($log_text, $disabled) = ('','');
bb4e9162 1454 if ( my $failures = $self->prereq_failures($info) ) {
613f422f
DG
1455 $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
1456 keys %$failures ) ? 1 : 0;
1457 $feature_text .= $disabled ? "disabled\n" : "enabled\n";
1458
1459 for my $type ( @{ $self->prereq_action_types } ) {
1460 next unless exists $failures->{$type};
1461 $feature_text .= " $type:\n";
1462 my $prereqs = $failures->{$type};
1463 for my $module ( sort keys %$prereqs ) {
1464 my $status = $prereqs->{$module};
1465 my $required =
1466 ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0;
1467 my $prefix = ($required) ? '!' : '*';
1468 $feature_text .= " $prefix $status->{message}\n";
1469 }
bb4e9162 1470 }
bb4e9162 1471 } else {
613f422f
DG
1472 $feature_text .= "enabled\n";
1473 }
1474 $log_text .= $feature_text if $disabled || $self->verbose;
1475 return $log_text;
1476}
1477
7cf8bfc0
DG
1478# Automatically detect configure_requires prereqs
1479sub auto_config_requires {
613f422f
DG
1480 my ($self) = @_;
1481 my $p = $self->{properties};
1482
1483 # add current Module::Build to configure_requires if there
1484 # isn't one already specified (but not ourself, so we're not circular)
1485 if ( $self->dist_name ne 'Module-Build'
1486 && $self->auto_configure_requires
1487 && ! exists $p->{configure_requires}{'Module::Build'}
1488 ) {
1489 (my $ver = $VERSION) =~ s/^(\d+\.\d\d).*$/$1/; # last major release only
7cf8bfc0
DG
1490 $self->log_warn(<<EOM);
1491Module::Build was not found in configure_requires! Adding it now
1492automatically as: configure_requires => { 'Module::Build' => $ver }
1493EOM
613f422f
DG
1494 $self->_add_prereq('configure_requires', 'Module::Build', $ver);
1495 }
1496
1497 # if we're in author mode, add inc::latest modules to
1498 # configure_requires if not already set. If we're not in author mode
1499 # then configure_requires will have been satisfied, or we'll just
1500 # live with what we've bundled
1501 if ( inc::latest->can('loaded_module') ) {
1502 for my $mod ( inc::latest->loaded_modules ) {
1503 next if exists $p->{configure_requires}{$mod};
1504 $self->_add_prereq('configure_requires', $mod, $mod->VERSION);
bb4e9162
YST
1505 }
1506 }
1507
7cf8bfc0
DG
1508 return;
1509}
1510
1511# Automatically detect and add prerequisites based on configuration
1512sub auto_require {
1513 my ($self) = @_;
1514 my $p = $self->{properties};
1515
46de787b 1516 # If needs_compiler is not explicitly set, automatically set it
613f422f
DG
1517 # If set, we need ExtUtils::CBuilder (and a compiler)
1518 my $xs_files = $self->find_xs_files;
1519 if ( ! defined $p->{needs_compiler} ) {
1520 $self->needs_compiler( keys %$xs_files || defined $self->c_source );
1521 }
1522 if ($self->needs_compiler) {
1523 $self->_add_prereq('build_requires', 'ExtUtils::CBuilder', 0);
1524 if ( ! $self->have_c_compiler ) {
1525 $self->log_warn(<<'EOM');
1526Warning: ExtUtils::CBuilder not installed or no compiler detected
1527Proceeding with configuration, but compilation may fail during Build
1528
1529EOM
1530 }
1531 }
1532
1533 # If using share_dir, require File::ShareDir
1534 if ( $self->share_dir ) {
1535 $self->_add_prereq( 'requires', 'File::ShareDir', '1.00' );
1536 }
1537
1538 return;
1539}
1540
1541sub _add_prereq {
1542 my ($self, $type, $module, $version) = @_;
1543 my $p = $self->{properties};
1544 $version = 0 unless defined $version;
1545 if ( exists $p->{$type}{$module} ) {
1546 return if $self->compare_versions( $version, '<=', $p->{$type}{$module} );
1547 }
1548 $self->log_verbose("Adding to $type\: $module => $version\n");
1549 $p->{$type}{$module} = $version;
1550 return 1;
bb4e9162
YST
1551}
1552
1553sub prereq_failures {
1554 my ($self, $info) = @_;
1555
1556 my @types = @{ $self->prereq_action_types };
1557 $info ||= {map {$_, $self->$_()} @types};
1558
1559 my $out;
1560
1561 foreach my $type (@types) {
1562 my $prereqs = $info->{$type};
613f422f
DG
1563 for my $modname ( keys %$prereqs ) {
1564 my $spec = $prereqs->{$modname};
bb4e9162
YST
1565 my $status = $self->check_installed_status($modname, $spec);
1566
1567 if ($type =~ /^(?:\w+_)?conflicts$/) {
58fa6946
CBW
1568 next if !$status->{ok};
1569 $status->{conflicts} = delete $status->{need};
1570 $status->{message} = "$modname ($status->{have}) conflicts with this distribution";
bb4e9162
YST
1571
1572 } elsif ($type =~ /^(?:\w+_)?recommends$/) {
58fa6946
CBW
1573 next if $status->{ok};
1574 $status->{message} = (!ref($status->{have}) && $status->{have} eq '<none>'
1575 ? "$modname is not installed"
1576 : "$modname ($status->{have}) is installed, but we prefer to have $spec");
bb4e9162 1577 } else {
58fa6946 1578 next if $status->{ok};
bb4e9162
YST
1579 }
1580
1581 $out->{$type}{$modname} = $status;
1582 }
1583 }
1584
1585 return $out;
1586}
1587
1588# returns a hash of defined prerequisites; i.e. only prereq types with values
1589sub _enum_prereqs {
1590 my $self = shift;
1591 my %prereqs;
1592 foreach my $type ( @{ $self->prereq_action_types } ) {
1593 if ( $self->can( $type ) ) {
1594 my $prereq = $self->$type() || {};
1595 $prereqs{$type} = $prereq if %$prereq;
1596 }
1597 }
1598 return \%prereqs;
1599}
1600
1601sub check_prereq {
1602 my $self = shift;
1603
bb4e9162
YST
1604 # Check to see if there are any prereqs to check
1605 my $info = $self->_enum_prereqs;
1606 return 1 unless $info;
1607
613f422f 1608 my $log_text = "Checking prerequisites...\n";
bb4e9162
YST
1609
1610 my $failures = $self->prereq_failures($info);
1611
1612 if ( $failures ) {
613f422f
DG
1613 $self->log_warn($log_text);
1614 for my $type ( @{ $self->prereq_action_types } ) {
1615 my $prereqs = $failures->{$type};
1616 $self->log_warn(" ${type}:\n") if keys %$prereqs;
1617 for my $module ( sort keys %$prereqs ) {
1618 my $status = $prereqs->{$module};
1619 my $prefix = ($type =~ /^(?:\w+_)?recommends$/) ? "* " : "! ";
1620 $self->log_warn(" $prefix $status->{message}\n");
bb4e9162
YST
1621 }
1622 }
bb4e9162 1623 return 0;
bb4e9162 1624 } else {
613f422f 1625 $self->log_verbose($log_text . "Looks good\n\n");
bb4e9162 1626 return 1;
bb4e9162
YST
1627 }
1628}
1629
1630sub perl_version {
1631 my ($self) = @_;
1632 # Check the current perl interpreter
1633 # It's much more convenient to use $] here than $^V, but 'man
1634 # perlvar' says I'm not supposed to. Bloody tyrant.
1635 return $^V ? $self->perl_version_to_float(sprintf "%vd", $^V) : $];
1636}
1637
1638sub perl_version_to_float {
1639 my ($self, $version) = @_;
7a827510 1640 return $version if grep( /\./, $version ) < 2;
bb4e9162
YST
1641 $version =~ s/\./../;
1642 $version =~ s/\.(\d+)/sprintf '%03d', $1/eg;
1643 return $version;
1644}
1645
1646sub _parse_conditions {
1647 my ($self, $spec) = @_;
1648
1ce5ed3e 1649 return ">= 0" if not defined $spec;
bb4e9162
YST
1650 if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores
1651 return (">= $spec");
1652 } else {
1653 return split /\s*,\s*/, $spec;
1654 }
1655}
1656
7cf8bfc0
DG
1657sub try_require {
1658 my ($self, $modname, $spec) = @_;
1659 my $status = $self->check_installed_status($modname, defined($spec) ? $spec : 0);
1660 return unless $status->{ok};
1661 my $path = $modname;
1662 $path =~ s{::}{/}g;
1663 $path .= ".pm";
1664 if ( defined $INC{$path} ) {
1665 return 1;
1666 }
1667 elsif ( exists $INC{$path} ) { # failed before, don't try again
1668 return;
1669 }
1670 else {
1671 return eval "require $modname";
1672 }
1673}
1674
bb4e9162
YST
1675sub check_installed_status {
1676 my ($self, $modname, $spec) = @_;
1677 my %status = (need => $spec);
613f422f 1678
bb4e9162
YST
1679 if ($modname eq 'perl') {
1680 $status{have} = $self->perl_version;
613f422f 1681
bb4e9162
YST
1682 } elsif (eval { no strict; $status{have} = ${"${modname}::VERSION"} }) {
1683 # Don't try to load if it's already loaded
613f422f 1684
bb4e9162
YST
1685 } else {
1686 my $pm_info = Module::Build::ModuleInfo->new_from_module( $modname );
1687 unless (defined( $pm_info )) {
1688 @status{ qw(have message) } = ('<none>', "$modname is not installed");
1689 return \%status;
1690 }
613f422f 1691
7cf8bfc0 1692 $status{have} = eval { $pm_info->version() };
7a827510 1693 if ($spec and !defined($status{have})) {
bb4e9162
YST
1694 @status{ qw(have message) } = (undef, "Couldn't find a \$VERSION in prerequisite $modname");
1695 return \%status;
1696 }
1697 }
613f422f 1698
bb4e9162 1699 my @conditions = $self->_parse_conditions($spec);
613f422f 1700
bb4e9162
YST
1701 foreach (@conditions) {
1702 my ($op, $version) = /^\s* (<=?|>=?|==|!=) \s* ([\w.]+) \s*$/x
1703 or die "Invalid prerequisite condition '$_' for $modname";
613f422f 1704
bb4e9162
YST
1705 $version = $self->perl_version_to_float($version)
1706 if $modname eq 'perl';
613f422f 1707
bb4e9162 1708 next if $op eq '>=' and !$version; # Module doesn't have to actually define a $VERSION
613f422f 1709
bb4e9162
YST
1710 unless ($self->compare_versions( $status{have}, $op, $version )) {
1711 $status{message} = "$modname ($status{have}) is installed, but we need version $op $version";
1712 return \%status;
1713 }
1714 }
613f422f 1715
bb4e9162
YST
1716 $status{ok} = 1;
1717 return \%status;
1718}
1719
1720sub compare_versions {
1721 my $self = shift;
1722 my ($v1, $op, $v2) = @_;
613f422f 1723 $v1 = Module::Build::Version->new($v1)
b3dfda33 1724 unless UNIVERSAL::isa($v1,'Module::Build::Version');
bb4e9162
YST
1725
1726 my $eval_str = "\$v1 $op \$v2";
1727 my $result = eval $eval_str;
1728 $self->log_warn("error comparing versions: '$eval_str' $@") if $@;
1729
1730 return $result;
1731}
1732
1733# I wish I could set $! to a string, but I can't, so I use $@
1734sub check_installed_version {
1735 my ($self, $modname, $spec) = @_;
613f422f 1736
bb4e9162 1737 my $status = $self->check_installed_status($modname, $spec);
613f422f 1738
bb4e9162 1739 if ($status->{ok}) {
738349a8 1740 return $status->{have} if $status->{have} and "$status->{have}" ne '<none>';
bb4e9162
YST
1741 return '0 but true';
1742 }
613f422f 1743
bb4e9162
YST
1744 $@ = $status->{message};
1745 return 0;
1746}
1747
1748sub make_executable {
1749 # Perl's chmod() is mapped to useful things on various non-Unix
1750 # platforms, so we use it in the base class even though it looks
1751 # Unixish.
1752
1753 my $self = shift;
1754 foreach (@_) {
1755 my $current_mode = (stat $_)[2];
77e96e88 1756 chmod $current_mode | oct(111), $_;
bb4e9162
YST
1757 }
1758}
1759
f943a5bf
SP
1760sub is_executable {
1761 # We assume this does the right thing on generic platforms, though
1762 # we do some other more specific stuff on Unixish platforms.
1763 my ($self, $file) = @_;
1764 return -x $file;
1765}
1766
bb4e9162
YST
1767sub _startperl { shift()->config('startperl') }
1768
1769# Return any directories in @INC which are not in the default @INC for
1770# this perl. For example, stuff passed in with -I or loaded with "use lib".
1771sub _added_to_INC {
1772 my $self = shift;
1773
1774 my %seen;
1775 $seen{$_}++ foreach $self->_default_INC;
1776 return grep !$seen{$_}++, @INC;
1777}
1778
1779# Determine the default @INC for this Perl
1780{
1781 my @default_inc; # Memoize
1782 sub _default_INC {
1783 my $self = shift;
1784 return @default_inc if @default_inc;
613f422f 1785
bb4e9162 1786 local $ENV{PERL5LIB}; # this is not considered part of the default.
613f422f 1787
bb4e9162 1788 my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
613f422f 1789
a314697d 1790 my @inc = $self->_backticks($perl, '-le', 'print for @INC');
bb4e9162 1791 chomp @inc;
613f422f 1792
bb4e9162
YST
1793 return @default_inc = @inc;
1794 }
1795}
1796
1797sub print_build_script {
1798 my ($self, $fh) = @_;
613f422f 1799
bb4e9162 1800 my $build_package = $self->build_class;
613f422f 1801
bb4e9162
YST
1802 my $closedata="";
1803
7cf8bfc0
DG
1804 my $config_requires;
1805 if ( -f $self->metafile ) {
1806 my $meta = eval { $self->read_metafile( $self->metafile ) };
1807 $config_requires = $meta && $meta->{configure_requires}{'Module::Build'};
1808 }
1809 $config_requires ||= 0;
1810
bb4e9162
YST
1811 my %q = map {$_, $self->$_()} qw(config_dir base_dir);
1812
7a827510 1813 $q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish;
bb4e9162
YST
1814
1815 $q{magic_numfile} = $self->config_file('magicnum');
1816
1817 my @myINC = $self->_added_to_INC;
1818 for (@myINC, values %q) {
ee76e757 1819 $_ = File::Spec->canonpath( $_ ) unless $self->is_vmsish;
bb4e9162
YST
1820 s/([\\\'])/\\$1/g;
1821 }
1822
1823 my $quoted_INC = join ",\n", map " '$_'", @myINC;
1824 my $shebang = $self->_startperl;
1825 my $magic_number = $self->magic_number;
1826
1827 print $fh <<EOF;
1828$shebang
1829
1830use strict;
1831use Cwd;
1832use File::Basename;
1833use File::Spec;
1834
1835sub magic_number_matches {
1836 return 0 unless -e '$q{magic_numfile}';
46de787b
CBW
1837 my \$FH;
1838 open \$FH, '<','$q{magic_numfile}' or return 0;
1839 my \$filenum = <\$FH>;
1840 close \$FH;
bb4e9162
YST
1841 return \$filenum == $magic_number;
1842}
1843
1844my \$progname;
1845my \$orig_dir;
1846BEGIN {
1847 \$^W = 1; # Use warnings
1848 \$progname = basename(\$0);
1849 \$orig_dir = Cwd::cwd();
1850 my \$base_dir = '$q{base_dir}';
1851 if (!magic_number_matches()) {
1852 unless (chdir(\$base_dir)) {
1853 die ("Couldn't chdir(\$base_dir), aborting\\n");
1854 }
1855 unless (magic_number_matches()) {
1856 die ("Configuration seems to be out of date, please re-run 'perl Build.PL' again.\\n");
1857 }
1858 }
1859 unshift \@INC,
1860 (
1861$quoted_INC
1862 );
1863}
1864
1865close(*DATA) unless eof(*DATA); # ensure no open handles to this script
1866
1867use $build_package;
7cf8bfc0 1868Module::Build->VERSION(q{$config_requires});
bb4e9162
YST
1869
1870# Some platforms have problems setting \$^X in shebang contexts, fix it up here
a314697d 1871\$^X = Module::Build->find_perl_interpreter;
bb4e9162
YST
1872
1873if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) {
1874 warn "Warning: Build.PL has been altered. You may need to run 'perl Build.PL' again.\\n";
1875}
1876
1877# This should have just enough arguments to be able to bootstrap the rest.
1878my \$build = $build_package->resume (
1879 properties => {
1880 config_dir => '$q{config_dir}',
1881 orig_dir => \$orig_dir,
1882 },
1883);
1884
1885\$build->dispatch;
1886EOF
1887}
1888
53fc1c7e 1889sub create_mymeta {
bb4e9162 1890 my ($self) = @_;
53fc1c7e 1891
a7c7ab1e
DG
1892 my ($meta_obj, $mymeta);
1893 my @metafiles = ( $self->metafile, $self->metafile2 );
1894 my @mymetafiles = ( $self->mymetafile, $self->mymetafile2 );
1895
1896 # cleanup old MYMETA
1897 for my $f ( @mymetafiles ) {
1898 if ( $self->delete_filetree($f) ) {
1899 $self->log_verbose("Removed previous '$f'\n");
1900 }
613f422f 1901 }
53fc1c7e 1902
a7c7ab1e
DG
1903 # Try loading META.json or META.yml
1904 if ( $self->try_require("CPAN::Meta", "2.110420") ) {
1905 for my $file ( @metafiles ) {
1906 next unless -f $file;
1907 $meta_obj = eval { CPAN::Meta->load_file($file) };
1908 last if $meta_obj;
1909 }
53fc1c7e 1910 }
a7c7ab1e
DG
1911
1912 # maybe get a copy in spec v2 format (regardless of original source)
1913 $mymeta = $meta_obj->as_struct
1914 if $meta_obj;
1915
1916 # if we have metadata, just update it
53fc1c7e
DG
1917 if ( defined $mymeta ) {
1918 my $prereqs = $self->_normalize_prereqs;
a7c7ab1e
DG
1919 # XXX refactor this mapping somewhere
1920 $mymeta->{prereqs}{runtime}{requires} = $prereqs->{requires};
1921 $mymeta->{prereqs}{build}{requires} = $prereqs->{build_requires};
ee76e757 1922 $mymeta->{prereqs}{test}{requires} = $prereqs->{test_requires};
a7c7ab1e
DG
1923 $mymeta->{prereqs}{runtime}{recommends} = $prereqs->{recommends};
1924 $mymeta->{prereqs}{runtime}{conflicts} = $prereqs->{conflicts};
1925 # delete empty entries
1926 for my $phase ( keys %{$mymeta->{prereqs}} ) {
1927 if ( ref $mymeta->{prereqs}{$phase} eq 'HASH' ) {
1928 for my $type ( keys %{$mymeta->{prereqs}{$phase}} ) {
1929 if ( ! defined $mymeta->{prereqs}{$phase}{$type}
1930 || ! keys %{$mymeta->{prereqs}{$phase}{$type}}
1931 ) {
1932 delete $mymeta->{prereqs}{$phase}{$type};
1933 }
1934 }
1935 }
1936 if ( ! defined $mymeta->{prereqs}{$phase}
1937 || ! keys %{$mymeta->{prereqs}{$phase}}
1938 ) {
1939 delete $mymeta->{prereqs}{$phase};
1940 }
53fc1c7e 1941 }
a7c7ab1e
DG
1942 $mymeta->{dynamic_config} = 0;
1943 $mymeta->{generated_by} = "Module::Build version $Module::Build::VERSION";
0bb35765 1944 eval { $meta_obj = CPAN::Meta->new( $mymeta, { lazy_validation => 1 } ) }
53fc1c7e 1945 }
a7c7ab1e 1946 # or generate from scratch, ignoring errors if META doesn't exist
53fc1c7e 1947 else {
a7c7ab1e
DG
1948 $meta_obj = $self->_get_meta_object(
1949 quiet => 0, dynamic => 0, fatal => 0, auto => 0
1950 );
53fc1c7e
DG
1951 }
1952
a7c7ab1e
DG
1953 my @created = $self->_write_meta_files( $meta_obj, 'MYMETA' );
1954
1955 $self->log_warn("Could not create MYMETA files\n")
1956 unless @created;
53fc1c7e 1957
53fc1c7e
DG
1958 return 1;
1959}
1960
1961sub create_build_script {
1962 my ($self) = @_;
1963
1964 $self->write_config;
1965 $self->create_mymeta;
613f422f
DG
1966
1967 # Create Build
bb4e9162
YST
1968 my ($build_script, $dist_name, $dist_version)
1969 = map $self->$_(), qw(build_script dist_name dist_version);
613f422f 1970
bb4e9162 1971 if ( $self->delete_filetree($build_script) ) {
613f422f 1972 $self->log_verbose("Removed previous script '$build_script'\n");
bb4e9162
YST
1973 }
1974
1975 $self->log_info("Creating new '$build_script' script for ",
613f422f 1976 "'$dist_name' version '$dist_version'\n");
46de787b 1977 open(my $fh, '>', $build_script) or die "Can't create '$build_script': $!";
bb4e9162
YST
1978 $self->print_build_script($fh);
1979 close $fh;
613f422f 1980
bb4e9162
YST
1981 $self->make_executable($build_script);
1982
1983 return 1;
1984}
1985
1986sub check_manifest {
1987 my $self = shift;
1988 return unless -e 'MANIFEST';
613f422f 1989
bb4e9162
YST
1990 # Stolen nearly verbatim from MakeMaker. But ExtUtils::Manifest
1991 # could easily be re-written into a modern Perl dialect.
1992
1993 require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean.
1994 local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
613f422f
DG
1995
1996 $self->log_verbose("Checking whether your kit is complete...\n");
bb4e9162
YST
1997 if (my @missed = ExtUtils::Manifest::manicheck()) {
1998 $self->log_warn("WARNING: the following files are missing in your kit:\n",
58fa6946
CBW
1999 "\t", join("\n\t", @missed), "\n",
2000 "Please inform the author.\n\n");
bb4e9162 2001 } else {
613f422f 2002 $self->log_verbose("Looks good\n\n");
bb4e9162
YST
2003 }
2004}
2005
2006sub dispatch {
2007 my $self = shift;
2008 local $self->{_completed_actions} = {};
2009
2010 if (@_) {
2011 my ($action, %p) = @_;
2012 my $args = $p{args} ? delete($p{args}) : {};
2013
2014 local $self->{invoked_action} = $action;
2015 local $self->{args} = {%{$self->{args}}, %$args};
2016 local $self->{properties} = {%{$self->{properties}}, %p};
2017 return $self->_call_action($action);
2018 }
2019
2020 die "No build action specified" unless $self->{action};
2021 local $self->{invoked_action} = $self->{action};
2022 $self->_call_action($self->{action});
2023}
2024
2025sub _call_action {
2026 my ($self, $action) = @_;
2027
2028 return if $self->{_completed_actions}{$action}++;
2029
2030 local $self->{action} = $action;
23837600
DG
2031 my $method = $self->can_action( $action );
2032 die "No action '$action' defined, try running the 'help' action.\n" unless $method;
4085a377
DG
2033 $self->log_debug("Starting ACTION_$action\n");
2034 my $rc = $self->$method();
2035 $self->log_debug("Finished ACTION_$action\n");
2036 return $rc;
bb4e9162
YST
2037}
2038
23837600
DG
2039sub can_action {
2040 my ($self, $action) = @_;
2041 return $self->can( "ACTION_$action" );
2042}
2043
738349a8 2044# cuts the user-specified options out of the command-line args
bb4e9162
YST
2045sub cull_options {
2046 my $self = shift;
738349a8
SH
2047 my (@argv) = @_;
2048
15cb7b9d
SH
2049 # XXX is it even valid to call this as a class method?
2050 return({}, @argv) unless(ref($self)); # no object
2051
738349a8
SH
2052 my $specs = $self->get_options;
2053 return({}, @argv) unless($specs and %$specs); # no user options
2054
bb4e9162
YST
2055 require Getopt::Long;
2056 # XXX Should we let Getopt::Long handle M::B's options? That would
2057 # be easy-ish to add to @specs right here, but wouldn't handle options
2058 # passed without "--" as M::B currently allows. We might be able to
2059 # get around this by setting the "prefix_pattern" Configure option.
2060 my @specs;
2061 my $args = {};
2062 # Construct the specifications for GetOptions.
2063 while (my ($k, $v) = each %$specs) {
2064 # Throw an error if specs conflict with our own.
2065 die "Option specification '$k' conflicts with a " . ref $self
2066 . " option of the same name"
2067 if $self->valid_property($k);
2068 push @specs, $k . (defined $v->{type} ? $v->{type} : '');
2069 push @specs, $v->{store} if exists $v->{store};
2070 $args->{$k} = $v->{default} if exists $v->{default};
2071 }
2072
738349a8 2073 local @ARGV = @argv; # No other way to dupe Getopt::Long
bb4e9162
YST
2074
2075 # Get the options values and return them.
2076 # XXX Add option to allow users to set options?
2077 if ( @specs ) {
2078 Getopt::Long::Configure('pass_through');
2079 Getopt::Long::GetOptions($args, @specs);
2080 }
2081
2082 return $args, @ARGV;
2083}
2084
2085sub unparse_args {
2086 my ($self, $args) = @_;
2087 my @out;
2088 while (my ($k, $v) = each %$args) {
2089 push @out, (UNIVERSAL::isa($v, 'HASH') ? map {+"--$k", "$_=$v->{$_}"} keys %$v :
58fa6946
CBW
2090 UNIVERSAL::isa($v, 'ARRAY') ? map {+"--$k", $_} @$v :
2091 ("--$k", $v));
bb4e9162
YST
2092 }
2093 return @out;
2094}
2095
2096sub args {
2097 my $self = shift;
2098 return wantarray ? %{ $self->{args} } : $self->{args} unless @_;
2099 my $key = shift;
2100 $self->{args}{$key} = shift if @_;
2101 return $self->{args}{$key};
2102}
2103
738349a8
SH
2104# allows select parameters (with underscores) to be spoken with dashes
2105# when used as command-line options
bb4e9162
YST
2106sub _translate_option {
2107 my $self = shift;
2108 my $opt = shift;
2109
2110 (my $tr_opt = $opt) =~ tr/-/_/;
2111
2112 return $tr_opt if grep $tr_opt =~ /^(?:no_?)?$_$/, qw(
15cb7b9d 2113 create_license
bb4e9162
YST
2114 create_makefile_pl
2115 create_readme
2116 extra_compiler_flags
2117 extra_linker_flags
bb4e9162
YST
2118 install_base
2119 install_path
2120 meta_add
2121 meta_merge
2122 test_files
2123 use_rcfile
738349a8
SH
2124 use_tap_harness
2125 tap_harness_args
613f422f 2126 cpan_client
ee76e757
CBW
2127 pureperl_only
2128 allow_pureperl
bb4e9162
YST
2129 ); # normalize only selected option names
2130
2131 return $opt;
2132}
2133
58fa6946
CBW
2134my %singular_argument = map { ($_ => 1) } qw/install_base prefix destdir installdir verbose quiet uninst debug sign/;
2135
bb4e9162
YST
2136sub _read_arg {
2137 my ($self, $args, $key, $val) = @_;
2138
2139 $key = $self->_translate_option($key);
2140
58fa6946 2141 if ( exists $args->{$key} and not $singular_argument{$key} ) {
bb4e9162
YST
2142 $args->{$key} = [ $args->{$key} ] unless ref $args->{$key};
2143 push @{$args->{$key}}, $val;
2144 } else {
2145 $args->{$key} = $val;
2146 }
2147}
2148
23837600 2149# decide whether or not an option requires/has an operand
bb4e9162
YST
2150sub _optional_arg {
2151 my $self = shift;
2152 my $opt = shift;
2153 my $argv = shift;
2154
2155 $opt = $self->_translate_option($opt);
2156
2157 my @bool_opts = qw(
2158 build_bat
15cb7b9d 2159 create_license
bb4e9162
YST
2160 create_readme
2161 pollute
2162 quiet
2163 uninst
2164 use_rcfile
2165 verbose
4085a377 2166 debug
738349a8
SH
2167 sign
2168 use_tap_harness
ee76e757
CBW
2169 pureperl_only
2170 allow_pureperl
bb4e9162
YST
2171 );
2172
2173 # inverted boolean options; eg --noverbose or --no-verbose
2174 # converted to proper name & returned with false value (verbose, 0)
2175 if ( grep $opt =~ /^no[-_]?$_$/, @bool_opts ) {
2176 $opt =~ s/^no-?//;
2177 return ($opt, 0);
2178 }
2179
2180 # non-boolean option; return option unchanged along with its argument
2181 return ($opt, shift(@$argv)) unless grep $_ eq $opt, @bool_opts;
2182
2183 # we're punting a bit here, if an option appears followed by a digit
2184 # we take the digit as the argument for the option. If there is
738349a8 2185 # nothing that looks like a digit, we pretend the option is a flag
bb4e9162
YST
2186 # that is being set and has no argument.
2187 my $arg = 1;
2188 $arg = shift(@$argv) if @$argv && $argv->[0] =~ /^\d+$/;
2189
2190 return ($opt, $arg);
2191}
2192
2193sub read_args {
2194 my $self = shift;
738349a8 2195
bb4e9162
YST
2196 (my $args, @_) = $self->cull_options(@_);
2197 my %args = %$args;
2198
2199 my $opt_re = qr/[\w\-]+/;
2200
738349a8 2201 my ($action, @argv);
bb4e9162
YST
2202 while (@_) {
2203 local $_ = shift;
2204 if ( /^(?:--)?($opt_re)=(.*)$/ ) {
2205 $self->_read_arg(\%args, $1, $2);
2206 } elsif ( /^--($opt_re)$/ ) {
2207 my($opt, $arg) = $self->_optional_arg($1, \@_);
2208 $self->_read_arg(\%args, $opt, $arg);
2209 } elsif ( /^($opt_re)$/ and !defined($action)) {
2210 $action = $1;
2211 } else {
2212 push @argv, $_;
2213 }
2214 }
2215 $args{ARGV} = \@argv;
2216
c1d8f74e
SP
2217 for ('extra_compiler_flags', 'extra_linker_flags') {
2218 $args{$_} = [ $self->split_like_shell($args{$_}) ] if exists $args{$_};
2219 }
2220
23837600
DG
2221 # Convert to arrays
2222 for ('include_dirs') {
2223 $args{$_} = [ $args{$_} ] if exists $args{$_} && !ref $args{$_}
2224 }
2225
bb4e9162 2226 # Hashify these parameters
77e96e88 2227 for ($self->hash_properties, 'config') {
bb4e9162
YST
2228 next unless exists $args{$_};
2229 my %hash;
2230 $args{$_} ||= [];
2231 $args{$_} = [ $args{$_} ] unless ref $args{$_};
2232 foreach my $arg ( @{$args{$_}} ) {
7cf8bfc0 2233 $arg =~ /($opt_re)=(.*)/
58fa6946 2234 or die "Malformed '$_' argument: '$arg' should be something like 'foo=bar'";
bb4e9162
YST
2235 $hash{$1} = $2;
2236 }
2237 $args{$_} = \%hash;
2238 }
2239
2240 # De-tilde-ify any path parameters
2241 for my $key (qw(prefix install_base destdir)) {
2242 next if !defined $args{$key};
3776488a 2243 $args{$key} = $self->_detildefy($args{$key});
bb4e9162
YST
2244 }
2245
2246 for my $key (qw(install_path)) {
2247 next if !defined $args{$key};
2248
2249 for my $subkey (keys %{$args{$key}}) {
2250 next if !defined $args{$key}{$subkey};
3776488a 2251 my $subkey_ext = $self->_detildefy($args{$key}{$subkey});
23837600 2252 if ( $subkey eq 'html' ) { # translate for compatibility
58fa6946
CBW
2253 $args{$key}{binhtml} = $subkey_ext;
2254 $args{$key}{libhtml} = $subkey_ext;
bb4e9162 2255 } else {
58fa6946 2256 $args{$key}{$subkey} = $subkey_ext;
bb4e9162
YST
2257 }
2258 }
2259 }
2260
2261 if ($args{makefile_env_macros}) {
2262 require Module::Build::Compat;
2263 %args = (%args, Module::Build::Compat->makefile_to_build_macros);
2264 }
613f422f 2265
bb4e9162
YST
2266 return \%args, $action;
2267}
2268
7a827510
RGS
2269# Default: do nothing. Overridden for Unix & Windows.
2270sub _detildefy {}
bb4e9162
YST
2271
2272
2273# merge Module::Build argument lists that have already been parsed
2274# by read_args(). Takes two references to option hashes and merges
2275# the contents, giving priority to the first.
2276sub _merge_arglist {
2277 my( $self, $opts1, $opts2 ) = @_;
2278
cdbde1c3
DG
2279 $opts1 ||= {};
2280 $opts2 ||= {};
bb4e9162
YST
2281 my %new_opts = %$opts1;
2282 while (my ($key, $val) = each %$opts2) {
2283 if ( exists( $opts1->{$key} ) ) {
2284 if ( ref( $val ) eq 'HASH' ) {
2285 while (my ($k, $v) = each %$val) {
58fa6946
CBW
2286 $new_opts{$key}{$k} = $v unless exists( $opts1->{$key}{$k} );
2287 }
bb4e9162
YST
2288 }
2289 } else {
2290 $new_opts{$key} = $val
2291 }
2292 }
2293
2294 return %new_opts;
2295}
2296
dc8021d3 2297# Look for a home directory on various systems.
bb4e9162 2298sub _home_dir {
dc8021d3
SP
2299 my @home_dirs;
2300 push( @home_dirs, $ENV{HOME} ) if $ENV{HOME};
2301
2302 push( @home_dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
2303 if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
2304
2305 my @other_home_envs = qw( USERPROFILE APPDATA WINDIR SYS$LOGIN );
2306 push( @home_dirs, map $ENV{$_}, grep $ENV{$_}, @other_home_envs );
2307
2308 my @real_home_dirs = grep -d, @home_dirs;
2309
2310 return wantarray ? @real_home_dirs : shift( @real_home_dirs );
2311}
2312
2313sub _find_user_config {
2314 my $self = shift;
2315 my $file = shift;
2316 foreach my $dir ( $self->_home_dir ) {
2317 my $path = File::Spec->catfile( $dir, $file );
2318 return $path if -e $path;
bb4e9162 2319 }
dc8021d3 2320 return undef;
bb4e9162
YST
2321}
2322
2323# read ~/.modulebuildrc returning global options '*' and
2324# options specific to the currently executing $action.
2325sub read_modulebuildrc {
2326 my( $self, $action ) = @_;
2327
2328 return () unless $self->use_rcfile;
2329
2330 my $modulebuildrc;
2331 if ( exists($ENV{MODULEBUILDRC}) && $ENV{MODULEBUILDRC} eq 'NONE' ) {
2332 return ();
2333 } elsif ( exists($ENV{MODULEBUILDRC}) && -e $ENV{MODULEBUILDRC} ) {
2334 $modulebuildrc = $ENV{MODULEBUILDRC};
2335 } elsif ( exists($ENV{MODULEBUILDRC}) ) {
2336 $self->log_warn("WARNING: Can't find resource file " .
58fa6946
CBW
2337 "'$ENV{MODULEBUILDRC}' defined in environment.\n" .
2338 "No options loaded\n");
bb4e9162
YST
2339 return ();
2340 } else {
dc8021d3
SP
2341 $modulebuildrc = $self->_find_user_config( '.modulebuildrc' );
2342 return () unless $modulebuildrc;
bb4e9162
YST
2343 }
2344
46de787b 2345 open(my $fh, '<', $modulebuildrc )
bb4e9162
YST
2346 or die "Can't open $modulebuildrc: $!";
2347
2348 my %options; my $buffer = '';
2349 while (defined( my $line = <$fh> )) {
2350 chomp( $line );
2351 $line =~ s/#.*$//;
2352 next unless length( $line );
2353
2354 if ( $line =~ /^\S/ ) {
2355 if ( $buffer ) {
58fa6946
CBW
2356 my( $action, $options ) = split( /\s+/, $buffer, 2 );
2357 $options{$action} .= $options . ' ';
2358 $buffer = '';
bb4e9162
YST
2359 }
2360 $buffer = $line;
2361 } else {
2362 $buffer .= $line;
2363 }
2364 }
2365
2366 if ( $buffer ) { # anything left in $buffer ?
2367 my( $action, $options ) = split( /\s+/, $buffer, 2 );
2368 $options{$action} .= $options . ' '; # merge if more than one line
2369 }
2370
2371 my ($global_opts) =
2372 $self->read_args( $self->split_like_shell( $options{'*'} || '' ) );
7cf8bfc0
DG
2373
2374 # let fakeinstall act like install if not provided
2375 if ( $action eq 'fakeinstall' && ! exists $options{fakeinstall} ) {
2376 $action = 'install';
2377 }
bb4e9162
YST
2378 my ($action_opts) =
2379 $self->read_args( $self->split_like_shell( $options{$action} || '' ) );
2380
2381 # specific $action options take priority over global options '*'
2382 return $self->_merge_arglist( $action_opts, $global_opts );
2383}
2384
2385# merge the relevant options in ~/.modulebuildrc into Module::Build's
2386# option list where they do not conflict with commandline options.
2387sub merge_modulebuildrc {
2388 my( $self, $action, %cmdline_opts ) = @_;
2389 my %rc_opts = $self->read_modulebuildrc( $action || $self->{action} || 'build' );
2390 my %new_opts = $self->_merge_arglist( \%cmdline_opts, \%rc_opts );
2391 $self->merge_args( $action, %new_opts );
2392}
2393
2394sub merge_args {
2395 my ($self, $action, %args) = @_;
2396 $self->{action} = $action if defined $action;
2397
2398 my %additive = map { $_ => 1 } $self->hash_properties;
2399
2400 # Extract our 'properties' from $cmd_args, the rest are put in 'args'.
2401 while (my ($key, $val) = each %args) {
2402 $self->{phash}{runtime_params}->access( $key => $val )
2403 if $self->valid_property($key);
bb4e9162 2404
77e96e88
RGS
2405 if ($key eq 'config') {
2406 $self->config($_ => $val->{$_}) foreach keys %$val;
bb4e9162 2407 } else {
738349a8
SH
2408 my $add_to = $additive{$key} ? $self->{properties}{$key} :
2409 $self->valid_property($key) ? $self->{properties} :
2410 $self->{args} ;
77e96e88
RGS
2411
2412 if ($additive{$key}) {
58fa6946 2413 $add_to->{$_} = $val->{$_} foreach keys %$val;
77e96e88 2414 } else {
58fa6946 2415 $add_to->{$key} = $val;
77e96e88 2416 }
bb4e9162
YST
2417 }
2418 }
2419}
2420
2421sub cull_args {
2422 my $self = shift;
613f422f
DG
2423 my @arg_list = @_;
2424 unshift @arg_list, $self->split_like_shell($ENV{PERL_MB_OPT})
2425 if $ENV{PERL_MB_OPT};
2426 my ($args, $action) = $self->read_args(@arg_list);
bb4e9162
YST
2427 $self->merge_args($action, %$args);
2428 $self->merge_modulebuildrc( $action, %$args );
2429}
2430
2431sub super_classes {
2432 my ($self, $class, $seen) = @_;
2433 $class ||= ref($self) || $self;
2434 $seen ||= {};
613f422f 2435
bb4e9162
YST
2436 no strict 'refs';
2437 my @super = grep {not $seen->{$_}++} $class, @{ $class . '::ISA' };
2438 return @super, map {$self->super_classes($_,$seen)} @super;
2439}
2440
2441sub known_actions {
2442 my ($self) = @_;
2443
2444 my %actions;
2445 no strict 'refs';
613f422f 2446
bb4e9162
YST
2447 foreach my $class ($self->super_classes) {
2448 foreach ( keys %{ $class . '::' } ) {
2449 $actions{$1}++ if /^ACTION_(\w+)/;
2450 }
2451 }
2452
2453 return wantarray ? sort keys %actions : \%actions;
2454}
2455
2456sub get_action_docs {
7253302f
SP
2457 my ($self, $action) = @_;
2458 my $actions = $self->known_actions;
2459 die "No known action '$action'" unless $actions->{$action};
2460
bb4e9162
YST
2461 my ($files_found, @docs) = (0);
2462 foreach my $class ($self->super_classes) {
2463 (my $file = $class) =~ s{::}{/}g;
c1d8f74e 2464 # NOTE: silently skipping relative paths if any chdir() happened
bb4e9162 2465 $file = $INC{$file . '.pm'} or next;
46de787b 2466 open(my $fh, '<', $file) or next;
bb4e9162 2467 $files_found++;
7253302f 2468
bb4e9162 2469 # Code below modified from /usr/bin/perldoc
7253302f 2470
bb4e9162
YST
2471 # Skip to ACTIONS section
2472 local $_;
2473 while (<$fh>) {
2474 last if /^=head1 ACTIONS\s/;
2475 }
7253302f 2476
c1d8f74e
SP
2477 # Look for our action and determine the style
2478 my $style;
bb4e9162 2479 while (<$fh>) {
c1d8f74e
SP
2480 last if /^=head1 /;
2481
2482 # only item and head2 are allowed (3&4 are not in 5.005)
2483 if(/^=(item|head2)\s+\Q$action\E\b/) {
2484 $style = $1;
2485 push @docs, $_;
2486 last;
bb4e9162 2487 }
bb4e9162 2488 }
c1d8f74e
SP
2489 $style or next; # not here
2490
2491 # and the content
2492 if($style eq 'item') {
2493 my ($found, $inlist) = (0, 0);
2494 while (<$fh>) {
2495 if (/^=(item|back)/) {
2496 last unless $inlist;
2497 }
2498 push @docs, $_;
2499 ++$inlist if /^=over/;
2500 --$inlist if /^=back/;
2501 }
2502 }
2503 else { # head2 style
2504 # stop at anything equal or greater than the found level
2505 while (<$fh>) {
2506 last if(/^=(?:head[12]|cut)/);
2507 push @docs, $_;
2508 }
2509 }
2510 # TODO maybe disallow overriding just pod for an action
2511 # TODO and possibly: @docs and last;
bb4e9162
YST
2512 }
2513
2514 unless ($files_found) {
2515 $@ = "Couldn't find any documentation to search";
2516 return;
2517 }
2518 unless (@docs) {
2519 $@ = "Couldn't find any docs for action '$action'";
2520 return;
2521 }
613f422f 2522
bb4e9162
YST
2523 return join '', @docs;
2524}
2525
2526sub ACTION_prereq_report {
2527 my $self = shift;
2528 $self->log_info( $self->prereq_report );
2529}
2530
66e531b6
NC
2531sub ACTION_prereq_data {
2532 my $self = shift;
2533 $self->log_info( Module::Build::Dumper->_data_dump( $self->prereq_data ) );
2534}
2535
2536sub prereq_data {
bb4e9162 2537 my $self = shift;
23837600 2538 my @types = ('configure_requires', @{ $self->prereq_action_types } );
66e531b6
NC
2539 my $info = { map { $_ => $self->$_() } grep { %{$self->$_()} } @types };
2540 return $info;
2541}
2542
2543sub prereq_report {
2544 my $self = shift;
2545 my $info = $self->prereq_data;
bb4e9162
YST
2546
2547 my $output = '';
66e531b6 2548 foreach my $type (keys %$info) {
bb4e9162 2549 my $prereqs = $info->{$type};
bb4e9162
YST
2550 $output .= "\n$type:\n";
2551 my $mod_len = 2;
2552 my $ver_len = 4;
2553 my %mods;
2554 while ( my ($modname, $spec) = each %$prereqs ) {
2555 my $len = length $modname;
2556 $mod_len = $len if $len > $mod_len;
2557 $spec ||= '0';
2558 $len = length $spec;
2559 $ver_len = $len if $len > $ver_len;
2560
2561 my $mod = $self->check_installed_status($modname, $spec);
2562 $mod->{name} = $modname;
2563 $mod->{ok} ||= 0;
2564 $mod->{ok} = ! $mod->{ok} if $type =~ /^(\w+_)?conflicts$/;
2565
2566 $mods{lc $modname} = $mod;
2567 }
2568
2569 my $space = q{ } x ($mod_len - 3);
2570 my $vspace = q{ } x ($ver_len - 3);
2571 my $sline = q{-} x ($mod_len - 3);
2572 my $vline = q{-} x ($ver_len - 3);
2573 my $disposition = ($type =~ /^(\w+_)?conflicts$/) ?
2574 'Clash' : 'Need';
2575 $output .=
2576 " Module $space $disposition $vspace Have\n".
2577 " ------$sline+------$vline-+----------\n";
2578
2579
2580 for my $k (sort keys %mods) {
2581 my $mod = $mods{$k};
2582 my $space = q{ } x ($mod_len - length $k);
2583 my $vspace = q{ } x ($ver_len - length $mod->{need});
2584 my $f = $mod->{ok} ? ' ' : '!';
2585 $output .=
7a827510
RGS
2586 " $f $mod->{name} $space $mod->{need} $vspace ".
2587 (defined($mod->{have}) ? $mod->{have} : "")."\n";
bb4e9162
YST
2588 }
2589 }
2590 return $output;
2591}
2592
2593sub ACTION_help {
2594 my ($self) = @_;
2595 my $actions = $self->known_actions;
613f422f 2596
bb4e9162 2597 if (@{$self->{args}{ARGV}}) {
7253302f
SP
2598 my $msg = eval {$self->get_action_docs($self->{args}{ARGV}[0], $actions)};
2599 print $@ ? "$@\n" : $msg;
bb4e9162
YST
2600 return;
2601 }
2602
2603 print <<EOF;
2604
2605 Usage: $0 <action> arg1=value arg2=value ...
2606 Example: $0 test verbose=1
613f422f 2607
bb4e9162
YST
2608 Actions defined:
2609EOF
613f422f 2610
bb4e9162
YST
2611 print $self->_action_listing($actions);
2612
2613 print "\nRun `Build help <action>` for details on an individual action.\n";
2614 print "See `perldoc Module::Build` for complete documentation.\n";
2615}
2616
2617sub _action_listing {
2618 my ($self, $actions) = @_;
2619
2620 # Flow down columns, not across rows
2621 my @actions = sort keys %$actions;
2622 @actions = map $actions[($_ + ($_ % 2) * @actions) / 2], 0..$#actions;
613f422f 2623
bb4e9162
YST
2624 my $out = '';
2625 while (my ($one, $two) = splice @actions, 0, 2) {
2626 $out .= sprintf(" %-12s %-12s\n", $one, $two||'');
2627 }
53fc1c7e 2628 $out =~ s{\s*$}{}mg; # remove trailing spaces
bb4e9162
YST
2629 return $out;
2630}
2631
77e96e88
RGS
2632sub ACTION_retest {
2633 my ($self) = @_;
613f422f 2634
77e96e88
RGS
2635 # Protect others against our @INC changes
2636 local @INC = @INC;
2637
2638 # Filter out nonsensical @INC entries - some versions of
2639 # Test::Harness will really explode the number of entries here
2640 @INC = grep {ref() || -d} @INC if @INC > 100;
2641
2642 $self->do_tests;
2643}
2644
7253302f
SP
2645sub ACTION_testall {
2646 my ($self) = @_;
2647
2648 my @types;
2649 for my $action (grep { $_ ne 'all' } $self->get_test_types) {
2650 # XXX We can't just dispatch because we get multiple summaries but
2651 # we'll need to dispatch to support custom setup/teardown in the
2652 # action. To support that, we'll need to call something besides
2653 # Harness::runtests() because we'll need to collect the results in
2654 # parts, then run the summary.
2655 push(@types, $action);
2656 #$self->_call_action( "test$action" );
2657 }
2658 $self->generic_test(types => ['default', @types]);
2659}
2660
2661sub get_test_types {
2662 my ($self) = @_;
2663
2664 my $t = $self->{properties}->{test_types};
2665 return ( defined $t ? ( keys %$t ) : () );
2666}
2667
77e96e88 2668
bb4e9162
YST
2669sub ACTION_test {
2670 my ($self) = @_;
7253302f
SP
2671 $self->generic_test(type => 'default');
2672}
2673
2674sub generic_test {
2675 my $self = shift;
2676 (@_ % 2) and croak('Odd number of elements in argument hash');
2677 my %args = @_;
2678
bb4e9162 2679 my $p = $self->{properties};
7253302f
SP
2680
2681 my @types = (
613f422f 2682 (exists($args{type}) ? $args{type} : ()),
7253302f
SP
2683 (exists($args{types}) ? @{$args{types}} : ()),
2684 );
2685 @types or croak "need some types of tests to check";
2686
2687 my %test_types = (
738349a8 2688 default => $p->{test_file_exts},
7253302f
SP
2689 (defined($p->{test_types}) ? %{$p->{test_types}} : ()),
2690 );
2691
2692 for my $type (@types) {
2693 croak "$type not defined in test_types!"
2694 unless defined $test_types{ $type };
2695 }
2696
2697 # we use local here because it ends up two method calls deep
738349a8 2698 local $p->{test_file_exts} = [ map { ref $_ ? @$_ : $_ } @test_types{@types} ];
bb4e9162 2699 $self->depends_on('code');
7253302f 2700
77e96e88
RGS
2701 # Protect others against our @INC changes
2702 local @INC = @INC;
2703
2704 # Make sure we test the module in blib/
2705 unshift @INC, (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
58fa6946 2706 File::Spec->catdir($p->{base_dir}, $self->blib, 'arch'));
77e96e88
RGS
2707
2708 # Filter out nonsensical @INC entries - some versions of
2709 # Test::Harness will really explode the number of entries here
2710 @INC = grep {ref() || -d} @INC if @INC > 100;
2711
2712 $self->do_tests;
2713}
2714
613f422f
DG
2715# Test::Harness dies on failure but TAP::Harness does not, so we must
2716# die if running under TAP::Harness
77e96e88
RGS
2717sub do_tests {
2718 my $self = shift;
bb4e9162 2719
bb4e9162
YST
2720 my $tests = $self->find_test_files;
2721
7cf8bfc0
DG
2722 local $ENV{PERL_DL_NONLAZY} = 1;
2723
738349a8
SH
2724 if(@$tests) {
2725 my $args = $self->tap_harness_args;
2726 if($self->use_tap_harness or ($args and %$args)) {
613f422f
DG
2727 my $aggregate = $self->run_tap_harness($tests);
2728 if ( $aggregate->has_errors ) {
2729 die "Errors in testing. Cannot continue.\n";
2730 }
738349a8
SH
2731 }
2732 else {
2733 $self->run_test_harness($tests);
2734 }
2735 }
2736 else {
2737 $self->log_info("No tests defined.\n");
2738 }
2739
2740 $self->run_visual_script;
2741}
2742
2743sub run_tap_harness {
2744 my ($self, $tests) = @_;
2745
2746 require TAP::Harness;
2747
2748 # TODO allow the test @INC to be set via our API?
2749
613f422f 2750 my $aggregate = TAP::Harness->new({
738349a8
SH
2751 lib => [@INC],
2752 verbosity => $self->{properties}{verbose},
2753 switches => [ $self->harness_switches ],
2754 %{ $self->tap_harness_args },
2755 })->runtests(@$tests);
613f422f
DG
2756
2757 return $aggregate;
738349a8
SH
2758}
2759
2760sub run_test_harness {
2761 my ($self, $tests) = @_;
2762 require Test::Harness;
738349a8 2763
6e4bdc3f
CBW
2764 local $Test::Harness::verbose = $self->verbose || 0;
2765 local $Test::Harness::switches = join ' ', $self->harness_switches;
738349a8 2766
bb4e9162 2767 Test::Harness::runtests(@$tests);
738349a8 2768}
bb4e9162 2769
738349a8
SH
2770sub run_visual_script {
2771 my $self = shift;
2772 # This will get run and the user will see the output. It doesn't
2773 # emit Test::Harness-style output.
2774 $self->run_perl_script('visual.pl', '-Mblib='.$self->blib)
2775 if -e 'visual.pl';
2776}
2777
2778sub harness_switches {
2779 shift->{properties}{debugger} ? qw(-w -d) : ();
bb4e9162
YST
2780}
2781
2782sub test_files {
2783 my $self = shift;
2784 my $p = $self->{properties};
2785 if (@_) {
2786 return $p->{test_files} = (@_ == 1 ? shift : [@_]);
2787 }
2788 return $self->find_test_files;
2789}
2790
2791sub expand_test_dir {
2792 my ($self, $dir) = @_;
738349a8 2793 my $exts = $self->{properties}{test_file_exts};
7253302f
SP
2794
2795 return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts
2796 if $self->recursive_test_files;
2797
2798 return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts;
bb4e9162
YST
2799}
2800
2801sub ACTION_testdb {
2802 my ($self) = @_;
2803 local $self->{properties}{debugger} = 1;
2804 $self->depends_on('test');
2805}
2806
2807sub ACTION_testcover {
2808 my ($self) = @_;
2809
2810 unless (Module::Build::ModuleInfo->find_module_by_name('Devel::Cover')) {
2811 warn("Cannot run testcover action unless Devel::Cover is installed.\n");
2812 return;
2813 }
2814
2815 $self->add_to_cleanup('coverage', 'cover_db');
2816 $self->depends_on('code');
2817
2818 # See whether any of the *.pm files have changed since last time
2819 # testcover was run. If so, start over.
2820 if (-e 'cover_db') {
d1bd4ef0 2821 my $pm_files = $self->rscan_dir
7cf8bfc0 2822 (File::Spec->catdir($self->blib, 'lib'), $self->file_qr('\.pm$') );
bb4e9162 2823 my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/});
613f422f 2824
bb4e9162 2825 $self->do_system(qw(cover -delete))
77e96e88 2826 unless $self->up_to_date($pm_files, $cover_files)
58fa6946 2827 && $self->up_to_date($self->test_files, $cover_files);
bb4e9162
YST
2828 }
2829
613f422f
DG
2830 local $Test::Harness::switches =
2831 local $Test::Harness::Switches =
bb4e9162
YST
2832 local $ENV{HARNESS_PERL_SWITCHES} = "-MDevel::Cover";
2833
2834 $self->depends_on('test');
2835 $self->do_system('cover');
2836}
2837
2838sub ACTION_code {
2839 my ($self) = @_;
613f422f 2840
bb4e9162
YST
2841 # All installable stuff gets created in blib/ .
2842 # Create blib/arch to keep blib.pm happy
2843 my $blib = $self->blib;
2844 $self->add_to_cleanup($blib);
2845 File::Path::mkpath( File::Spec->catdir($blib, 'arch') );
613f422f 2846
bb4e9162
YST
2847 if (my $split = $self->autosplit) {
2848 $self->autosplit_file($_, $blib) for ref($split) ? @$split : ($split);
2849 }
613f422f 2850
bb4e9162
YST
2851 foreach my $element (@{$self->build_elements}) {
2852 my $method = "process_${element}_files";
2853 $method = "process_files_by_extension" unless $self->can($method);
2854 $self->$method($element);
2855 }
2856
2857 $self->depends_on('config_data');
2858}
2859
2860sub ACTION_build {
2861 my $self = shift;
613f422f 2862 $self->log_info("Building " . $self->dist_name . "\n");
bb4e9162
YST
2863 $self->depends_on('code');
2864 $self->depends_on('docs');
2865}
2866
2867sub process_files_by_extension {
2868 my ($self, $ext) = @_;
613f422f 2869
bb4e9162
YST
2870 my $method = "find_${ext}_files";
2871 my $files = $self->can($method) ? $self->$method() : $self->_find_file_by_type($ext, 'lib');
613f422f 2872
bb4e9162
YST
2873 while (my ($file, $dest) = each %$files) {
2874 $self->copy_if_modified(from => $file, to => File::Spec->catfile($self->blib, $dest) );
2875 }
2876}
2877
2878sub process_support_files {
2879 my $self = shift;
2880 my $p = $self->{properties};
2881 return unless $p->{c_source};
613f422f 2882
40c9afb2
CBW
2883 my $files;
2884 if (ref($p->{c_source}) eq "ARRAY") {
2885 push @{$p->{include_dirs}}, @{$p->{c_source}};
2886 for my $path (@{$p->{c_source}}) {
7cf8bfc0 2887 push @$files, @{ $self->rscan_dir($path, $self->file_qr('\.c(c|p|pp|xx|\+\+)?$')) };
40c9afb2
CBW
2888 }
2889 } else {
2890 push @{$p->{include_dirs}}, $p->{c_source};
7cf8bfc0 2891 $files = $self->rscan_dir($p->{c_source}, $self->file_qr('\.c(c|p|pp|xx|\+\+)?$'));
40c9afb2 2892 }
613f422f 2893
bb4e9162 2894 foreach my $file (@$files) {
40c9afb2 2895 push @{$p->{objects}}, $self->compile_c($file);
bb4e9162
YST
2896 }
2897}
2898
613f422f
DG
2899sub process_share_dir_files {
2900 my $self = shift;
2901 my $files = $self->_find_share_dir_files;
2902 return unless $files;
2903
2904 # root for all File::ShareDir paths
2905 my $share_prefix = File::Spec->catdir($self->blib, qw/lib auto share/);
2906
2907 # copy all share files to blib
2908 while (my ($file, $dest) = each %$files) {
2909 $self->copy_if_modified(
2910 from => $file, to => File::Spec->catfile( $share_prefix, $dest )
2911 );
2912 }
2913}
2914
2915sub _find_share_dir_files {
2916 my $self = shift;
2917 my $share_dir = $self->share_dir;
2918 return unless $share_dir;
2919
2920 my @file_map;
2921 if ( $share_dir->{dist} ) {
53fc1c7e 2922 my $prefix = "dist/".$self->dist_name;
613f422f
DG
2923 push @file_map, $self->_share_dir_map( $prefix, $share_dir->{dist} );
2924 }
2925
2926 if ( $share_dir->{module} ) {
2927 for my $mod ( keys %{ $share_dir->{module} } ) {
2928 (my $altmod = $mod) =~ s{::}{-}g;
53fc1c7e 2929 my $prefix = "module/$altmod";
613f422f
DG
2930 push @file_map, $self->_share_dir_map($prefix, $share_dir->{module}{$mod});
2931 }
2932 }
2933
2934 return { @file_map };
2935}
2936
2937sub _share_dir_map {
2938 my ($self, $prefix, $list) = @_;
2939 my %files;
2940 for my $dir ( @$list ) {
2941 for my $f ( @{ $self->rscan_dir( $dir, sub {-f} )} ) {
2df9265e 2942 $f =~ s{\A.*?\Q$dir\E/}{};
53fc1c7e 2943 $files{"$dir/$f"} = "$prefix/$f";
613f422f
DG
2944 }
2945 }
2946 return %files;
2947}
2948
bb4e9162
YST
2949sub process_PL_files {
2950 my ($self) = @_;
2951 my $files = $self->find_PL_files;
613f422f 2952
bb4e9162
YST
2953 while (my ($file, $to) = each %$files) {
2954 unless ($self->up_to_date( $file, $to )) {
7a827510 2955 $self->run_perl_script($file, [], [@$to]) or die "$file failed";
bb4e9162
YST
2956 $self->add_to_cleanup(@$to);
2957 }
2958 }
2959}
2960
2961sub process_xs_files {
2962 my $self = shift;
ee76e757 2963 return if $self->pureperl_only && $self->allow_pureperl;
bb4e9162 2964 my $files = $self->find_xs_files;
ee76e757 2965 croak 'Can\'t build xs files under --pureperl-only' if %$files && $self->pureperl_only;
bb4e9162
YST
2966 while (my ($from, $to) = each %$files) {
2967 unless ($from eq $to) {
2968 $self->add_to_cleanup($to);
2969 $self->copy_if_modified( from => $from, to => $to );
2970 }
2971 $self->process_xs($to);
2972 }
2973}
2974
2975sub process_pod_files { shift()->process_files_by_extension(shift()) }
2976sub process_pm_files { shift()->process_files_by_extension(shift()) }
2977
2978sub process_script_files {
2979 my $self = shift;
2980 my $files = $self->find_script_files;
2981 return unless keys %$files;
2982
2983 my $script_dir = File::Spec->catdir($self->blib, 'script');
2984 File::Path::mkpath( $script_dir );
613f422f 2985
bb4e9162
YST
2986 foreach my $file (keys %$files) {
2987 my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
c1d8f74e 2988 $self->fix_shebang_line($result) unless $self->is_vmsish;
bb4e9162
YST
2989 $self->make_executable($result);
2990 }
2991}
2992
2993sub find_PL_files {
2994 my $self = shift;
2995 if (my $files = $self->{properties}{PL_files}) {
2996 # 'PL_files' is given as a Unix file spec, so we localize_file_path().
613f422f 2997
bb4e9162
YST
2998 if (UNIVERSAL::isa($files, 'ARRAY')) {
2999 return { map {$_, [/^(.*)\.PL$/]}
58fa6946
CBW
3000 map $self->localize_file_path($_),
3001 @$files };
bb4e9162
YST
3002
3003 } elsif (UNIVERSAL::isa($files, 'HASH')) {
3004 my %out;
3005 while (my ($file, $to) = each %$files) {
58fa6946
CBW
3006 $out{ $self->localize_file_path($file) } = [ map $self->localize_file_path($_),
3007 ref $to ? @$to : ($to) ];
bb4e9162
YST
3008 }
3009 return \%out;
3010
3011 } else {
3012 die "'PL_files' must be a hash reference or array reference";
3013 }
3014 }
613f422f 3015
bb4e9162 3016 return unless -d 'lib';
a7c7ab1e
DG
3017 return {
3018 map {$_, [/^(.*)\.PL$/i ]}
3019 @{ $self->rscan_dir('lib', $self->file_qr('\.PL$')) }
7cf8bfc0 3020 };
bb4e9162
YST
3021}
3022
3023sub find_pm_files { shift->_find_file_by_type('pm', 'lib') }
3024sub find_pod_files { shift->_find_file_by_type('pod', 'lib') }
3025sub find_xs_files { shift->_find_file_by_type('xs', 'lib') }
3026
3027sub find_script_files {
3028 my $self = shift;
3029 if (my $files = $self->script_files) {
3030 # Always given as a Unix file spec. Values in the hash are
3031 # meaningless, but we preserve if present.
3032 return { map {$self->localize_file_path($_), $files->{$_}} keys %$files };
3033 }
613f422f 3034
bb4e9162
YST
3035 # No default location for script files
3036 return {};
3037}
3038
3039sub find_test_files {
3040 my $self = shift;
3041 my $p = $self->{properties};
7253302f 3042
bb4e9162
YST
3043 if (my $files = $p->{test_files}) {
3044 $files = [keys %$files] if UNIVERSAL::isa($files, 'HASH');
3045 $files = [map { -d $_ ? $self->expand_test_dir($_) : $_ }
58fa6946
CBW
3046 map glob,
3047 $self->split_like_shell($files)];
613f422f 3048
bb4e9162
YST
3049 # Always given as a Unix file spec.
3050 return [ map $self->localize_file_path($_), @$files ];
613f422f 3051
bb4e9162
YST
3052 } else {
3053 # Find all possible tests in t/ or test.pl
3054 my @tests;
3055 push @tests, 'test.pl' if -e 'test.pl';
3056 push @tests, $self->expand_test_dir('t') if -e 't' and -d _;
3057 return \@tests;
3058 }
3059}
3060
3061sub _find_file_by_type {
3062 my ($self, $type, $dir) = @_;
613f422f 3063
bb4e9162
YST
3064 if (my $files = $self->{properties}{"${type}_files"}) {
3065 # Always given as a Unix file spec
3066 return { map $self->localize_file_path($_), %$files };
3067 }
613f422f 3068
bb4e9162
YST
3069 return {} unless -d $dir;
3070 return { map {$_, $_}
58fa6946
CBW
3071 map $self->localize_file_path($_),
3072 grep !/\.\#/,
3073 @{ $self->rscan_dir($dir, $self->file_qr("\\.$type\$")) } };
bb4e9162
YST
3074}
3075
3076sub localize_file_path {
3077 my ($self, $path) = @_;
3078 return File::Spec->catfile( split m{/}, $path );
3079}
3080
3081sub localize_dir_path {
3082 my ($self, $path) = @_;
3083 return File::Spec->catdir( split m{/}, $path );
3084}
3085
3086sub fix_shebang_line { # Adapted from fixin() in ExtUtils::MM_Unix 1.35
3087 my ($self, @files) = @_;
77e96e88 3088 my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
613f422f 3089
77e96e88 3090 my ($does_shbang) = $c->get('sharpbang') =~ /^\s*\#\!/;
bb4e9162 3091 for my $file (@files) {
46de787b 3092 open(my $FIXIN, '<', $file) or die "Can't process '$file': $!";
bb4e9162
YST
3093 local $/ = "\n";
3094 chomp(my $line = <$FIXIN>);
46de787b 3095 next unless $line =~ s/^\s*\#!\s*//; # Not a shebang file.
613f422f 3096
bb4e9162
YST
3097 my ($cmd, $arg) = (split(' ', $line, 2), '');
3098 next unless $cmd =~ /perl/i;
3099 my $interpreter = $self->{properties}{perl};
613f422f 3100
40c9afb2 3101 $self->log_verbose("Changing sharpbang in $file to $interpreter\n");
bb4e9162 3102 my $shb = '';
77e96e88 3103 $shb .= $c->get('sharpbang')."$interpreter $arg\n" if $does_shbang;
613f422f 3104
bb4e9162
YST
3105 # I'm not smart enough to know the ramifications of changing the
3106 # embedded newlines here to \n, so I leave 'em in.
3107 $shb .= qq{
3108eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
3109 if 0; # not running under some shell
c1d8f74e 3110} unless $self->is_windowsish; # this won't work on win32, so don't
613f422f 3111
46de787b 3112 open(my $FIXOUT, '>', "$file.new")
bb4e9162 3113 or die "Can't create new $file: $!\n";
613f422f 3114
bb4e9162
YST
3115 # Print out the new #! line (or equivalent).
3116 local $\;
3117 undef $/; # Was localized above
3118 print $FIXOUT $shb, <$FIXIN>;
3119 close $FIXIN;
3120 close $FIXOUT;
613f422f 3121
bb4e9162
YST
3122 rename($file, "$file.bak")
3123 or die "Can't rename $file to $file.bak: $!";
613f422f 3124
bb4e9162
YST
3125 rename("$file.new", $file)
3126 or die "Can't rename $file.new to $file: $!";
613f422f 3127
7253302f 3128 $self->delete_filetree("$file.bak")
bb4e9162 3129 or $self->log_warn("Couldn't clean up $file.bak, leaving it there");
613f422f 3130
77e96e88 3131 $self->do_system($c->get('eunicefix'), $file) if $c->get('eunicefix') ne ':';
bb4e9162
YST
3132 }
3133}
3134
3135
3136sub ACTION_testpod {
3137 my $self = shift;
3138 $self->depends_on('docs');
613f422f 3139
bb4e9162
YST
3140 eval q{use Test::Pod 0.95; 1}
3141 or die "The 'testpod' action requires Test::Pod version 0.95";
3142
3143 my @files = sort keys %{$self->_find_pods($self->libdoc_dirs)},
d1bd4ef0
JM
3144 keys %{$self->_find_pods
3145 ($self->bindoc_dirs,
7cf8bfc0 3146 exclude => [ $self->file_qr('\.bat$') ])}
bb4e9162
YST
3147 or die "Couldn't find any POD files to test\n";
3148
23837600
DG
3149 { package # hide from PAUSE
3150 Module::Build::PodTester; # Don't want to pollute the main namespace
bb4e9162
YST
3151 Test::Pod->import( tests => scalar @files );
3152 pod_file_ok($_) foreach @files;
3153 }
3154}
3155
47f13fd5
SP
3156sub ACTION_testpodcoverage {
3157 my $self = shift;
3158
3159 $self->depends_on('docs');
613f422f 3160
47f13fd5
SP
3161 eval q{use Test::Pod::Coverage 1.00; 1}
3162 or die "The 'testpodcoverage' action requires ",
3163 "Test::Pod::Coverage version 1.00";
3164
c1d8f74e
SP
3165 # TODO this needs test coverage!
3166
3167 # XXX work-around a bug in Test::Pod::Coverage previous to v1.09
3168 # Make sure we test the module in blib/
3169 local @INC = @INC;
3170 my $p = $self->{properties};
3171 unshift(@INC,
3172 # XXX any reason to include arch?
3173 File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
3174 #File::Spec->catdir($p->{base_dir}, $self->blib, 'arch')
3175 );
3176
47f13fd5
SP
3177 all_pod_coverage_ok();
3178}
3179
bb4e9162
YST
3180sub ACTION_docs {
3181 my $self = shift;
3182
3183 $self->depends_on('code');
3184 $self->depends_on('manpages', 'html');
3185}
3186
3187# Given a file type, will return true if the file type would normally
3188# be installed when neither install-base nor prefix has been set.
3189# I.e. it will be true only if the path is set from Config.pm or
3190# set explicitly by the user via install-path.
3191sub _is_default_installable {
3192 my $self = shift;
3193 my $type = shift;
3194 return ( $self->install_destination($type) &&
3195 ( $self->install_path($type) ||
58fa6946
CBW
3196 $self->install_sets($self->installdirs)->{$type} )
3197 ) ? 1 : 0;
bb4e9162
YST
3198}
3199
7cf8bfc0
DG
3200sub _is_ActivePerl {
3201# return 0;
3202 my $self = shift;
3203 unless (exists($self->{_is_ActivePerl})) {
3204 $self->{_is_ActivePerl} = (eval { require ActivePerl::DocTools; } || 0);
3205 }
3206 return $self->{_is_ActivePerl};
3207}
3208
3209sub _is_ActivePPM {
3210# return 0;
3211 my $self = shift;
3212 unless (exists($self->{_is_ActivePPM})) {
3213 $self->{_is_ActivePPM} = (eval { require ActivePerl::PPM; } || 0);
3214 }
3215 return $self->{_is_ActivePPM};
3216}
3217
bb4e9162
YST
3218sub ACTION_manpages {
3219 my $self = shift;
3220
3221 return unless $self->_mb_feature('manpage_support');
3222
3223 $self->depends_on('code');
3224
46de787b
CBW
3225 my %extra_manify_args = $self->{properties}{'extra_manify_args'} ? %{ $self->{properties}{'extra_manify_args'} } : ();
3226
bb4e9162 3227 foreach my $type ( qw(bin lib) ) {
7cf8bfc0 3228 next unless ( $self->invoked_action eq 'manpages' || $self->_is_default_installable("${type}doc"));
bb4e9162 3229 my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
7cf8bfc0 3230 exclude => [ $self->file_qr('\.bat$') ] );
bb4e9162
YST
3231 next unless %$files;
3232
3233 my $sub = $self->can("manify_${type}_pods");
46de787b 3234 $self->$sub( %extra_manify_args ) if defined( $sub );
bb4e9162 3235 }
bb4e9162
YST
3236}
3237
3238sub manify_bin_pods {
3239 my $self = shift;
46de787b 3240 my %podman_args = (section => 1, @_); # binaries go in section 1
bb4e9162
YST
3241
3242 my $files = $self->_find_pods( $self->{properties}{bindoc_dirs},
7cf8bfc0 3243 exclude => [ $self->file_qr('\.bat$') ] );
bb4e9162
YST
3244 return unless keys %$files;
3245
3246 my $mandir = File::Spec->catdir( $self->blib, 'bindoc' );
77e96e88 3247 File::Path::mkpath( $mandir, 0, oct(777) );
bb4e9162
YST
3248
3249 require Pod::Man;
3250 foreach my $file (keys %$files) {
3251 # Pod::Simple based parsers only support one document per instance.
3252 # This is expected to change in a future version (Pod::Simple > 3.03).
46de787b 3253 my $parser = Pod::Man->new( %podman_args );
bb4e9162 3254 my $manpage = $self->man1page_name( $file ) . '.' .
58fa6946 3255 $self->config( 'man1ext' );
bb4e9162
YST
3256 my $outfile = File::Spec->catfile($mandir, $manpage);
3257 next if $self->up_to_date( $file, $outfile );
613f422f 3258 $self->log_verbose("Manifying $file -> $outfile\n");
cdbde1c3 3259 eval { $parser->parse_from_file( $file, $outfile ); 1 }
613f422f 3260 or $self->log_warn("Error creating '$outfile': $@\n");
bb4e9162
YST
3261 $files->{$file} = $outfile;
3262 }
3263}
3264
3265sub manify_lib_pods {
3266 my $self = shift;
46de787b 3267 my %podman_args = (section => 3, @_); # libraries go in section 3
bb4e9162
YST
3268
3269 my $files = $self->_find_pods($self->{properties}{libdoc_dirs});
3270 return unless keys %$files;
3271
3272 my $mandir = File::Spec->catdir( $self->blib, 'libdoc' );
77e96e88 3273 File::Path::mkpath( $mandir, 0, oct(777) );
bb4e9162
YST
3274
3275 require Pod::Man;
3276 while (my ($file, $relfile) = each %$files) {
3277 # Pod::Simple based parsers only support one document per instance.
3278 # This is expected to change in a future version (Pod::Simple > 3.03).
46de787b 3279 my $parser = Pod::Man->new( %podman_args );
bb4e9162 3280 my $manpage = $self->man3page_name( $relfile ) . '.' .
58fa6946 3281 $self->config( 'man3ext' );
bb4e9162
YST
3282 my $outfile = File::Spec->catfile( $mandir, $manpage);
3283 next if $self->up_to_date( $file, $outfile );
613f422f 3284 $self->log_verbose("Manifying $file -> $outfile\n");
cdbde1c3 3285 eval { $parser->parse_from_file( $file, $outfile ); 1 }
613f422f 3286 or $self->log_warn("Error creating '$outfile': $@\n");
bb4e9162
YST
3287 $files->{$file} = $outfile;
3288 }
3289}
3290
3291sub _find_pods {
3292 my ($self, $dirs, %args) = @_;
3293 my %files;
3294 foreach my $spec (@$dirs) {
3295 my $dir = $self->localize_dir_path($spec);
3296 next unless -e $dir;
b3dfda33 3297
bb4e9162
YST
3298 FILE: foreach my $file ( @{ $self->rscan_dir( $dir ) } ) {
3299 foreach my $regexp ( @{ $args{exclude} } ) {
58fa6946 3300 next FILE if $file =~ $regexp;
bb4e9162 3301 }
ee76e757 3302 $file = $self->localize_file_path($file);
bb4e9162
YST
3303 $files{$file} = File::Spec->abs2rel($file, $dir) if $self->contains_pod( $file )
3304 }
3305 }
3306 return \%files;
3307}
3308
3309sub contains_pod {
3310 my ($self, $file) = @_;
3311 return '' unless -T $file; # Only look at text files
613f422f 3312
46de787b 3313 open(my $fh, '<', $file ) or die "Can't open $file: $!";
bb4e9162
YST
3314 while (my $line = <$fh>) {
3315 return 1 if $line =~ /^\=(?:head|pod|item)/;
3316 }
613f422f 3317
bb4e9162
YST
3318 return '';
3319}
3320
3321sub ACTION_html {
3322 my $self = shift;
3323
3324 return unless $self->_mb_feature('HTML_support');
3325
3326 $self->depends_on('code');
3327
3328 foreach my $type ( qw(bin lib) ) {
7cf8bfc0
DG
3329 next unless ( $self->invoked_action eq 'html' || $self->_is_default_installable("${type}html"));
3330 $self->htmlify_pods( $type );
bb4e9162 3331 }
bb4e9162
YST
3332}
3333
bb4e9162
YST
3334# 1) If it's an ActiveState perl install, we need to run
3335# ActivePerl::DocTools->UpdateTOC;
3336# 2) Links to other modules are not being generated
3337sub htmlify_pods {
3338 my $self = shift;
3339 my $type = shift;
3340 my $htmldir = shift || File::Spec->catdir($self->blib, "${type}html");
3341
bb4e9162
YST
3342 $self->add_to_cleanup('pod2htm*');
3343
3344 my $pods = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
7cf8bfc0 3345 exclude => [ $self->file_qr('\.(?:bat|com|html)$') ] );
f943a5bf 3346 return unless %$pods; # nothing to do
bb4e9162
YST
3347
3348 unless ( -d $htmldir ) {
77e96e88 3349 File::Path::mkpath($htmldir, 0, oct(755))
bb4e9162
YST
3350 or die "Couldn't mkdir $htmldir: $!";
3351 }
3352
3353 my @rootdirs = ($type eq 'bin') ? qw(bin) :
3354 $self->installdirs eq 'core' ? qw(lib) : qw(site lib);
501ab549
DG
3355 my $podroot = $ENV{PERL_CORE}
3356 ? File::Basename::dirname($ENV{PERL_CORE})
3357 : $self->original_prefix('core');
7cf8bfc0
DG
3358
3359 my $htmlroot = $self->install_sets('core')->{libhtml};
46de787b
CBW
3360 my $podpath;
3361 unless (defined $self->args('html_links') and !$self->args('html_links')) {
3362 my @podpath = ( (map { File::Spec->abs2rel($_ ,$podroot) } grep { -d }
3363 ( $self->install_sets('core', 'lib'), # lib
3364 $self->install_sets('core', 'bin'), # bin
3365 $self->install_sets('site', 'lib'), # site/lib
3366 ) ), File::Spec->rel2abs($self->blib) );
bb4e9162 3367
46de787b
CBW
3368 $podpath = $ENV{PERL_CORE}
3369 ? File::Spec->catdir($podroot, 'lib')
3370 : join(":", map { tr,:\\,|/,; $_ } @podpath);
3371 }
bb4e9162 3372
7cf8bfc0
DG
3373 my $blibdir = join('/', File::Spec->splitdir(
3374 (File::Spec->splitpath(File::Spec->rel2abs($htmldir),1))[1]),''
3375 );
3376
3377 my ($with_ActiveState, $htmltool);
3378
3379 if ( $with_ActiveState = $self->_is_ActivePerl
3380 && eval { require ActivePerl::DocTools::Pod; 1 }
3381 ) {
3382 my $tool_v = ActiveState::DocTools::Pod->VERSION;
3383 $htmltool = "ActiveState::DocTools::Pod";
3384 $htmltool .= " $tool_v" if $tool_v && length $tool_v;
3385 }
3386 else {
3387 require Module::Build::PodParser;
3388 require Pod::Html;
3389 $htmltool = "Pod::Html " . Pod::Html->VERSION;
3390 }
3391 $self->log_verbose("Converting Pod to HTML with $htmltool\n");
3392
3393 my $errors = 0;
3394
3395 POD:
bb4e9162
YST
3396 foreach my $pod ( keys %$pods ) {
3397
3398 my ($name, $path) = File::Basename::fileparse($pods->{$pod},
7cf8bfc0
DG
3399 $self->file_qr('\.(?:pm|plx?|pod)$')
3400 );
bb4e9162 3401 my @dirs = File::Spec->splitdir( File::Spec->canonpath( $path ) );
86bddcbf 3402 pop( @dirs ) if scalar(@dirs) && $dirs[-1] eq File::Spec->curdir;
bb4e9162 3403
7cf8bfc0
DG
3404 my $fulldir = File::Spec->catdir($htmldir, @rootdirs, @dirs);
3405 my $tmpfile = File::Spec->catfile($fulldir, "${name}.tmp");
bb4e9162
YST
3406 my $outfile = File::Spec->catfile($fulldir, "${name}.html");
3407 my $infile = File::Spec->abs2rel($pod);
3408
3409 next if $self->up_to_date($infile, $outfile);
3410
3411 unless ( -d $fulldir ){
77e96e88 3412 File::Path::mkpath($fulldir, 0, oct(755))
bb4e9162
YST
3413 or die "Couldn't mkdir $fulldir: $!";
3414 }
3415
7cf8bfc0
DG
3416 $self->log_verbose("HTMLifying $infile -> $outfile\n");
3417 if ( $with_ActiveState ) {
3418 my $depth = @rootdirs + @dirs;
3419 my %opts = ( infile => $infile,
3420 outfile => $tmpfile,
46de787b 3421 ( defined($podpath) ? (podpath => $podpath) : ()),
7cf8bfc0
DG
3422 podroot => $podroot,
3423 index => 1,
3424 depth => $depth,
3425 );
3426 eval {
3427 ActivePerl::DocTools::Pod::pod2html(%opts);
3428 1;
3429 } or $self->log_warn("[$htmltool] pod2html (" .
3430 join(", ", map { "q{$_} => q{$opts{$_}}" } (keys %opts)) . ") failed: $@");
3431 } else {
46de787b
CBW
3432 my $path2root = File::Spec->catdir((File::Spec->updir) x @dirs);
3433 open(my $fh, '<', $infile) or die "Can't read $infile: $!";
7cf8bfc0
DG
3434 my $abstract = Module::Build::PodParser->new(fh => $fh)->get_abstract();
3435
3436 my $title = join( '::', (@dirs, $name) );
3437 $title .= " - $abstract" if $abstract;
3438
3439 my @opts = (
7cf8bfc0 3440 "--title=$title",
46de787b 3441 ( defined($podpath) ? "--podpath=$podpath" : ()),
7cf8bfc0
DG
3442 "--infile=$infile",
3443 "--outfile=$tmpfile",
3444 "--podroot=$podroot",
46de787b 3445 ($path2root ? "--htmlroot=$path2root" : ()),
7cf8bfc0
DG
3446 );
3447
2df9265e
DG
3448 unless ( eval{Pod::Html->VERSION(1.12)} ) {
3449 push( @opts, ('--flush') ); # caching removed in 1.12
3450 }