File Coverage

blib/lib/Test/Stream.pm

Criterion	Covered	Total	%
statement	117	119	98.3
branch	49	56	87.5
condition	14	17	82.3
subroutine	14	14	100.0
pod	0	5	0.0
total	194	211	91.9

package Test::Stream;
use strict;
use warnings;
use vars qw/$VERSION/;

$Test::Stream::VERSION = '1.302027';
$VERSION = eval $VERSION;

use Carp qw/croak/;
use Scalar::Util qw/reftype/;

use Test::Stream::Sync();

use Test::Stream::Util qw/try pkg_to_file/;

sub default {
    croak "No plugins or bundles specified (Maybe try '-Classic'?)"
}

sub import {
    my $class = shift;
    my @caller = caller;

    push @_ => $class->default unless @_;

    $class->load(\@caller, @_);

    1;
}

sub load {
    my $class = shift;
    my $caller = shift;

    my @order;
    my %args;
    my %skip;

    while (my $arg = shift @_) {
        my $type = reftype($arg) || "";

        if ($type eq 'CODE') {
            push @order => $arg;
            next;
        }

        # Strip off the '+', which may be combined with ':' or '-' at the
        # start.
        my $full = ($arg =~ s/^([!:-]?)\+/$1/) ? 1 : 0;

        # Disallowed plugin
        if ($arg =~ m/^!(.*)$/) {
            my $pkg = $full ? $1 : "Test::Stream::Plugin::$1";
            $skip{$pkg}++;
            next;
        }

        # Bundle
        if ($arg =~ m/^-(.*)$/) {
            my $pkg = $full ? $1 : "Test::Stream::Bundle::$1";
            my $file = pkg_to_file($pkg);
            require $file;
            unshift @_ => $pkg->plugins;
            next;
        }

        # Local Bundle
        if ($arg =~ m/^:(.*)$/) {
            my $pkg = $full ? $1 : "Test::Stream::Bundle::$1";
            my $file = pkg_to_file($pkg);

            local @INC = (
                ($ENV{TS_LB_PATH} ? split(':', $ENV{TS_LB_PATH}) : ()),
                't/lib',
                'lib',
                sub {
                    my ($me, $fname) = @_;
                    return unless $fname eq $file;
                    die "Could not load LOCAL PROJECT bundle '$pkg' (Do you need to set TS_LB_PATH?)\n";
                },
                @INC,
            );

            require $file;
            unshift @_ => $pkg->plugins;
            next;
        }

        if ($arg =~ m/^[a-z]/) {
            my $method = "opt_$arg";

            die "'$arg' is not a valid option for '$class' (Did you intend to use the '" . ucfirst($arg) . "' plugin?) at $caller->[1] line $caller->[2].\n"
                unless $class->can($method);

            $class->$method(list => \@_, order => \@order, args => \%args, skip => \%skip);
            next;
        }

        # Load the plugin
        $arg = 'Test::Stream::Plugin::' . $arg unless $full;

        # Get the value
        my $val;

        # Arg is specified
        $val = shift @_ if @_ && (ref($_[0]) || ($_[0] && $_[0] eq '*'));

        # Special Cases
        $val = $val eq '*' ? ['-all'] : [$val]
            if defined($val) && !ref($val);

        # Make sure we only list it in @order once.
        push @order => $arg unless $args{$arg};

        # Override any existing value, last wins.
        $args{$arg} = $val if defined $val;
    }

    for my $arg (@order) {
        my $type = reftype($arg) || "";
        if ($type eq 'CODE') {
            $arg->($caller);
            next;
        }

        next if $skip{$arg};

        my $import = $args{$arg};
        my $mod  = $arg;

        my $file = pkg_to_file($mod);
        unless (eval { require $file; 1 }) {
            my $error = $@ || 'unknown error';
            my $file = __FILE__;
            my $line = __LINE__ - 3;
            $error =~ s/ at \Q$file\E line $line.*//;
            croak "Could not load Test::Stream plugin '$arg': $error";
        }

        if ($mod->can('load_ts_plugin')) {
            $mod->load_ts_plugin($caller, @$import);
        }
        elsif (my $meta = Test::Stream::Exporter::Meta->get($mod)) {
            Test::Stream::Exporter::export_from($mod, $caller->[0], $import);
        }
        elsif (@$import) {
            croak "Module '$mod' does it implement 'load_ts_plugin()', nor does it export using Test::Stream::Exporter."
        }
    }

    Test::Stream::Sync->loaded(1);
}

sub opt_class {
    shift;
    my %params = @_;
    my $list = $params{list};
    my $args = $params{args};
    my $order = $params{order};

    my $class = shift @$list;

    push @{$params{order}} => 'Test::Stream::Plugin::Class'
        unless $args->{'Test::Stream::Plugin::Class'};

    $args->{'Test::Stream::Plugin::Class'} = [$class];
}

sub opt_skip_without {
    shift;
    my %params = @_;
    my $list = $params{list};
    my $args = $params{args};
    my $order = $params{order};

    my $class = shift @$list;

    push @{$params{order}} => 'Test::Stream::Plugin::SkipWithout'
        unless $args->{'Test::Stream::Plugin::SkipWithout'};

    $args->{'Test::Stream::Plugin::SkipWithout'} ||= [];
    push @{$args->{'Test::Stream::Plugin::SkipWithout'}} => $class;
}

sub opt_srand {
    shift;
    my %params = @_;
    my $list = $params{list};
    my $args = $params{args};
    my $order = $params{order};

    my $seed = shift @$list;

    push @{$params{order}} => 'Test::Stream::Plugin::SRand'
        unless $args->{'Test::Stream::Plugin::SRand'};

    $args->{'Test::Stream::Plugin::SRand'} = [$seed];
}

1;

__END__