unless ($self->allow_mb_mismatch) {
my $mb_version = $Module::Build::VERSION;
die(" * ERROR: Configuration was initially created with Module::Build version '$self->{properties}{mb_version}',\n".
- " but we are now using version '$mb_version'. Please re-run the Build.PL or Makefile.PL script.\n")
+ " but we are now using version '$mb_version'. Please re-run the Build.PL or Makefile.PL script,\n".
+ " or use --allow_mb_mismatch 1 to skip this version check.\n")
if $mb_version ne $self->{properties}{mb_version};
}
# as it is during resume() (and thereafter).
{
local @ARGV = $package->unparse_args(\%args);
- do 'Build.PL';
+ do './Build.PL';
die $@ if $@;
}
return $package->resume;
my $exe = $c->get('exe_ext');
foreach my $thisperl ( @potential_perls ) {
- if ($proto->os_type eq 'VMS') {
- # VMS might have a file version at the end
- $thisperl .= $exe unless $thisperl =~ m/$exe(;\d+)?$/i;
- } elsif (defined $exe) {
+ if (defined $exe and $proto->os_type ne 'VMS') {
$thisperl .= $exe unless $thisperl =~ m/$exe$/i;
}
return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe?
}
+# NOTE this is a blocking operation if(-t STDIN)
sub _is_unattended {
my $self = shift;
- return $ENV{PERL_MM_USE_DEFAULT} || ( !$self->_is_interactive && eof STDIN );
+ return $ENV{PERL_MM_USE_DEFAULT} ||
+ ( !$self->_is_interactive && eof STDIN );
}
sub _readline {
my $mess = shift
or die "prompt() called without a prompt message";
- my $def;
- if ( $self->_is_unattended && !@_ ) {
+ # use a list to distinguish a default of undef() from no default
+ my @def;
+ @def = (shift) if @_;
+ # use dispdef for output
+ my @dispdef = scalar(@def) ?
+ ('[', (defined($def[0]) ? $def[0] . ' ' : ''), ']') :
+ (' ', '');
+
+ local $|=1;
+ print "$mess ", @dispdef;
+
+ if ( $self->_is_unattended && !@def ) {
die <<EOF;
ERROR: This build seems to be unattended, but there is no default value
for this question. Aborting.
EOF
}
- $def = shift if @_;
- ($def, my $dispdef) = defined $def ? ($def, "[$def] ") : ('', ' ');
-
- local $|=1;
- print "$mess $dispdef";
my $ans = $self->_readline();
if ( !defined($ans) # Ctrl-D or unattended
or !length($ans) ) { # User hit return
- print "$def\n";
- $ans = $def;
+ print "$dispdef[1]\n";
+ $ans = scalar(@def) ? $def[0] : '';
}
return $ans;
die "Invalid default value: y_n() default must be 'y' or 'n'"
if $def && $def !~ /^[yn]/i;
- if ( $self->_is_unattended && !$def ) {
- die <<EOF;
-ERROR: This build seems to be unattended, but there is no default value
-for this question. Aborting.
-EOF
- }
-
my $answer;
while (1) { # XXX Infinite or a large number followed by an exception ?
$answer = $self->prompt(@_);
my ($self) = @_;
my $file = $self->config_file('build_params')
- or die "No build_params?";
+ or die "Can't find 'build_params' in " . $self->config_dir;
my $fh = IO::File->new($file) or die "Can't read '$file': $!";
my $ref = eval do {local $/; <$fh>};
die if $@;
}
$args{ARGV} = \@argv;
+ for ('extra_compiler_flags', 'extra_linker_flags') {
+ $args{$_} = [ $self->split_like_shell($args{$_}) ] if exists $args{$_};
+ }
+
# Hashify these parameters
for ($self->hash_properties, 'config') {
next unless exists $args{$_};
}
+# (bash shell won't expand tildes mid-word: "--foo=~/thing")
+# TODO: handle ~user/foo
sub _detildefy {
my $arg = shift;
}
sub get_action_docs {
- my ($self, $action, $actions) = @_;
- $actions ||= $self->known_actions;
- $@ = '';
- ($@ = "No known action '$action'\n"), return
- unless $actions->{$action};
-
+ my ($self, $action) = @_;
+ my $actions = $self->known_actions;
+ die "No known action '$action'" unless $actions->{$action};
+
my ($files_found, @docs) = (0);
foreach my $class ($self->super_classes) {
(my $file = $class) =~ s{::}{/}g;
+ # NOTE: silently skipping relative paths if any chdir() happened
$file = $INC{$file . '.pm'} or next;
my $fh = IO::File->new("< $file") or next;
$files_found++;
-
+
# Code below modified from /usr/bin/perldoc
-
+
# Skip to ACTIONS section
local $_;
while (<$fh>) {
last if /^=head1 ACTIONS\s/;
}
-
- # Look for our action
- my ($found, $inlist) = (0, 0);
+
+ # Look for our action and determine the style
+ my $style;
while (<$fh>) {
- if (/^=item\s+\Q$action\E\b/) {
- $found = 1;
- } elsif (/^=(item|back)/) {
- last if $found > 1 and not $inlist;
+ last if /^=head1 /;
+
+ # only item and head2 are allowed (3&4 are not in 5.005)
+ if(/^=(item|head2)\s+\Q$action\E\b/) {
+ $style = $1;
+ push @docs, $_;
+ last;
}
- next unless $found;
- push @docs, $_;
- ++$inlist if /^=over/;
- --$inlist if /^=back/;
- ++$found if /^\w/; # Found descriptive text
}
+ $style or next; # not here
+
+ # and the content
+ if($style eq 'item') {
+ my ($found, $inlist) = (0, 0);
+ while (<$fh>) {
+ if (/^=(item|back)/) {
+ last unless $inlist;
+ }
+ push @docs, $_;
+ ++$inlist if /^=over/;
+ --$inlist if /^=back/;
+ }
+ }
+ else { # head2 style
+ # stop at anything equal or greater than the found level
+ while (<$fh>) {
+ last if(/^=(?:head[12]|cut)/);
+ push @docs, $_;
+ }
+ }
+ # TODO maybe disallow overriding just pod for an action
+ # TODO and possibly: @docs and last;
}
unless ($files_found) {
my $actions = $self->known_actions;
if (@{$self->{args}{ARGV}}) {
- my $msg = $self->get_action_docs($self->{args}{ARGV}[0], $actions) || "$@\n";
- print $msg;
+ my $msg = eval {$self->get_action_docs($self->{args}{ARGV}[0], $actions)};
+ print $@ ? "$@\n" : $msg;
return;
}
$self->do_tests;
}
+sub ACTION_testall {
+ my ($self) = @_;
+
+ my @types;
+ for my $action (grep { $_ ne 'all' } $self->get_test_types) {
+ # XXX We can't just dispatch because we get multiple summaries but
+ # we'll need to dispatch to support custom setup/teardown in the
+ # action. To support that, we'll need to call something besides
+ # Harness::runtests() because we'll need to collect the results in
+ # parts, then run the summary.
+ push(@types, $action);
+ #$self->_call_action( "test$action" );
+ }
+ $self->generic_test(types => ['default', @types]);
+}
+
+sub get_test_types {
+ my ($self) = @_;
+
+ my $t = $self->{properties}->{test_types};
+ return ( defined $t ? ( keys %$t ) : () );
+}
+
sub ACTION_test {
my ($self) = @_;
+ $self->generic_test(type => 'default');
+}
+
+sub generic_test {
+ my $self = shift;
+ (@_ % 2) and croak('Odd number of elements in argument hash');
+ my %args = @_;
+
my $p = $self->{properties};
-
+
+ my @types = (
+ (exists($args{type}) ? $args{type} : ()),
+ (exists($args{types}) ? @{$args{types}} : ()),
+ );
+ @types or croak "need some types of tests to check";
+
+ my %test_types = (
+ default => '.t',
+ (defined($p->{test_types}) ? %{$p->{test_types}} : ()),
+ );
+
+ for my $type (@types) {
+ croak "$type not defined in test_types!"
+ unless defined $test_types{ $type };
+ }
+
+ # we use local here because it ends up two method calls deep
+ local $p->{test_file_exts} = [ @test_types{@types} ];
$self->depends_on('code');
-
+
# Protect others against our @INC changes
local @INC = @INC;
sub expand_test_dir {
my ($self, $dir) = @_;
- return sort @{$self->rscan_dir($dir, qr{^[^.].*\.t$})} if $self->recursive_test_files;
- return sort glob File::Spec->catfile($dir, "*.t");
+ my $exts = $self->{properties}{test_file_exts} || ['.t'];
+
+ return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts
+ if $self->recursive_test_files;
+
+ return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts;
}
sub ACTION_testdb {
foreach my $file (keys %$files) {
my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
- $self->fix_shebang_line($result) unless $self->os_type eq 'VMS';
+ $self->fix_shebang_line($result) unless $self->is_vmsish;
$self->make_executable($result);
}
}
sub find_test_files {
my $self = shift;
my $p = $self->{properties};
-
+
if (my $files = $p->{test_files}) {
$files = [keys %$files] if UNIVERSAL::isa($files, 'HASH');
$files = [map { -d $_ ? $self->expand_test_dir($_) : $_ }
sub localize_file_path {
my ($self, $path) = @_;
- $path =~ s/\.\z// if $self->os_type eq 'VMS';
+ $path =~ s/\.\z// if $self->is_vmsish;
return File::Spec->catfile( split m{/}, $path );
}
$shb .= qq{
eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
if 0; # not running under some shell
-} unless $self->os_type eq 'Windows'; # this won't work on win32, so don't
+} unless $self->is_windowsish; # this won't work on win32, so don't
my $FIXOUT = IO::File->new(">$file.new")
or die "Can't create new $file: $!\n";
rename("$file.new", $file)
or die "Can't rename $file.new to $file: $!";
- unlink "$file.bak"
+ $self->delete_filetree("$file.bak")
or $self->log_warn("Couldn't clean up $file.bak, leaving it there");
$self->do_system($c->get('eunicefix'), $file) if $c->get('eunicefix') ne ':';
or die "The 'testpodcoverage' action requires ",
"Test::Pod::Coverage version 1.00";
+ # TODO this needs test coverage!
+
+ # XXX work-around a bug in Test::Pod::Coverage previous to v1.09
+ # Make sure we test the module in blib/
+ local @INC = @INC;
+ my $p = $self->{properties};
+ unshift(@INC,
+ # XXX any reason to include arch?
+ File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
+ #File::Spec->catdir($p->{base_dir}, $self->blib, 'arch')
+ );
+
all_pod_coverage_ok();
}
my %seen;
my $sep = $self->config('path_sep');
local $ENV{PERL5LIB} =
- ( length($ENV{PERL5LIB}) < 500
+ ( !exists($ENV{PERL5LIB}) ? '' :
+ length($ENV{PERL5LIB}) < 500
? $ENV{PERL5LIB}
: join $sep, grep { ! $seen{$_}++ and -d $_ } split($sep, $ENV{PERL5LIB})
);
File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777));
$self->log_info("Copying $file -> $to_path\n") if $args{verbose};
- File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!";
+
+ if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite
+ chmod 0666, $to_path;
+ File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!";
+ } else {
+ File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!";
+ }
+
# mode is read-only + (executable if source is executable)
my $mode = oct(444) | ( $self->is_executable($file) ? oct(111) : 0 );
chmod( $mode, $to_path );
perl(1), Module::Build(3)
=cut
+
+# vim:ts=8:sw=2:et:sta:sts=2
projects / p5sagit/p5-mst-13.2.git / blobdiff