File Coverage

lib/Badger/Test.pm

Criterion	Covered	Total	%
statement	66	96	68.7
branch	12	36	33.3
condition	4	11	36.3
subroutine	25	36	69.4
pod	10	10	100.0
total	117	189	61.9

package Badger::Test;

use Carp;
use Badger;
use Badger::Class
    version   => 0.01,
    base      => 'Badger::Base',
    import    => 'CLASS class',
    constants => 'ARRAY DELIMITER PKG',
    words     => 'DEBUG DEBUG_MODULES',
    exports   => {
        all   => 'plan ok is isnt like unlike pass fail
                  skip_some skip_rest skip_all manager',
        after => \&_after_hook,
        hooks => {
            lib      => [\&_lib_hook,    1],
            skip     => [\&_skip_hook,   1],
            if_env   => [\&_if_env_hook, 1],
            debug    => \&_debug_hook,
            map { $_ => \&_export_hook }
            qw( summary colour color args tests )
        },
    };

use Badger::Debug;
use Badger::Exception;
use Badger::Test::Manager;
our $MANAGER   = 'Badger::Test::Manager';
our $DEBUGGER  = 'Badger::Debug';
our $EXCEPTION = 'Badger::Exception';
our ($ALL, $IF_ENV, $DEBUG, $DEBUG_MODULES);

*color = \&colour;


sub _lib_hook {
    Badger->lib($_[3]);
}

sub _skip_hook {
    $MANAGER->skip_all($_[3]);
}

sub _if_env_hook {
    my $vars = $_[3];
    $IF_ENV = $vars eq ARRAY
        ? $vars
        : [ split(DELIMITER, $vars) ]
}

sub _export_hook {
    my ($class, $target, $key, $symbols) = @_;
    croak "You didn't specify a value for the '$key' load option"
        unless @$symbols;
    $class->$key(shift @$symbols);
}

sub _debug_hook {
    my ($class, $target, $key, $symbols, $import) = @_;
    croak "You didn't specify any values for the 'debug' load option.\n"
        unless @$symbols;


    # define $DEBUG in caller
    no strict 'refs';
    *{ $target.PKG.DEBUG } = \$DEBUG;
    *{ $target.PKG.DEBUG } = sub { $DEBUG };

    # set $DEBUG_MODULE in this class to contain the argument passed - a list
    # of class names to enable $DEBUG in when/if debugging is enabled
    my $modules = shift @$symbols;
    return unless $modules;           # zero/false for no debugging
    $class->debug_modules($modules);
}

sub _after_hook {
    my ($class, $target) = @_;

    # See if we've got any constraints specified and assert that they're
    # met.  If the --all command line parameter is specified (which sets
    # $ALL) then we run the tests regardless

    if ($IF_ENV && ! $ALL) {
        my $run   = 0;
        my @names = @$IF_ENV;

        foreach my $var (@names) {
            $run++, last if $ENV{$var};
        }
        unless ($run) {
            my $name = pop(@names);
            $name = join(' or ', join(', ', @names), $name);
            $MANAGER->skip_all("Tests only apply for $name");
        }
    }
}

sub manager {
    my $class = shift;
    return @_
        ? ($MANAGER = shift)
        :  $MANAGER;
}

sub colour {
    shift;
    manager->colour(@_);
}

sub summary {
    shift;
    manager->summary(@_);
}

sub args {
    my $self = shift;
    my $args = @_ && ref $_[0] eq ARRAY ? shift : [ @_ ];
    my $arg;

    # quick hack until Badger::Config is done
    while (@$args && $args->[0] =~ /^-/) {
        $arg =  shift @$args;
        if ($arg =~ /^(-c|--colou?r)$/) {
            $self->colour(1);
        }
        elsif ($arg =~ /^(-d|--debug)$/) {
            # physically set $DEBUG in this package (required for exported
            # aliases) and also call debugging() for any subclasses to use
            $self->debugging( $DEBUG = 1 );
        }
        elsif ($arg =~ /^(-s|--summary)$/) {
            $self->summary(1);
        }
        elsif ($arg =~ /^(-t|--trace)$/) {
            $self->trace(1);
        }
        elsif ($arg =~ /^(-a|--all)$/) {
            $self->all(1);
        }
        elsif ($arg =~ /^(-h|--help)$/) {
            warn $self->help;
            exit;
        }
        else {
            unshift(@$args, $arg);
            last;
        }
    }
}

sub tests {
    shift;
    plan(@_);
}

sub debug_modules {
    my $self = shift;
    $self->class->var( DEBUG_MODULES => shift );
}

sub debugging {
    my $self    = shift;
    my $flag    = $DEBUG = (@_ ? shift : 1);
    my $modules = $self->class->var(DEBUG_MODULES) || return;
    $DEBUGGER->debug_modules($modules);
}

sub trace {
    my $self = shift;
    my $flag = @_ ? shift : 1;
    $EXCEPTION->trace($flag);
}

sub all {
    my $self = shift;
    $ALL = @_ ? shift : 1;
}

sub help {
    return <
Options:
    -a      --all               Run all tests (e.g. author/release tests)
    -d      --debug             Enable debugging
    -t      --trace             Enable stack tracing
    -c      --colour/--color    Enable colour output
    -s      --summary           Display summary of test results
    -h      --help              This help summary
END_OF_HELP
}


class->methods(
    plan      => sub ($;$)  { manager->plan(@_)      },
    ok        => sub ($;$)  { manager->ok(@_)        },
    is        => sub ($$;$) { manager->is(@_)        },
    isnt      => sub ($$;$) { manager->isnt(@_)      },
    like      => sub ($$;$) { manager->like(@_)      },
    unlike    => sub ($$;$) { manager->unlike(@_)    },
    pass      => sub (;$)   { manager->pass(@_)      },
    fail      => sub (;$)   { manager->fail(@_)      },
    skip      => sub (;$)   { manager->skip(@_)      },
    skip_some => sub (;$$)  { manager->skip_some(@_) },
    skip_rest => sub (;$)   { manager->skip_rest(@_) },
    skip_all  => sub (;$)   { manager->skip_all(@_)  },
);


1;

__END__