view release on metacpan or  search on metacpan

lib/Test2/V1.pm  view on Meta::CPAN

package Test2::V1;
use strict;
use warnings;

our $VERSION = '1.302219';

use Carp qw/croak/;

use Test2::V1::Base();
use Test2::V1::Handle();

use Test2::Plugin::ExitSummary();
use Test2::Plugin::SRand();
use Test2::Plugin::UTF8();
use Test2::Tools::Target();

# Magic reference to check against later
my $SET = \'set';

# Lists of pragmas and plugins
my @PRAGMAS = qw/strict warnings/;
my @PLUGINS = qw/utf8 srand summary target/;

sub import {
    my $class = shift;

    my $caller = caller;

    croak "Got One or more undefined arguments, this usually means you passed in a single-character flag like '-p' without quoting it, which conflicts with the -p builtin"
        if grep { !defined($_) } @_;

    my ($requested_exports, $options) = $class->_parse_args(\@_);

    my $pragmas = $class->_compute_pragmas($options);
    my $plugins = $class->_compute_plugins($options);

    my ($handle_name, $handle) = $class->_build_handle($options);
    my $ns = $handle->HANDLE_NAMESPACE;

    unshift @$requested_exports => $handle->HANDLE_SUBS() if delete $options->{'-import'};

    unshift @$requested_exports => grep { my $p = prototype($ns->can($_)); $p && $p =~ '&' } $handle->HANDLE_SUBS() if delete $options->{'-x'};

    my $exports = $class->_build_exports($handle, $requested_exports);
    unless (delete $options->{'-no-T2'}) {
        my $h = $handle;
        $exports->{$handle_name} = sub() { $h };
    }

    croak "Unknown option(s): " . join(', ', sort keys %$options) if keys %$options;

    strict->import()                     if $pragmas->{strict};
    'warnings'->import()                 if $pragmas->{warnings};
    Test2::Plugin::UTF8->import()        if $plugins->{utf8};
    Test2::Plugin::ExitSummary->import() if $plugins->{summary};

    if (my $set = $plugins->{srand}) {
        Test2::Plugin::SRand->import((ref($set) && "$set" ne "$SET") ? $set->{seed} : ());
    }

    if (my $target = $plugins->{target}) {
        Test2::Tools::Target->import_into($caller, $plugins->{target}) unless "$target" eq "$SET";
    }

    for my $exp (keys %$exports) {
        no strict 'refs';
        *{"$caller\::$exp"} = $exports->{$exp};
    }
}

sub _build_exports {
    my $class = shift;
    my ($handle, $requested) = @_;

    my %exports;

    while (my $exp = shift @$requested) {
        if ($exp =~ m/^!(.+)$/) {
            delete $exports{$1};
            next;
        }

        my $code = $handle->HANDLE_NAMESPACE->can($exp) or croak "requested export '$exp' is not available";

        my $args = shift @$requested if @$requested && ref($requested->[0]) eq 'HASH';

        my $name = $exp;
        if ($args) {
            $name = delete $args->{-as}               if $args->{-as};
            $name = delete($args->{-prefix}) . $name  if $args->{-prefix};
            $name = $name . delete($args->{-postfix}) if $args->{-postfix};
        }

        $exports{$name} = $code;
    }

    return \%exports;
}

sub _build_handle {
    my $class = shift;
    my ($options) = @_;

    my $handle_opts = delete $options->{'-T2'} || {};
    my $handle_name = delete $handle_opts->{'-as'} || delete $handle_opts->{'as'} || 'T2';
    my $handle      = Test2::V1::Handle->new(%$handle_opts);

    return ($handle_name, $handle);
}

sub _compute_plugins {
    my $class = shift;