@@ -1,3 +1,11 @@
+0.008 2014-11-18
+* bugfix: fixed a regression in 0.007 which changed the API of MDOM::Document::Gmake
+ and broke backward-compatibility.
+
+0.007 2014-11-18
+* bugfix: The test file pod-coverage.t was failing. thanks ambs (Alberto Simões)
+ for the original patch.
+
0.006 2011-08-28
* Fixed a syntax error in the POD documentation. thanks Mikhail Gusarov.
@@ -75,3 +75,5 @@ t/mdom/rule-simple.t
t/mdom/token.t
t/Shell.pm
TODO
+MYMETA.json
+MYMETA.yml
@@ -1,13 +1,14 @@
---
abstract: 'Simple DOM parser for Makefiles'
author:
- - "Zhang \"agentzh\" Yichun (章亦春) <agentzh@gmail.com>"
+ - "Yichun \"agentzh\" Zhang (章亦春) <agentzh@gmail.com>"
build_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.59
configure_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.59
distribution_type: module
-generated_by: 'Module::Install version 1.01'
+dynamic_config: 1
+generated_by: 'Module::Install version 1.06'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -26,4 +27,4 @@ requires:
resources:
license: http://dev.perl.org/licenses/
repository: http://github.com/agentzh/makefile-dom-pm
-version: 0.006
+version: 0.008
@@ -0,0 +1,53 @@
+{
+ "abstract" : "Simple DOM parser for Makefiles",
+ "author" : [
+ "Yichun \"agentzh\" Zhang (章亦春) <agentzh@gmail.com>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Module::Install version 1.06, CPAN::Meta::Converter version 2.131490",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Makefile-DOM",
+ "no_index" : {
+ "directory" : [
+ "inc",
+ "t"
+ ]
+ },
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.59"
+ }
+ },
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.59"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "Clone" : "0.18",
+ "Filter::Util::Call" : "0",
+ "List::MoreUtils" : "0.21",
+ "Params::Util" : "0.22",
+ "perl" : "5.006001"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "license" : [
+ "http://dev.perl.org/licenses/"
+ ],
+ "repository" : {
+ "url" : "http://github.com/agentzh/makefile-dom-pm"
+ }
+ },
+ "version" : "0.008"
+}
@@ -0,0 +1,26 @@
+---
+abstract: 'Simple DOM parser for Makefiles'
+author:
+ - "Yichun \"agentzh\" Zhang (ç« äº¦æ¥) <agentzh@gmail.com>"
+build_requires:
+ ExtUtils::MakeMaker: 6.59
+configure_requires:
+ ExtUtils::MakeMaker: 0
+dynamic_config: 0
+generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.131490'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Makefile-DOM
+no_index:
+ directory:
+ - t
+ - inc
+requires:
+ Clone: 0.18
+ Filter::Util::Call: 0
+ List::MoreUtils: 0.21
+ Params::Util: 0.22
+ perl: 5.006001
+version: 0.008
@@ -2,7 +2,8 @@ NAME
Makefile::DOM - Simple DOM parser for Makefiles
VERSION
- This document describes Makefile::DOM 0.006 released on 28 August 2011.
+ This document describes Makefile::DOM 0.008 released on 18 November
+ 2014.
DESCRIPTION
This libary can serve as an advanced lexer for (GNU) makefiles. It
@@ -222,8 +223,8 @@ OPERATIONS FOR MDOM TREES
by invoking its "content" method.
BUGS AND TODO
- The current implemenation of the MDOM::Document::Gmake lexer is based on
- a hand-written state machie. Although the efficiency of the engine is
+ The current implementation of the MDOM::Document::Gmake lexer is based
+ on a hand-written state machie. Although the efficiency of the engine is
not bad, the code is rather complicated and messy, which hurts both
extensibility and maintanabilty. So it's expected to rewrite the parser
using some grammatical tools like the Perl 6 regex engine
@@ -238,10 +239,10 @@ SOURCE REPOSITORY
If you want a commit bit, please let me know.
AUTHOR
- Zhang "agentzh" Yichun (章亦春) <agentzh@gmail.com>
+ Yichun "agentzh" Zhang (章亦春) <agentzh@gmail.com>
COPYRIGHT
- Copyright 2006-2011 by Zhang "agentzh" Yichun (章亦春).
+ Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
@@ -3,11 +3,12 @@ package Module::AutoInstall;
use strict;
use Cwd ();
+use File::Spec ();
use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.03';
+ $VERSION = '1.06';
}
# special map on pre-defined feature sets
@@ -17,11 +18,14 @@ my %FeatureMap = (
);
# various lexical flags
-my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
+my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS );
my (
- $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
+ $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps,
+ $UpgradeDeps
);
-my ( $PostambleActions, $PostambleUsed );
+my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps,
+ $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps,
+ $PostambleActionsListAllDeps, $PostambleUsed, $NoTest);
# See if it's a testing or non-interactive session
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
@@ -31,6 +35,10 @@ sub _accept_default {
$AcceptDefault = shift;
}
+sub _installdeps_target {
+ $InstallDepsTarget = shift;
+}
+
sub missing_modules {
return @Missing;
}
@@ -63,6 +71,11 @@ sub _init {
__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
exit 0;
}
+ elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) {
+ $UpgradeDeps = 1;
+ __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
+ exit 0;
+ }
elsif ( $arg =~ /^--default(?:deps)?$/ ) {
$AcceptDefault = 1;
}
@@ -125,7 +138,7 @@ sub import {
# check entirely since we don't want to have to load (and configure)
# an old CPAN just for a cosmetic message
- $UnderCPAN = _check_lock(1) unless $SkipInstall;
+ $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget;
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
@@ -175,7 +188,7 @@ sub import {
}
# XXX: check for conflicts and uninstalls(!) them.
- my $cur = _load($mod);
+ my $cur = _version_of($mod);
if (_version_cmp ($cur, $arg) >= 0)
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
@@ -207,6 +220,7 @@ sub import {
$CheckOnly
or ($mandatory and $UnderCPAN)
or $AllDeps
+ or $InstallDepsTarget
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
@@ -237,10 +251,17 @@ sub import {
}
}
- if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
+ if ( @Missing and not( $CheckOnly or $UnderCPAN) ) {
require Config;
- print
-"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
+ my $make = $Config::Config{make};
+ if ($InstallDepsTarget) {
+ print
+"*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n";
+ }
+ else {
+ print
+"*** Dependencies will be installed the next time you type '$make'.\n";
+ }
# make an educated guess of whether we'll need root permission.
print " (You may need to do that as the 'root' user.)\n"
@@ -271,6 +292,10 @@ END_MESSAGE
sub _check_lock {
return unless @Missing or @_;
+ if ($ENV{PERL5_CPANM_IS_RUNNING}) {
+ return _running_under('cpanminus');
+ }
+
my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
@@ -324,7 +349,7 @@ sub install {
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
- if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
else {
@@ -332,6 +357,11 @@ sub install {
}
}
+ if ($UpgradeDeps) {
+ push @modules, @installed;
+ @installed = ();
+ }
+
return @installed unless @modules; # nothing to do
return @installed if _check_lock(); # defer to the CPAN shell
@@ -363,7 +393,7 @@ sub install {
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
@@ -463,6 +493,11 @@ sub _cpanplus_config {
} else {
die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
}
+ push @config, 'prereqs', $value;
+ } elsif ( $key eq 'force' ) {
+ push @config, $key, $value;
+ } elsif ( $key eq 'notest' ) {
+ push @config, 'skiptest', $value;
} else {
die "*** Cannot convert option $key to CPANPLUS version.\n";
}
@@ -497,10 +532,14 @@ sub _install_cpan {
# set additional options
while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
( $args{$opt} = $arg, next )
- if $opt =~ /^force$/; # pseudo-option
+ if $opt =~ /^(?:force|notest)$/; # pseudo-option
$CPAN::Config->{$opt} = $arg;
}
+ if ($args{notest} && (not CPAN::Shell->can('notest'))) {
+ die "Your version of CPAN is too old to support the 'notest' pragma";
+ }
+
local $CPAN::Config->{prerequisites_policy} = 'follow';
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
@@ -519,8 +558,16 @@ sub _install_cpan {
delete $INC{$inc};
}
- my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
- : CPAN::Shell->install($pkg);
+ my $rv = do {
+ if ($args{force}) {
+ CPAN::Shell->force( install => $pkg )
+ } elsif ($args{notest}) {
+ CPAN::Shell->notest( install => $pkg )
+ } else {
+ CPAN::Shell->install($pkg)
+ }
+ };
+
$rv ||= eval {
$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
->{install}
@@ -575,7 +622,7 @@ sub _update_to {
my $ver = shift;
return
- if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
+ if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
@@ -660,16 +707,30 @@ sub _can_write {
# load a module and return the version it reports
sub _load {
- my $mod = pop; # class/instance doesn't matter
+ my $mod = pop; # method/function doesn't matter
my $file = $mod;
-
$file =~ s|::|/|g;
$file .= '.pm';
-
local $@;
return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
}
+# report version without loading a module
+sub _version_of {
+ my $mod = pop; # method/function doesn't matter
+ my $file = $mod;
+ $file =~ s|::|/|g;
+ $file .= '.pm';
+ foreach my $dir ( @INC ) {
+ next if ref $dir;
+ my $path = File::Spec->catfile($dir, $file);
+ next unless -e $path;
+ require ExtUtils::MM_Unix;
+ return ExtUtils::MM_Unix->parse_version($path);
+ }
+ return undef;
+}
+
# Load CPAN.pm and it's configuration
sub _load_cpan {
return if $CPAN::VERSION and $CPAN::Config and not @_;
@@ -763,6 +824,35 @@ sub _make_args {
: "\$(NOECHO) \$(NOOP)"
);
+ my $deps_list = join( ',', @Missing, @Existing );
+
+ $PostambleActionsUpgradeDeps =
+ "\$(PERL) $0 --config=$config --upgradedeps=$deps_list";
+
+ my $config_notest =
+ join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}),
+ 'notest', 1 )
+ if $Config;
+
+ $PostambleActionsNoTest = (
+ ($missing and not $UnderCPAN)
+ ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing"
+ : "\$(NOECHO) \$(NOOP)"
+ );
+
+ $PostambleActionsUpgradeDepsNoTest =
+ "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list";
+
+ $PostambleActionsListDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing);
+
+ my @all = (@Missing, @Existing);
+
+ $PostambleActionsListAllDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all);
+
return %args;
}
@@ -797,11 +887,15 @@ sub Write {
sub postamble {
$PostambleUsed = 1;
+ my $fragment;
- return <<"END_MAKE";
+ $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget;
config :: installdeps
\t\$(NOECHO) \$(NOOP)
+AUTO_INSTALL
+
+ $fragment .= <<"END_MAKE";
checkdeps ::
\t\$(PERL) $0 --checkdeps
@@ -809,12 +903,28 @@ checkdeps ::
installdeps ::
\t$PostambleActions
+installdeps_notest ::
+\t$PostambleActionsNoTest
+
+upgradedeps ::
+\t$PostambleActionsUpgradeDeps
+
+upgradedeps_notest ::
+\t$PostambleActionsUpgradeDepsNoTest
+
+listdeps ::
+\t$PostambleActionsListDeps
+
+listalldeps ::
+\t$PostambleActionsListAllDeps
+
END_MAKE
+ return $fragment;
}
1;
__END__
-#line 1071
+#line 1193
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.06';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -73,6 +73,17 @@ sub auto_install {
);
}
+sub installdeps_target {
+ my ($self, @args) = @_;
+
+ $self->include('Module::AutoInstall');
+ require Module::AutoInstall;
+
+ Module::AutoInstall::_installdeps_target(1);
+
+ $self->auto_install(@args);
+}
+
sub auto_install_now {
my $self = shift;
$self->auto_install(@_);
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.06';
}
# Suspend handler for "redefined" warnings
@@ -3,13 +3,12 @@ package Module::Install::Can;
use strict;
use Config ();
-use File::Spec ();
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.06';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -29,7 +28,7 @@ sub can_use {
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
-# check if we can run some command
+# Check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
@@ -38,14 +37,88 @@ sub can_run {
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
- my $abs = File::Spec->catfile($dir, $_[1]);
+ require File::Spec;
+ my $abs = File::Spec->catfile($dir, $cmd);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
-# can we locate a (the) C compiler
+# Can our C compiler environment build XS files
+sub can_xs {
+ my $self = shift;
+
+ # Ensure we have the CBuilder module
+ $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 );
+
+ # Do we have the configure_requires checker?
+ local $@;
+ eval "require ExtUtils::CBuilder;";
+ if ( $@ ) {
+ # They don't obey configure_requires, so it is
+ # someone old and delicate. Try to avoid hurting
+ # them by falling back to an older simpler test.
+ return $self->can_cc();
+ }
+
+ # Do we have a working C compiler
+ my $builder = ExtUtils::CBuilder->new(
+ quiet => 1,
+ );
+ unless ( $builder->have_compiler ) {
+ # No working C compiler
+ return 0;
+ }
+
+ # Write a C file representative of what XS becomes
+ require File::Temp;
+ my ( $FH, $tmpfile ) = File::Temp::tempfile(
+ "compilexs-XXXXX",
+ SUFFIX => '.c',
+ );
+ binmode $FH;
+ print $FH <<'END_C';
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+int main(int argc, char **argv) {
+ return 0;
+}
+
+int boot_sanexs() {
+ return 1;
+}
+
+END_C
+ close $FH;
+
+ # Can the C compiler access the same headers XS does
+ my @libs = ();
+ my $object = undef;
+ eval {
+ local $^W = 0;
+ $object = $builder->compile(
+ source => $tmpfile,
+ );
+ @libs = $builder->link(
+ objects => $object,
+ module_name => 'sanexs',
+ );
+ };
+ my $result = $@ ? 0 : 1;
+
+ # Clean up all the build files
+ foreach ( $tmpfile, $object, @libs ) {
+ next unless defined $_;
+ 1 while unlink;
+ }
+
+ return $result;
+}
+
+# Can we locate a (the) C compiler
sub can_cc {
my $self = shift;
my @chunks = split(/ /, $Config::Config{cc}) or return;
@@ -78,4 +151,4 @@ if ( $^O eq 'cygwin' ) {
__END__
-#line 156
+#line 236
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.06';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.06';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.06';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -215,18 +215,22 @@ sub write {
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
- # MakeMaker can complain about module versions that include
- # an underscore, even though its own version may contain one!
- # Hence the funny regexp to get rid of it. See RT #35800
- # for details.
- my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
- $self->build_requires( 'ExtUtils::MakeMaker' => $v );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
+ # This previous attempted to inherit the version of
+ # ExtUtils::MakeMaker in use by the module author, but this
+ # was found to be untenable as some authors build releases
+ # using future dev versions of EU:MM that nobody else has.
+ # Instead, #toolchain suggests we use 6.59 which is the most
+ # stable version on CPAN at time of writing and is, to quote
+ # ribasushi, "not terminally fucked, > and tested enough".
+ # TODO: We will now need to maintain this over time to push
+ # the version up as new versions are released.
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
- $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
@@ -241,7 +245,6 @@ in a module, and provide its file path via 'version_from' (or
'all_from' if you prefer) in Makefile.PL.
EOT
- $DB::single = 1;
if ( $self->tests ) {
my @tests = split ' ', $self->tests;
my %seen;
@@ -412,4 +415,4 @@ sub postamble {
__END__
-#line 541
+#line 544
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.06';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -151,15 +151,21 @@ sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
- my $self = shift;
- unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config\n";
- return $self;
+ my $self = shift;
+ my $value = @_ ? shift : 1;
+ if ( $self->{values}->{dynamic_config} ) {
+ # Once dynamic we never change to static, for safety
+ return 0;
}
- $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
+ $self->{values}->{dynamic_config} = $value ? 1 : 0;
return 1;
}
+# Convenience command
+sub static_config {
+ shift->dynamic_config(0);
+}
+
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
@@ -170,7 +176,7 @@ sub perl_version {
# Normalize the version
$version = $self->_perl_version($version);
- # We don't support the reall old versions
+ # We don't support the really old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
@@ -582,7 +588,7 @@ sub bugtracker_from {
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
- my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.06';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.06';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -31,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '1.01';
+ $VERSION = '1.06';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -451,7 +451,7 @@ sub _version ($) {
}
sub _cmp ($$) {
- _version($_[0]) <=> _version($_[1]);
+ _version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
@@ -467,4 +467,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2011 Adam Kennedy.
+# Copyright 2008 - 2012 Adam Kennedy.
@@ -1,17 +1,16 @@
#line 1
+use strict; use warnings;
package Spiffy;
-use strict;
-use 5.006001;
-use warnings;
+our $VERSION = '0.46';
+
use Carp;
require Exporter;
-our $VERSION = '0.30';
our @EXPORT = ();
our @EXPORT_BASE = qw(field const stub super);
our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
-my $stack_frame = 0;
+my $stack_frame = 0;
my $dump = 'yaml';
my $bases_map = {};
@@ -38,7 +37,7 @@ sub new {
my $method = shift;
$self->$method(shift);
}
- return $self;
+ return $self;
}
my $filtered_files = {};
@@ -46,7 +45,7 @@ my $filter_dump = 0;
my $filter_save = 0;
our $filter_result = '';
sub import {
- no strict 'refs';
+ no strict 'refs';
no warnings;
my $self_package = shift;
@@ -54,12 +53,12 @@ sub import {
# subclass's boolean_arguments and paired_arguments can conflict, causing
# difficult debugging. Consider using something truly local.
my ($args, @export_list) = do {
- local *boolean_arguments = sub {
+ local *boolean_arguments = sub {
qw(
- -base -Base -mixin -selfless
- -XXX -dumper -yaml
+ -base -Base -mixin -selfless
+ -XXX -dumper -yaml
-filter_dump -filter_save
- )
+ )
};
local *paired_arguments = sub { qw(-package) };
$self_package->parse_arguments(@_);
@@ -79,8 +78,8 @@ sub import {
unless grep /^XXX$/, @EXPORT_BASE;
}
- spiffy_filter()
- if ($args->{-selfless} or $args->{-Base}) and
+ spiffy_filter()
+ if ($args->{-selfless} or $args->{-Base}) and
not $filtered_files->{(caller($stack_frame))[1]}++;
my $caller_package = $args->{-package} || caller($stack_frame);
@@ -91,7 +90,7 @@ sub import {
next unless $class->isa('Spiffy');
my @export = grep {
not defined &{"$caller_package\::$_"};
- } ( @{"$class\::EXPORT"},
+ } ( @{"$class\::EXPORT"},
($args->{-Base} or $args->{-base})
? @{"$class\::EXPORT_BASE"} : (),
);
@@ -99,7 +98,7 @@ sub import {
not defined &{"$caller_package\::$_"};
} @{"$class\::EXPORT_OK"};
- # Avoid calling the expensive Exporter::export
+ # Avoid calling the expensive Exporter::export
# if there is nothing to do (optimization)
my %exportable = map { ($_, 1) } @export, @export_ok;
next unless keys %exportable;
@@ -163,7 +162,7 @@ sub base {
sub all_my_bases {
my $class = shift;
- return $bases_map->{$class}
+ return $bases_map->{$class}
if defined $bases_map->{$class};
my @bases = ($class);
@@ -175,10 +174,10 @@ sub all_my_bases {
$bases_map->{$class} = [grep {not $used->{$_}++} @bases];
}
-my %code = (
- sub_start =>
+my %code = (
+ sub_start =>
"sub {\n",
- set_default =>
+ set_default =>
" \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
init =>
" return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
@@ -189,13 +188,13 @@ my %code = (
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
" \$_[0]->{%s};\n" .
" } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
- return_if_get =>
+ return_if_get =>
" return \$_[0]->{%s} unless \$#_ > 0;\n",
- set =>
+ set =>
" \$_[0]->{%s} = \$_[1];\n",
- weaken =>
+ weaken =>
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
- sub_end =>
+ sub_end =>
" return \$_[0]->{%s};\n}\n",
);
@@ -223,13 +222,14 @@ sub field {
my $code = $code{sub_start};
if ($args->{-init}) {
my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
- $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
+ my @count = ($fragment =~ /(%s)/g);
+ $code .= sprintf $fragment, $field, $args->{-init}, ($field) x (@count - 2);
}
$code .= sprintf $code{set_default}, $field, $default_string, $field
if defined $default;
$code .= sprintf $code{return_if_get}, $field;
$code .= sprintf $code{set}, $field;
- $code .= sprintf $code{weaken}, $field, $field
+ $code .= sprintf $code{weaken}, $field, $field
if $args->{-weak};
$code .= sprintf $code{sub_end}, $field;
@@ -274,10 +274,10 @@ sub stub {
$package = $args->{-package} if defined $args->{-package};
no strict 'refs';
return if defined &{"${package}::$field"};
- *{"${package}::$field"} =
- sub {
+ *{"${package}::$field"} =
+ sub {
require Carp;
- Carp::confess
+ Carp::confess
"Method $field in package $package must be subclassed";
}
}
@@ -301,7 +301,7 @@ sub parse_arguments {
push @values, $elem;
}
}
- return wantarray ? ($args, @values) : $args;
+ return wantarray ? ($args, @values) : $args;
}
sub boolean_arguments { () }
@@ -325,8 +325,8 @@ sub id {
package DB;
{
no warnings 'redefine';
- sub super_args {
- my @dummy = caller(@_ ? $_[0] : 2);
+ sub super_args {
+ my @dummy = caller(@_ ? $_[0] : 2);
return @DB::args;
}
}
@@ -397,7 +397,7 @@ sub spiffy_base_import {
my $inheritor = caller(0);
for my $base_class (@base_classes) {
next if $inheritor->isa($base_class);
- croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
+ croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
"See the documentation of Spiffy.pm for details\n "
unless $base_class->isa('Spiffy');
$stack_frame = 1; # tell import to use different caller
@@ -439,7 +439,7 @@ sub spiffy_mixin_methods {
$methods{$_}
? ($_, \ &{"$methods{$_}\::$_"})
: ($_, \ &{"$mixin_class\::$_"})
- } @_
+ } @_
? (get_roles($mixin_class, @_))
: (keys %methods);
}
@@ -450,12 +450,12 @@ sub get_roles {
while (grep /^!*:/, @roles) {
@roles = map {
s/!!//g;
- /^!:(.*)/ ? do {
- my $m = "_role_$1";
+ /^!:(.*)/ ? do {
+ my $m = "_role_$1";
map("!$_", $mixin_class->$m);
} :
/^:(.*)/ ? do {
- my $m = "_role_$1";
+ my $m = "_role_$1";
($mixin_class->$m);
} :
($_)
@@ -533,7 +533,3 @@ sub ZZZ {
}
1;
-
-__END__
-
-#line 1066
@@ -336,6 +336,4 @@ sub _write_to {
or die "Couldn't close $filename: $!\n";
}
-__DATA__
-
-#line 636
+1;
@@ -1,9 +1,22 @@
#line 1
package Test::Base;
-use 5.006001;
-use Spiffy 0.30 -Base;
+our $VERSION = '0.88';
+
+use Spiffy -Base;
use Spiffy ':XXX';
-our $VERSION = '0.60';
+
+my $HAS_PROVIDER;
+BEGIN {
+ $HAS_PROVIDER = eval "require Test::Builder::Provider; 1";
+
+ if ($HAS_PROVIDER) {
+ Test::Builder::Provider->import('provides');
+ }
+ else {
+ *provides = sub { 1 };
+ }
+}
+
my @test_more_exports;
BEGIN {
@@ -24,9 +37,9 @@ our @EXPORT = (@test_more_exports, qw(
is no_diff
blocks next_block first_block
- delimiters spec_file spec_string
+ delimiters spec_file spec_string
filters filters_delay filter_arguments
- run run_compare run_is run_is_deeply run_like run_unlike
+ run run_compare run_is run_is_deeply run_like run_unlike
skip_all_unless_require is_deep run_is_deep
WWW XXX YYY ZZZ
tie_output no_diag_on_only
@@ -59,7 +72,7 @@ my $default_class;
my $default_object;
my $reserved_section_names = {};
-sub default_object {
+sub default_object {
$default_object ||= $default_class->new;
return $default_object;
}
@@ -67,7 +80,7 @@ sub default_object {
my $import_called = 0;
sub import() {
$import_called = 1;
- my $class = (grep /^-base$/i, @_)
+ my $class = (grep /^-base$/i, @_)
? scalar(caller)
: $_[0];
if (not defined $default_class) {
@@ -90,7 +103,7 @@ sub import() {
Test::More->import(import => \@test_more_exports, @args)
if @args;
}
-
+
_strict_warnings();
goto &Spiffy::import;
}
@@ -147,14 +160,14 @@ sub blocks() {
if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
my $blocks = $self->block_list;
-
+
my $section_name = shift || '';
my @blocks = $section_name
? (grep { exists $_->{$section_name} } @$blocks)
: (@$blocks);
return scalar(@blocks) unless wantarray;
-
+
return (@blocks) if $self->_filters_delay;
for my $block (@blocks) {
@@ -225,7 +238,7 @@ sub filters() {
if (ref($_[0]) eq 'HASH') {
$self->_filters_map(shift);
}
- else {
+ else {
my $filters = $self->_filters;
push @$filters, @_;
}
@@ -242,23 +255,24 @@ sub have_text_diff {
$Algorithm::Diff::VERSION >= 1.15;
}
+provides 'is';
sub is($$;$) {
(my ($self), @_) = find_my_self(@_);
my ($actual, $expected, $name) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ local $Test::Builder::Level = $Test::Builder::Level + 1 unless $HAS_PROVIDER;
if ($ENV{TEST_SHOW_NO_DIFFS} or
not defined $actual or
not defined $expected or
- $actual eq $expected or
- not($self->have_text_diff) or
+ $actual eq $expected or
+ not($self->have_text_diff) or
$expected !~ /\n./s
) {
Test::More::is($actual, $expected, $name);
}
else {
$name = '' unless defined $name;
- ok $actual eq $expected,
- $name . "\n" . Text::Diff::diff(\$expected, \$actual);
+ ok $actual eq $expected, $name;
+ diag Text::Diff::diff(\$expected, \$actual);
}
}
@@ -322,7 +336,7 @@ sub run_is() {
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
- is($block->$x, $block->$y,
+ is($block->$x, $block->$y,
$block->name ? $block->name : ()
);
}
@@ -335,7 +349,7 @@ sub run_is_deeply() {
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
- is_deeply($block->$x, $block->$y,
+ is_deeply($block->$x, $block->$y,
$block->name ? $block->name : ()
);
}
@@ -391,7 +405,7 @@ sub run_is_deep() {
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
$block->run_filters unless $block->is_filtered;
- is_deep($block->$x, $block->$y,
+ is_deep($block->$x, $block->$y,
$block->name ? $block->name : ()
);
}
@@ -462,7 +476,7 @@ sub _make_block {
}
$description =~ s/\s*\z//;
$block->set_value(description => $description);
-
+
my $section_map = {};
my $section_order = [];
while (@parts) {
@@ -499,9 +513,9 @@ sub _spec_init {
$spec = <FILE>;
close FILE;
}
- else {
- $spec = do {
- package main;
+ else {
+ $spec = do {
+ package main;
no warnings 'once';
<DATA>;
};
@@ -617,7 +631,7 @@ sub run_filters {
join '', @value;
my $old = $_;
@value = &$function(@value);
- if (not(@value) or
+ if (not(@value) or
@value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/
) {
if ($value[0] && $_ eq $old) {
@@ -650,7 +664,7 @@ sub _get_filters {
$map_filters = [ $map_filters ] unless ref $map_filters;
my @append = ();
for (
- @{$self->blocks_object->_filters},
+ @{$self->blocks_object->_filters},
@$map_filters,
split(/\s+/, $string),
) {
@@ -675,8 +689,4 @@ sub _get_filters {
} keys(%Test::Base::Block::), qw( new DESTROY );
}
-__DATA__
-
-=encoding utf8
-
-#line 1374
+1;
@@ -3,24 +3,16 @@ package Test::Builder::Module;
use strict;
-use Test::Builder;
+use Test::Builder 0.99;
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '0.92';
+our $VERSION = '1.001009';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-# 5.004's Exporter doesn't have export_to_level.
-my $_export_to_level = sub {
- my $pkg = shift;
- my $level = shift;
- (undef) = shift; # redundant arg
- my $callpkg = caller($level);
- $pkg->export( $callpkg, @_ );
-};
-#line 82
+#line 74
sub import {
my($class) = shift;
@@ -39,7 +31,7 @@ sub import {
$test->plan(@_);
- $class->$_export_to_level( 1, $class, @imports );
+ $class->export_to_level( 1, $class, @imports );
}
sub _strip_imports {
@@ -68,11 +60,11 @@ sub _strip_imports {
return @imports;
}
-#line 145
+#line 137
sub import_extra { }
-#line 175
+#line 167
sub builder {
return Test::Builder->new;
@@ -5,7 +5,7 @@ use 5.006;
use strict;
use warnings;
-our $VERSION = '0.92';
+our $VERSION = '1.001009';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
BEGIN {
@@ -24,7 +24,7 @@ BEGIN {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
- # occassionally forget the contents of the variable when sharing it.
+ # occasionally forget the contents of the variable when sharing it.
# So we first copy the data, then share, then put our copy back.
*share = sub (\[$@%]) {
my $type = ref $_[0];
@@ -71,7 +71,7 @@ BEGIN {
#line 117
-my $Test = Test::Builder->new;
+our $Test = Test::Builder->new;
sub new {
my($class) = shift;
@@ -90,7 +90,193 @@ sub create {
return $self;
}
-#line 158
+
+# Copy an object, currently a shallow.
+# This does *not* bless the destination. This keeps the destructor from
+# firing when we're just storing a copy of the object to restore later.
+sub _copy {
+ my($src, $dest) = @_;
+
+ %$dest = %$src;
+ _share_keys($dest);
+
+ return;
+}
+
+
+#line 182
+
+sub child {
+ my( $self, $name ) = @_;
+
+ if( $self->{Child_Name} ) {
+ $self->croak("You already have a child named ($self->{Child_Name}) running");
+ }
+
+ my $parent_in_todo = $self->in_todo;
+
+ # Clear $TODO for the child.
+ my $orig_TODO = $self->find_TODO(undef, 1, undef);
+
+ my $class = ref $self;
+ my $child = $class->create;
+
+ # Add to our indentation
+ $child->_indent( $self->_indent . ' ' );
+
+ # Make the child use the same outputs as the parent
+ for my $method (qw(output failure_output todo_output)) {
+ $child->$method( $self->$method );
+ }
+
+ # Ensure the child understands if they're inside a TODO
+ if( $parent_in_todo ) {
+ $child->failure_output( $self->todo_output );
+ }
+
+ # This will be reset in finalize. We do this here lest one child failure
+ # cause all children to fail.
+ $child->{Child_Error} = $?;
+ $? = 0;
+ $child->{Parent} = $self;
+ $child->{Parent_TODO} = $orig_TODO;
+ $child->{Name} = $name || "Child of " . $self->name;
+ $self->{Child_Name} = $child->name;
+ return $child;
+}
+
+
+#line 233
+
+sub subtest {
+ my $self = shift;
+ my($name, $subtests, @args) = @_;
+
+ if ('CODE' ne ref $subtests) {
+ $self->croak("subtest()'s second argument must be a code ref");
+ }
+
+ # Turn the child into the parent so anyone who has stored a copy of
+ # the Test::Builder singleton will get the child.
+ my $error;
+ my $child;
+ my $parent = {};
+ {
+ # child() calls reset() which sets $Level to 1, so we localize
+ # $Level first to limit the scope of the reset to the subtest.
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ # Store the guts of $self as $parent and turn $child into $self.
+ $child = $self->child($name);
+ _copy($self, $parent);
+ _copy($child, $self);
+
+ my $run_the_subtests = sub {
+ # Add subtest name for clarification of starting point
+ $self->note("Subtest: $name");
+ $subtests->(@args);
+ $self->done_testing unless $self->_plan_handled;
+ 1;
+ };
+
+ if( !eval { $run_the_subtests->() } ) {
+ $error = $@;
+ }
+ }
+
+ # Restore the parent and the copied child.
+ _copy($self, $child);
+ _copy($parent, $self);
+
+ # Restore the parent's $TODO
+ $self->find_TODO(undef, 1, $child->{Parent_TODO});
+
+ # Die *after* we restore the parent.
+ die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $finalize = $child->finalize;
+
+ $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out};
+
+ return $finalize;
+}
+
+#line 312
+
+sub _plan_handled {
+ my $self = shift;
+ return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
+}
+
+
+#line 337
+
+sub finalize {
+ my $self = shift;
+
+ return unless $self->parent;
+ if( $self->{Child_Name} ) {
+ $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
+ }
+
+ local $? = 0; # don't fail if $subtests happened to set $? nonzero
+ $self->_ending;
+
+ # XXX This will only be necessary for TAP envelopes (we think)
+ #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $ok = 1;
+ $self->parent->{Child_Name} = undef;
+ unless ($self->{Bailed_Out}) {
+ if ( $self->{Skip_All} ) {
+ $self->parent->skip($self->{Skip_All}, $self->name);
+ }
+ elsif ( not @{ $self->{Test_Results} } ) {
+ $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
+ }
+ else {
+ $self->parent->ok( $self->is_passing, $self->name );
+ }
+ }
+ $? = $self->{Child_Error};
+ delete $self->{Parent};
+
+ return $self->is_passing;
+}
+
+sub _indent {
+ my $self = shift;
+
+ if( @_ ) {
+ $self->{Indent} = shift;
+ }
+
+ return $self->{Indent};
+}
+
+#line 392
+
+sub parent { shift->{Parent} }
+
+#line 404
+
+sub name { shift->{Name} }
+
+sub DESTROY {
+ my $self = shift;
+ if ( $self->parent and $$ == $self->{Original_Pid} ) {
+ my $name = $self->name;
+ $self->diag(<<"FAIL");
+Child ($name) exited without calling finalize()
+FAIL
+ $self->parent->{In_Destroy} = 1;
+ $self->parent->ok(0, $name);
+ }
+}
+
+#line 428
our $Level;
@@ -101,13 +287,18 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
# hash keys is just asking for pain. Also, it was documented.
$Level = 1;
+ $self->{Name} = $0;
+ $self->is_passing(1);
+ $self->{Ending} = 0;
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Have_Output_Plan} = 0;
+ $self->{Done_Testing} = 0;
$self->{Original_Pid} = $$;
+ $self->{Child_Name} = undef;
+ $self->{Indent} ||= '';
- share( $self->{Curr_Test} );
$self->{Curr_Test} = 0;
$self->{Test_Results} = &share( [] );
@@ -126,12 +317,26 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
$self->{Start_Todo} = 0;
$self->{Opened_Testhandles} = 0;
+ $self->_share_keys;
$self->_dup_stdhandles;
return;
}
-#line 219
+
+# Shared scalar values are lost when a hash is copied, so we have
+# a separate method to restore them.
+# Shared references are retained across copies.
+sub _share_keys {
+ my $self = shift;
+
+ share( $self->{Curr_Test} );
+
+ return;
+}
+
+
+#line 520
my %plan_cmds = (
no_plan => \&no_plan,
@@ -178,8 +383,7 @@ sub _plan_tests {
return;
}
-
-#line 275
+#line 575
sub expected_tests {
my $self = shift;
@@ -197,7 +401,7 @@ sub expected_tests {
return $self->{Expected_Tests};
}
-#line 299
+#line 599
sub no_plan {
my($self, $arg) = @_;
@@ -210,8 +414,7 @@ sub no_plan {
return 1;
}
-
-#line 333
+#line 632
sub _output_plan {
my($self, $max, $directive, $reason) = @_;
@@ -229,7 +432,8 @@ sub _output_plan {
return;
}
-#line 384
+
+#line 684
sub done_testing {
my($self, $num_tests) = @_;
@@ -262,11 +466,17 @@ sub done_testing {
$self->{Have_Plan} = 1;
+ # The wrong number of tests were run
+ $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
+
+ # No tests were run
+ $self->is_passing(0) if $self->{Curr_Test} == 0;
+
return 1;
}
-#line 429
+#line 735
sub has_plan {
my $self = shift;
@@ -276,18 +486,21 @@ sub has_plan {
return(undef);
}
-#line 446
+#line 752
sub skip_all {
my( $self, $reason ) = @_;
- $self->{Skip_All} = 1;
+ $self->{Skip_All} = $self->parent ? $reason : 1;
$self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
+ if ( $self->parent ) {
+ die bless {} => 'Test::Builder::Exception';
+ }
exit(0);
}
-#line 468
+#line 777
sub exported_to {
my( $self, $pack ) = @_;
@@ -298,11 +511,16 @@ sub exported_to {
return $self->{Exported_To};
}
-#line 498
+#line 807
sub ok {
my( $self, $test, $name ) = @_;
+ if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
+ $name = 'unnamed test' unless defined $name;
+ $self->is_passing(0);
+ $self->croak("Cannot run test ($name) with active children");
+ }
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
@@ -378,9 +596,27 @@ ERR
}
}
+ $self->is_passing(0) unless $test || $self->in_todo;
+
+ # Check that we haven't violated the plan
+ $self->_check_is_passing_plan();
+
return $test ? 1 : 0;
}
+
+# Check that we haven't yet violated the plan and set
+# is_passing() accordingly
+sub _check_is_passing_plan {
+ my $self = shift;
+
+ my $plan = $self->has_plan;
+ return unless defined $plan; # no plan yet defined
+ return unless $plan !~ /\D/; # no numeric plan
+ $self->is_passing(0) if $plan < $self->{Curr_Test};
+}
+
+
sub _unoverload {
my $self = shift;
my $type = shift;
@@ -432,17 +668,15 @@ sub _is_dualvar {
no warnings 'numeric';
my $numval = $val + 0;
- return $numval != 0 and $numval ne $val ? 1 : 0;
+ return ($numval != 0 and $numval ne $val ? 1 : 0);
}
-#line 649
+#line 985
sub is_eq {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
- $self->_unoverload_str( \$got, \$expect );
-
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
@@ -459,8 +693,6 @@ sub is_num {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
- $self->_unoverload_num( \$got, \$expect );
-
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
@@ -518,7 +750,7 @@ sub _isnt_diag {
DIAGNOSTIC
}
-#line 746
+#line 1078
sub isnt_eq {
my( $self, $got, $dont_expect, $name ) = @_;
@@ -552,30 +784,37 @@ sub isnt_num {
return $self->cmp_ok( $got, '!=', $dont_expect, $name );
}
-#line 797
+#line 1127
sub like {
- my( $self, $this, $regex, $name ) = @_;
+ my( $self, $thing, $regex, $name ) = @_;
local $Level = $Level + 1;
- return $self->_regex_ok( $this, $regex, '=~', $name );
+ return $self->_regex_ok( $thing, $regex, '=~', $name );
}
sub unlike {
- my( $self, $this, $regex, $name ) = @_;
+ my( $self, $thing, $regex, $name ) = @_;
local $Level = $Level + 1;
- return $self->_regex_ok( $this, $regex, '!~', $name );
+ return $self->_regex_ok( $thing, $regex, '!~', $name );
}
-#line 821
+#line 1151
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
+# Bad, these are not comparison operators. Should we include more?
+my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
+
sub cmp_ok {
my( $self, $got, $type, $expect, $name ) = @_;
- my $test;
+ if ($cmp_ok_bl{$type}) {
+ $self->croak("$type is not a valid comparison operator in cmp_ok()");
+ }
+
+ my ($test, $succ);
my $error;
{
## no critic (BuiltinFunctions::ProhibitStringyEval)
@@ -584,9 +823,11 @@ sub cmp_ok {
my($pack, $file, $line) = $self->caller();
- $test = eval qq[
-#line 1 "cmp_ok [from $file line $line]"
-\$got $type \$expect;
+ # This is so that warnings come out at the caller's level
+ $succ = eval qq[
+#line $line "(eval in cmp_ok) $file"
+\$test = (\$got $type \$expect);
+1;
];
$error = $@;
}
@@ -600,7 +841,7 @@ sub cmp_ok {
? '_unoverload_num'
: '_unoverload_str';
- $self->diag(<<"END") if $error;
+ $self->diag(<<"END") unless $succ;
An error occurred while using $type:
------------------------------------
$error
@@ -648,25 +889,36 @@ sub _caller_context {
return $code;
}
-#line 920
+#line 1259
sub BAIL_OUT {
my( $self, $reason ) = @_;
$self->{Bailed_Out} = 1;
+
+ if ($self->parent) {
+ $self->{Bailed_Out_Reason} = $reason;
+ $self->no_ending(1);
+ die bless {} => 'Test::Builder::Exception';
+ }
+
$self->_print("Bail out! $reason");
exit 255;
}
-#line 933
+#line 1279
-*BAILOUT = \&BAIL_OUT;
+{
+ no warnings 'once';
+ *BAILOUT = \&BAIL_OUT;
+}
-#line 944
+#line 1293
sub skip {
- my( $self, $why ) = @_;
+ my( $self, $why, $name ) = @_;
$why ||= '';
+ $name = '' unless defined $name;
$self->_unoverload_str( \$why );
lock( $self->{Curr_Test} );
@@ -676,7 +928,7 @@ sub skip {
{
'ok' => 1,
actual_ok => 1,
- name => '',
+ name => $name,
type => 'skip',
reason => $why,
}
@@ -693,7 +945,7 @@ sub skip {
return 1;
}
-#line 985
+#line 1335
sub todo_skip {
my( $self, $why ) = @_;
@@ -721,7 +973,7 @@ sub todo_skip {
return 1;
}
-#line 1062
+#line 1415
sub maybe_regex {
my( $self, $regex ) = @_;
@@ -756,7 +1008,7 @@ sub _is_qr {
}
sub _regex_ok {
- my( $self, $this, $regex, $cmp, $name ) = @_;
+ my( $self, $thing, $regex, $cmp, $name ) = @_;
my $ok = 0;
my $usable_regex = $self->maybe_regex($regex);
@@ -768,18 +1020,19 @@ sub _regex_ok {
}
{
- ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
my $test;
- my $code = $self->_caller_context;
+ my $context = $self->_caller_context;
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
- # Yes, it has to look like this or 5.4.5 won't see the #line
- # directive.
- # Don't ask me, man, I just work here.
- $test = eval "
-$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ # No point in issuing an uninit warning, they'll see it in the diagnostics
+ no warnings 'uninitialized';
+
+ $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
+ }
$test = !$test if $cmp eq '!~';
@@ -788,11 +1041,11 @@ $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
}
unless($ok) {
- $this = defined $this ? "'$this'" : 'undef';
+ $thing = defined $thing ? "'$thing'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
local $Level = $Level + 1;
- $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
+ $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
%s
%13s '%s'
DIAGNOSTIC
@@ -805,7 +1058,7 @@ DIAGNOSTIC
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
-#line 1162
+#line 1516
sub _try {
my( $self, $code, %opts ) = @_;
@@ -825,7 +1078,7 @@ sub _try {
return wantarray ? ( $return, $error ) : $return;
}
-#line 1191
+#line 1545
sub is_fh {
my $self = shift;
@@ -836,11 +1089,10 @@ sub is_fh {
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
return eval { $maybe_fh->isa("IO::Handle") } ||
- # 5.5.4's tied() and can() doesn't like getting undef
- eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
+ eval { tied($maybe_fh)->can('TIEHANDLE') };
}
-#line 1235
+#line 1588
sub level {
my( $self, $level ) = @_;
@@ -851,7 +1103,7 @@ sub level {
return $Level;
}
-#line 1267
+#line 1620
sub use_numbers {
my( $self, $use_nums ) = @_;
@@ -862,7 +1114,7 @@ sub use_numbers {
return $self->{Use_Nums};
}
-#line 1300
+#line 1653
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
@@ -880,7 +1132,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
*{ __PACKAGE__ . '::' . $method } = $code;
}
-#line 1353
+#line 1706
sub diag {
my $self = shift;
@@ -888,7 +1140,7 @@ sub diag {
$self->_print_comment( $self->_diag_fh, @_ );
}
-#line 1368
+#line 1721
sub note {
my $self = shift;
@@ -925,7 +1177,7 @@ sub _print_comment {
return 0;
}
-#line 1418
+#line 1771
sub explain {
my $self = shift;
@@ -944,7 +1196,7 @@ sub explain {
} @_;
}
-#line 1447
+#line 1800
sub _print {
my $self = shift;
@@ -959,20 +1211,21 @@ sub _print_to_fh {
return if $^C;
my $msg = join '', @msgs;
+ my $indent = $self->_indent;
local( $\, $", $, ) = ( undef, ' ', '' );
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
- $msg =~ s{\n(?!\z)}{\n# }sg;
+ $msg =~ s{\n(?!\z)}{\n$indent# }sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\z/;
- return print $fh $msg;
+ return print $fh $indent, $msg;
}
-#line 1506
+#line 1860
sub output {
my( $self, $fh ) = @_;
@@ -1068,8 +1321,8 @@ sub _open_testhandles {
open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
- # $self->_copy_io_layers( \*STDOUT, $Testout );
- # $self->_copy_io_layers( \*STDERR, $Testerr );
+ $self->_copy_io_layers( \*STDOUT, $Testout );
+ $self->_copy_io_layers( \*STDERR, $Testerr );
$self->{Opened_Testhandles} = 1;
@@ -1084,14 +1337,22 @@ sub _copy_io_layers {
require PerlIO;
my @src_layers = PerlIO::get_layers($src);
- binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
+ _apply_layers($dst, @src_layers) if @src_layers;
}
);
return;
}
-#line 1631
+sub _apply_layers {
+ my ($fh, @layers) = @_;
+ my %seen;
+ my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
+ binmode($fh, join(":", "", "raw", @unique));
+}
+
+
+#line 1993
sub reset_outputs {
my $self = shift;
@@ -1103,7 +1364,7 @@ sub reset_outputs {
return;
}
-#line 1657
+#line 2019
sub _message_at_caller {
my $self = shift;
@@ -1124,7 +1385,7 @@ sub croak {
}
-#line 1697
+#line 2059
sub current_test {
my( $self, $num ) = @_;
@@ -1157,7 +1418,20 @@ sub current_test {
return $self->{Curr_Test};
}
-#line 1739
+#line 2107
+
+sub is_passing {
+ my $self = shift;
+
+ if( @_ ) {
+ $self->{Is_Passing} = shift;
+ }
+
+ return $self->{Is_Passing};
+}
+
+
+#line 2129
sub summary {
my($self) = shift;
@@ -1165,14 +1439,14 @@ sub summary {
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
-#line 1794
+#line 2184
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
-#line 1823
+#line 2213
sub todo {
my( $self, $pack ) = @_;
@@ -1186,19 +1460,21 @@ sub todo {
return '';
}
-#line 1845
+#line 2240
sub find_TODO {
- my( $self, $pack ) = @_;
+ my( $self, $pack, $set, $new_value ) = @_;
$pack = $pack || $self->caller(1) || $self->exported_to;
return unless $pack;
no strict 'refs'; ## no critic
- return ${ $pack . '::TODO' };
+ my $old_value = ${ $pack . '::TODO' };
+ $set and ${ $pack . '::TODO' } = $new_value;
+ return $old_value;
}
-#line 1863
+#line 2260
sub in_todo {
my $self = shift;
@@ -1207,7 +1483,7 @@ sub in_todo {
return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
}
-#line 1913
+#line 2310
sub todo_start {
my $self = shift;
@@ -1222,7 +1498,7 @@ sub todo_start {
return;
}
-#line 1935
+#line 2332
sub todo_end {
my $self = shift;
@@ -1243,7 +1519,7 @@ sub todo_end {
return;
}
-#line 1968
+#line 2365
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
my( $self, $height ) = @_;
@@ -1258,9 +1534,9 @@ sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
return wantarray ? @caller : $caller[0];
}
-#line 1985
+#line 2382
-#line 1999
+#line 2396
#'#
sub _sanity_check {
@@ -1273,7 +1549,7 @@ sub _sanity_check {
return;
}
-#line 2020
+#line 2417
sub _whoa {
my( $self, $check, $desc ) = @_;
@@ -1288,7 +1564,7 @@ WHOA
return;
}
-#line 2044
+#line 2441
sub _my_exit {
$? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
@@ -1296,10 +1572,12 @@ sub _my_exit {
return 1;
}
-#line 2056
+#line 2453
sub _ending {
my $self = shift;
+ return if $self->no_ending;
+ return if $self->{Ending}++;
my $real_exit_code = $?;
@@ -1311,7 +1589,28 @@ sub _ending {
# Ran tests but never declared a plan or hit done_testing
if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
+ $self->is_passing(0);
$self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
+
+ if($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
+FAIL
+ $self->is_passing(0);
+ _my_exit($real_exit_code) && return;
+ }
+
+ # But if the tests ran, handle exit code.
+ my $test_results = $self->{Test_Results};
+ if(@$test_results) {
+ my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
+ if ($num_failed > 0) {
+
+ my $exit_code = $num_failed <= 254 ? $num_failed : 254;
+ _my_exit($exit_code) && return;
+ }
+ }
+ _my_exit(254) && return;
}
# Exit if plan() was never called. This is so "require Test::Simple"
@@ -1322,9 +1621,9 @@ sub _ending {
# Don't do an ending if we bailed out.
if( $self->{Bailed_Out} ) {
+ $self->is_passing(0);
return;
}
-
# Figure out if we passed or failed and print helpful messages.
my $test_results = $self->{Test_Results};
if(@$test_results) {
@@ -1352,6 +1651,7 @@ sub _ending {
$self->diag(<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
FAIL
+ $self->is_passing(0);
}
if($num_failed) {
@@ -1363,13 +1663,14 @@ FAIL
$self->diag(<<"FAIL");
Looks like you failed $num_failed test$s of $num_tests$qualifier.
FAIL
+ $self->is_passing(0);
}
if($real_exit_code) {
$self->diag(<<"FAIL");
Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
FAIL
-
+ $self->is_passing(0);
_my_exit($real_exit_code) && return;
}
@@ -1393,21 +1694,24 @@ FAIL
$self->diag(<<"FAIL");
Looks like your test exited with $real_exit_code before it could output anything.
FAIL
+ $self->is_passing(0);
_my_exit($real_exit_code) && return;
}
else {
$self->diag("No tests run!\n");
+ $self->is_passing(0);
_my_exit(255) && return;
}
+ $self->is_passing(0);
$self->_whoa( 1, "We fell off the end of _ending()" );
}
END {
- $Test->_ending if defined $Test and !$Test->no_ending;
+ $Test->_ending if defined $Test;
}
-#line 2236
+#line 2669
1;
@@ -10,7 +10,7 @@ use warnings;
# We use a lot of subroutine prototypes
## no critic (Subroutines::ProhibitSubroutinePrototypes)
-# Can't use Carp because it might cause use_ok() to accidentally succeed
+# Can't use Carp because it might cause C<use_ok()> to accidentally succeed
# even though the module being used forgot to use Carp. Yes, this
# actually happened.
sub _carp {
@@ -18,10 +18,10 @@ sub _carp {
return warn @_, " at $file line $line\n";
}
-our $VERSION = '0.92';
+our $VERSION = '1.001009';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-use Test::Builder::Module;
+use Test::Builder::Module 0.99;
our @ISA = qw(Test::Builder::Module);
our @EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
@@ -34,6 +34,7 @@ our @EXPORT = qw(ok use_ok require_ok
done_testing
can_ok isa_ok new_ok
diag note explain
+ subtest
BAIL_OUT
);
@@ -78,7 +79,7 @@ sub done_testing {
$tb->done_testing(@_);
}
-#line 289
+#line 288
sub ok ($;$) {
my( $test, $name ) = @_;
@@ -87,7 +88,7 @@ sub ok ($;$) {
return $tb->ok( $test, $name );
}
-#line 367
+#line 371
sub is ($$;$) {
my $tb = Test::More->builder;
@@ -102,8 +103,9 @@ sub isnt ($$;$) {
}
*isn't = \&isnt;
+# ' to unconfuse syntax higlighters
-#line 411
+#line 416
sub like ($$;$) {
my $tb = Test::More->builder;
@@ -111,7 +113,7 @@ sub like ($$;$) {
return $tb->like(@_);
}
-#line 426
+#line 431
sub unlike ($$;$) {
my $tb = Test::More->builder;
@@ -119,7 +121,7 @@ sub unlike ($$;$) {
return $tb->unlike(@_);
}
-#line 471
+#line 477
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
@@ -127,7 +129,7 @@ sub cmp_ok($$$;$) {
return $tb->cmp_ok(@_);
}
-#line 506
+#line 512
sub can_ok ($@) {
my( $proto, @methods ) = @_;
@@ -161,66 +163,89 @@ sub can_ok ($@) {
return $ok;
}
-#line 572
+#line 578
sub isa_ok ($$;$) {
- my( $object, $class, $obj_name ) = @_;
+ my( $thing, $class, $thing_name ) = @_;
my $tb = Test::More->builder;
- my $diag;
+ my $whatami;
+ if( !defined $thing ) {
+ $whatami = 'undef';
+ }
+ elsif( ref $thing ) {
+ $whatami = 'reference';
- if( !defined $object ) {
- $obj_name = 'The thing' unless defined $obj_name;
- $diag = "$obj_name isn't defined";
+ local($@,$!);
+ require Scalar::Util;
+ if( Scalar::Util::blessed($thing) ) {
+ $whatami = 'object';
+ }
}
else {
- my $whatami = ref $object ? 'object' : 'class';
- # We can't use UNIVERSAL::isa because we want to honor isa() overrides
- my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
- if($error) {
- if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
- # Its an unblessed reference
- $obj_name = 'The reference' unless defined $obj_name;
- if( !UNIVERSAL::isa( $object, $class ) ) {
- my $ref = ref $object;
- $diag = "$obj_name isn't a '$class' it's a '$ref'";
- }
- }
- elsif( $error =~ /Can't call method "isa" without a package/ ) {
- # It's something that can't even be a class
- $diag = "$obj_name isn't a class or reference";
- }
- else {
- die <<WHOA;
+ $whatami = 'class';
+ }
+
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } );
+
+ if($error) {
+ die <<WHOA unless $error =~ /^Can't (locate|call) method "isa"/;
WHOA! I tried to call ->isa on your $whatami and got some weird error.
Here's the error.
$error
WHOA
- }
- }
- else {
- $obj_name = "The $whatami" unless defined $obj_name;
- if( !$rslt ) {
- my $ref = ref $object;
- $diag = "$obj_name isn't a '$class' it's a '$ref'";
- }
- }
}
- my $name = "$obj_name isa $class";
- my $ok;
- if($diag) {
- $ok = $tb->ok( 0, $name );
- $tb->diag(" $diag\n");
+ # Special case for isa_ok( [], "ARRAY" ) and like
+ if( $whatami eq 'reference' ) {
+ $rslt = UNIVERSAL::isa($thing, $class);
+ }
+
+ my($diag, $name);
+ if( defined $thing_name ) {
+ $name = "'$thing_name' isa '$class'";
+ $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined";
+ }
+ elsif( $whatami eq 'object' ) {
+ my $my_class = ref $thing;
+ $thing_name = qq[An object of class '$my_class'];
+ $name = "$thing_name isa '$class'";
+ $diag = "The object of class '$my_class' isn't a '$class'";
+ }
+ elsif( $whatami eq 'reference' ) {
+ my $type = ref $thing;
+ $thing_name = qq[A reference of type '$type'];
+ $name = "$thing_name isa '$class'";
+ $diag = "The reference of type '$type' isn't a '$class'";
+ }
+ elsif( $whatami eq 'undef' ) {
+ $thing_name = 'undef';
+ $name = "$thing_name isa '$class'";
+ $diag = "$thing_name isn't defined";
+ }
+ elsif( $whatami eq 'class' ) {
+ $thing_name = qq[The class (or class-like) '$thing'];
+ $name = "$thing_name isa '$class'";
+ $diag = "$thing_name isn't a '$class'";
}
else {
+ die;
+ }
+
+ my $ok;
+ if($rslt) {
$ok = $tb->ok( 1, $name );
}
+ else {
+ $ok = $tb->ok( 0, $name );
+ $tb->diag(" $diag\n");
+ }
return $ok;
}
-#line 650
+#line 679
sub new_ok {
my $tb = Test::More->builder;
@@ -229,7 +254,6 @@ sub new_ok {
my( $class, $args, $object_name ) = @_;
$args ||= [];
- $object_name = "The object" unless defined $object_name;
my $obj;
my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
@@ -238,14 +262,24 @@ sub new_ok {
isa_ok $obj, $class, $object_name;
}
else {
- $tb->ok( 0, "new() died" );
+ $class = 'undef' if !defined $class;
+ $tb->ok( 0, "$class->new() died" );
$tb->diag(" Error was: $error");
}
return $obj;
}
-#line 690
+#line 765
+
+sub subtest {
+ my ($name, $subtests) = @_;
+
+ my $tb = Test::More->builder;
+ return $tb->subtest(@_);
+}
+
+#line 789
sub pass (;$) {
my $tb = Test::More->builder;
@@ -259,7 +293,52 @@ sub fail (;$) {
return $tb->ok( 0, @_ );
}
-#line 753
+#line 842
+
+sub require_ok ($) {
+ my($module) = shift;
+ my $tb = Test::More->builder;
+
+ my $pack = caller;
+
+ # Try to determine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
+ my $code = <<REQUIRE;
+package $pack;
+require $module;
+1;
+REQUIRE
+
+ my( $eval_result, $eval_error ) = _eval($code);
+ my $ok = $tb->ok( $eval_result, "require $module;" );
+
+ unless($ok) {
+ chomp $eval_error;
+ $tb->diag(<<DIAGNOSTIC);
+ Tried to require '$module'.
+ Error: $eval_error
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+
+ return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
+}
+
+
+#line 936
sub use_ok ($;@) {
my( $module, @imports ) = @_;
@@ -267,6 +346,7 @@ sub use_ok ($;@) {
my $tb = Test::More->builder;
my( $pack, $filename, $line ) = caller;
+ $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line
my $code;
if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
@@ -274,6 +354,8 @@ sub use_ok ($;@) {
# for it to work with non-Exporter based modules.
$code = <<USE;
package $pack;
+
+#line $line $filename
use $module $imports[0];
1;
USE
@@ -281,6 +363,8 @@ USE
else {
$code = <<USE;
package $pack;
+
+#line $line $filename
use $module \@{\$args[0]};
1;
USE
@@ -321,51 +405,8 @@ sub _eval {
return( $eval_result, $eval_error );
}
-#line 822
-
-sub require_ok ($) {
- my($module) = shift;
- my $tb = Test::More->builder;
-
- my $pack = caller;
-
- # Try to deterine if we've been given a module name or file.
- # Module names must be barewords, files not.
- $module = qq['$module'] unless _is_module_name($module);
-
- my $code = <<REQUIRE;
-package $pack;
-require $module;
-1;
-REQUIRE
-
- my( $eval_result, $eval_error ) = _eval($code);
- my $ok = $tb->ok( $eval_result, "require $module;" );
-
- unless($ok) {
- chomp $eval_error;
- $tb->diag(<<DIAGNOSTIC);
- Tried to require '$module'.
- Error: $eval_error
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-sub _is_module_name {
- my $module = shift;
- # Module names start with a letter.
- # End with an alphanumeric.
- # The rest is an alphanumeric or ::
- $module =~ s/\b::\b//g;
-
- return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
-}
-
-#line 899
+#line 1037
our( @Data_Stack, %Refs_Seen );
my $DNE = bless [], 'Does::Not::Exist';
@@ -465,14 +506,14 @@ sub _type {
return '' if !ref $thing;
- for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
return $type if UNIVERSAL::isa( $thing, $type );
}
return '';
}
-#line 1059
+#line 1197
sub diag {
return Test::More->builder->diag(@_);
@@ -482,13 +523,13 @@ sub note {
return Test::More->builder->note(@_);
}
-#line 1085
+#line 1223
sub explain {
return Test::More->builder->explain(@_);
}
-#line 1151
+#line 1289
## no critic (Subroutines::RequireFinalReturn)
sub skip {
@@ -516,7 +557,7 @@ sub skip {
last SKIP;
}
-#line 1238
+#line 1373
sub todo_skip {
my( $why, $how_many ) = @_;
@@ -537,7 +578,7 @@ sub todo_skip {
last TODO;
}
-#line 1293
+#line 1428
sub BAIL_OUT {
my $reason = shift;
@@ -546,7 +587,7 @@ sub BAIL_OUT {
$tb->BAIL_OUT($reason);
}
-#line 1332
+#line 1467
#'#
sub eq_array {
@@ -570,6 +611,8 @@ sub _eq_array {
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -580,6 +623,21 @@ sub _eq_array {
return $ok;
}
+sub _equal_nonrefs {
+ my( $e1, $e2 ) = @_;
+
+ return if ref $e1 or ref $e2;
+
+ if ( defined $e1 ) {
+ return 1 if defined $e2 and $e1 eq $e2;
+ }
+ else {
+ return 1 if !defined $e2;
+ }
+
+ return;
+}
+
sub _deep_check {
my( $e1, $e2 ) = @_;
my $tb = Test::More->builder;
@@ -592,9 +650,6 @@ sub _deep_check {
local %Refs_Seen = %Refs_Seen;
{
- # Quiet uninitialized value warnings when comparing undefs.
- no warnings 'uninitialized';
-
$tb->_unoverload_str( \$e1, \$e2 );
# Either they're both references or both not.
@@ -605,7 +660,7 @@ sub _deep_check {
$ok = 0;
}
elsif( !defined $e1 and !defined $e2 ) {
- # Shortcut if they're both defined.
+ # Shortcut if they're both undefined.
$ok = 1;
}
elsif( _dne($e1) xor _dne($e2) ) {
@@ -672,7 +727,7 @@ WHOA
}
}
-#line 1465
+#line 1614
sub eq_hash {
local @Data_Stack = ();
@@ -695,6 +750,8 @@ sub _eq_hash {
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -705,7 +762,7 @@ sub _eq_hash {
return $ok;
}
-#line 1522
+#line 1673
sub eq_set {
my( $a1, $a2 ) = @_;
@@ -730,6 +787,6 @@ sub eq_set {
);
}
-#line 1735
+#line 1946
1;
@@ -54,3 +54,49 @@ sub _parse ($) {
}
1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Assignment - DOM Assignment Node for Makefiles
+
+=head1 DESCRIPTION
+
+An assignment node.
+
+=head2 Accessors
+
+=over 4
+
+=item lhs
+
+left hand side of assignment
+
+=item rhs
+
+right hand side of assignment
+
+=item op
+
+assignment operator
+
+=back
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -4,3 +4,31 @@ use strict;
use base 'MDOM::Node';
1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Command - DOM Command Node for Makefiles
+
+=head1 DESCRIPTION
+
+A command node.
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -17,3 +17,44 @@ sub value {
1;
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Directive - DOM Directive Node for Makefiles
+
+=head1 DESCRIPTION
+
+A directive node.
+
+=head2 Accessors
+
+=over 4
+
+=item name
+
+directive name
+
+=item value
+
+directive value
+
+=back
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -476,3 +476,36 @@ sub _is_keyword {
1;
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Gmake - Represents a GNU makefile for Makefile::DOM
+
+=head1 DESCRIPTION
+
+Represents a GNU Makefile.
+
+=head1 METHODS
+
+=head2 C<extract_interp>
+
+Extract interpolated make variables like C<$(foo)> and C<${bar}>.
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -37,7 +37,7 @@ use Params::Util '_INSTANCE';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.006';
+ $VERSION = '0.008';
}
@@ -308,7 +308,7 @@ See the L<support section|MDOM/SUPPORT> in the main module.
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
-Zhang "agentzh" Yichun C<< <agentzh@gmail.com> >>
+Yichun "agentzh" Zhang C<< <agentzh@gmail.com> >>
=head1 COPYRIGHT
@@ -37,7 +37,7 @@ use overload 'bool' => sub () { 1 },
use vars qw{$VERSION $errstr %_PARENT};
BEGIN {
- $VERSION = '0.006';
+ $VERSION = '0.008';
$errstr = '';
# Master Child -> Parent index
@@ -68,6 +68,12 @@ Returns true if the Element is significant, or false it not.
### XS -> MDOM/XS.xs:_MDOM_Element__significant 0.845+
sub significant { 1 }
+=head2 lineno
+
+Accessor for current line number.
+
+=cut
+
sub lineno {
$_[0]->{lineno};
}
@@ -195,6 +201,8 @@ sub top {
=pod
+=head2 document
+
For an Element that is contained within a L<MDOM::Document> object,
the C<document> method will return the top-level Document for the Element.
@@ -58,7 +58,7 @@ use Params::Util '_INSTANCE',
use vars qw{$VERSION *_PARENT};
BEGIN {
- $VERSION = '0.006';
+ $VERSION = '0.008';
*_PARENT = *MDOM::Element::_PARENT;
}
@@ -77,3 +77,46 @@ sub _parse {
1;
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Rule::Simple - DOM simple rule node for Makefiles
+
+=head1 DESCRIPTION
+
+A simple rule node.
+
+=head2 Accessors
+
+=over 4
+
+=item colon
+
+=item command
+
+=item normal_prereqs
+
+=item order_prereqs
+
+=item targets
+
+=back
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -4,3 +4,31 @@ use strict;
use base 'MDOM::Rule';
1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Rule::StaticPattern - DOM static pattern rule node for Makefiles
+
+=head1 DESCRIPTION
+
+A static pattern rule node.
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -9,3 +9,31 @@ use MDOM::Rule::Simple;
use MDOM::Rule::StaticPattern;
1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Rule - DOM Rule Abstract Node for Makefiles
+
+=head1 DESCRIPTION
+
+A rule node.
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -6,3 +6,30 @@ use warnings;
use base 'MDOM::Token';
1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Token::Bare - A Bare Token node for Makefile DOM
+
+=head1 DESCRIPTION
+
+A bare token node.
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
@@ -60,7 +60,7 @@ use base 'MDOM::Token';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.006';
+ $VERSION = '0.008';
}
### XS -> MDOM/XS.xs:_MDOM_Token_Comment__significant 0.900+
@@ -4,3 +4,31 @@ use strict;
use base 'MDOM::Token';
1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Token::Interpolation - A Interpolation Token node for Makefile DOM
+
+=head1 DESCRIPTION
+
+A interpolation token node.
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -3,4 +3,32 @@ package MDOM::Token::Modifier;
use strict;
use base 'MDOM::Token';
-1;
\ No newline at end of file
+1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Token::Modifier - A Modifier Token node for Makefile DOM
+
+=head1 DESCRIPTION
+
+A modifier token node.
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -28,7 +28,7 @@ use base 'MDOM::Token';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.006';
+ $VERSION = '0.008';
}
1;
@@ -46,7 +46,7 @@ use base 'MDOM::Token';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.006';
+ $VERSION = '0.008';
}
=pod
@@ -28,7 +28,7 @@ use Params::Util '_INSTANCE';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.006';
+ $VERSION = '0.008';
}
# We don't load the abstracts, they are loaded
@@ -73,6 +73,12 @@ sub new {
undef;
}
+=head2 set_class
+
+Set a specific class for a token.
+
+=cut
+
sub set_class {
my $self = shift; @_ or return undef;
my $class = substr( $_[0], 0, 12 ) eq 'MDOM::Token::' ? shift : 'MDOM::Token::' . shift;
@@ -4,3 +4,31 @@ use strict;
use base 'MDOM::Node';
1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Rule - DOM Unknown Node for Makefiles
+
+=head1 DESCRIPTION
+
+An unknown node.
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -21,3 +21,35 @@ sub trim_tokens ($) {
}
1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+MDOM::Util - Utilities methods for Makefile::DOM
+
+=head1 DESCRIPTION
+
+Includes auxiliary methods.
+
+=head2 trim_tokens
+
+Remove space tokens from the beginning or the end of a list reference.
+
+=head1 AUTHOR
+
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<MDOM::Document>, L<MDOM::Document::Gmake>, L<PPI>, L<Makefile::Parser::GmakeDB>, L<makesimple>.
+
@@ -3,7 +3,7 @@ package Makefile::DOM;
use strict;
use warnings;
-our $VERSION = '0.006';
+our $VERSION = '0.008';
use MDOM::Document;
use MDOM::Element;
@@ -26,7 +26,7 @@ Makefile::DOM - Simple DOM parser for Makefiles
=head1 VERSION
-This document describes Makefile::DOM 0.006 released on 28 August 2011.
+This document describes Makefile::DOM 0.008 released on 18 November 2014.
=head1 DESCRIPTION
@@ -190,7 +190,13 @@ For every MDOM node, its corresponding makefile source can be generated by invok
=head1 BUGS AND TODO
-The current implemenation of the L<MDOM::Document::Gmake> lexer is based on a hand-written state machie. Although the efficiency of the engine is not bad, the code is rather complicated and messy, which hurts both extensibility and maintanabilty. So it's expected to rewrite the parser using some grammatical tools like the Perl 6 regex engine L<Pugs::Compiler::Rule> or a yacc-style one like L<Parse::Yapp>.
+The current implementation of the L<MDOM::Document::Gmake> lexer is
+based on a hand-written state machie. Although the efficiency of the
+engine is not bad, the code is rather complicated and messy, which
+hurts both extensibility and maintanabilty. So it's expected to
+rewrite the parser using some grammatical tools like the Perl 6 regex
+engine L<Pugs::Compiler::Rule> or a yacc-style one like
+L<Parse::Yapp>.
=head1 SOURCE REPOSITORY
@@ -202,11 +208,11 @@ If you want a commit bit, please let me know.
=head1 AUTHOR
-Zhang "agentzh" Yichun (章亦春) E<lt>agentzh@gmail.comE<gt>
+Yichun "agentzh" Zhang (章亦春) E<lt>agentzh@gmail.comE<gt>
=head1 COPYRIGHT
-Copyright 2006-2011 by Zhang "agentzh" Yichun (章亦春).
+Copyright 2006-2014 by Yichun "agentzh" Zhang (章亦春).
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
@@ -1,7 +1,6 @@
#: t/Shell.pm
#: Testing framework for t/sh/*.t
-#: Copyright (c) 2006 Zhang "agentzh" Yichun
-#: 2006-02-02 2006-02-10
+#: Copyright (C) Yichun "agentzh" Zhang
package t::Shell;
@@ -2,4 +2,11 @@ use Test::More;
eval "use Test::Pod::Coverage";
plan skip_all => "Test::Pod::Coverage required for testing POD coverage" if $@;
-all_pod_coverage_ok();
+
+my $trustme = {
+ trustme => [qr/^(?:new)$/],
+ coverage_class => 'Pod::Coverage::CountParents'
+ };
+all_pod_coverage_ok($trustme);
+
+done_testing();