view release on metacpan or  search on metacpan

lib/Test/Arrow.pm  view on Meta::CPAN

package Test::Arrow;
use strict;
use warnings;
use Test::Builder::Module;
use Test::Name::FromLine;
use Text::MatchedPosition;

our $VERSION = '0.22';

our @ISA = qw/Test::Builder::Module/;

sub _carp {
    my ($pkg, $file, $line) = caller;
    return warn @_, " at $pkg, $file line $line\n";
}

sub _croak {
    my ($pkg, $file, $line) = caller;
    return die @_, " at $pkg, $file line $line\n";
}

sub PASS { 1 }
sub FAIL { 0 }

sub import {
    my $pkg  = shift;
    my %args = map { $_ => 1 } @_;

    {
        my $caller = caller;
        no strict 'refs'; ## no critic
        *{"${caller}::done"} = \&done;
        *{"${caller}::t"} = \&t;
    }

    $pkg->_import_option_no_strict(\%args);
    $pkg->_import_option_no_warnings(\%args);
    $pkg->_import_option_binary(\%args);

    if (scalar(keys %args) > 0) {
        _croak "Wrong option: " . join(", ", keys %args);
    }

    if ( _need_io_handle() ) {
        require IO::Handle;
        IO::Handle->import;
    }
}

sub _need_io_handle { $] < 5.014000 }

sub _import_option_no_strict {
    my ($pkg, $args) = @_;

    my $no_strict = delete $args->{no_strict} or delete $args->{'-strict'};
    if (!$no_strict) {
        strict->import;
    }
}

sub _import_option_no_warnings {
    my ($pkg, $args) = @_;

    my $no_warnings = delete $args->{no_warnings} or delete $args->{'-warnings'};
    if (!$no_warnings) {
        warnings->import;
    }
}

sub _import_option_binary {
    my ($pkg, $args) = @_;

    my $binary = delete $args->{binary} or delete $args->{binary_mode}
                    or delete $args->{not_utf8} or delete $args->{'-utf8'} or delete $args->{'-utf'};
    if (!$binary) {
        binmode $pkg->builder->$_, ':utf8' for qw(failure_output todo_output output);
        require utf8;
        utf8->import;
    }
}

sub new {
    my $class = shift;
    my %args  = @_;

    my $self = bless {
        no_x => delete $args{'no_x'},
    }, $class;

    if ($args{plan}) {
        $self->plan(%{$args{plan}});
    }

    $self;
}

sub t {
    return __PACKAGE__->new(@_);
}

sub _tb { __PACKAGE__->builder }

sub _reset {
    my ($self) = @_;

    delete $self->{_name};
    delete $self->{_expected};
    delete $self->{_got};

    $self;
}

sub pass { shift; _tb->ok(PASS, @_) }
sub fail { shift; _tb->ok(FAIL, @_) }

sub plan {
    my $self = shift;