—

              
package Test::TypeTiny;
use strict;
use warnings;
use Test::More qw();
use Scalar::Util qw(blessed);
use Types::TypeTiny ();
use Type::Tiny      ();
require Exporter::Tiny;
our @ISA = 'Exporter::Tiny';
BEGIN {
        *EXTENDED_TESTING = $ENV{EXTENDED_TESTING} ? sub() { !!1 } : sub() { !!0 };
}
our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '2.007_004';
our @EXPORT    = qw( should_pass should_fail ok_subtype );
our @EXPORT_OK = qw( EXTENDED_TESTING matchfor );
$VERSION =~ tr/_//d;
my $overloads_installed = 0;
sub matchfor {
        my @matchers = @_;
        bless \@matchers, do {
                package    #
                        Test::TypeTiny::Internal::MATCHFOR;
                Test::TypeTiny::Internal::MATCHFOR->Type::Tiny::_install_overloads(
                        q[==] => 'match',
                        q[eq] => 'match',
                        q[""] => 'to_string',
                ) unless $overloads_installed++;
                 
                sub to_string {
                        $_[0][0];
                }
                 
                sub match {
                        my ( $self, $e ) = @_;
                        my $does =
                                Scalar::Util::blessed( $e )
                                ? ( $e->can( 'DOES' ) || $e->can( 'isa' ) )
                                : undef;
                        for my $s ( @$self ) {
                                return 1 if ref( $s ) && $e =~ $s;
                                return 1 if !ref( $s ) && $does && $e->$does( $s );
                        }
                        return;
                } #/ sub match
                __PACKAGE__;
        };
} #/ sub matchfor
sub _mk_message {
        require Type::Tiny;
        my ( $template, $value ) = @_;
        sprintf( $template, Type::Tiny::_dd( $value ) );
}
sub ok_subtype {
        my ( $type, @s ) = @_;
        @_ = (
                not( scalar grep !$_->is_subtype_of( $type ), @s ),
                sprintf( "%s subtype: %s", $type, join q[, ], @s ),
        );
        goto \&Test::More::ok;
}
eval( EXTENDED_TESTING ? <<'SLOW' : <<'FAST');
sub should_pass
{
        my ($value, $type, $message) = @_;
         
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        $type = Types::TypeTiny::to_TypeTiny($type) unless blessed($type) && $type->can("check");
         
        my $strictures = $type->can("_strict_check");
        my $compiled   = $type->can("compiled_check");
        my $can_inline = $type->can("can_be_inlined") && $type->can_be_inlined && $type->can("inline_check");
         
        my $count = 1;
        $count +=1 if $strictures;
        $count +=1 if $compiled;
        $count +=2 if $can_inline;
         
        my @codes;
        if ( $can_inline ) {
                push @codes, eval sprintf('no warnings; [ q(inlined), sub { my $VAR = shift; %s } ]', $type->inline_check('$VAR'));
                local $Type::Tiny::AvoidCallbacks = 1;
                push @codes, eval sprintf('no warnings; [ q(inlined avoiding callbacks), sub { my $VAR = shift; %s } ]', $type->inline_check('$VAR'));
        }
         
        my $test = "Test::Builder"->new->child(
                $message || _mk_message("%s passes type constraint $type", $value),
        );
        $test->plan(tests => $count);
        $test->ok(!!$type->check($value), '->check');
        $test->ok(!!$type->_strict_check($value), '->_strict_check') if $strictures;
        $test->ok(!!$type->compiled_check->($value), '->compiled_check') if $compiled;
        for my $code ( @codes ) {
                $test->ok(!!$code->[1]->($value), $code->[0]);
        }
        $test->finalize;
        return $test->is_passing;
}
sub should_fail
{
        my ($value, $type, $message) = @_;
        $type = Types::TypeTiny::to_TypeTiny($type) unless blessed($type) && $type->can("check");
         
        local $Test::Builder::Level = $Test::Builder::Level + 1;
         
        my $strictures = $type->can("_strict_check");
        my $compiled   = $type->can("compiled_check");
        my $can_inline = $type->can("can_be_inlined") && $type->can_be_inlined && $type->can("inline_check");
         
        my $count = 1;
        $count +=1 if $strictures;
        $count +=1 if $compiled;
        $count +=2 if $can_inline;
         
        my @codes;
        if ( $can_inline ) {
                push @codes, eval sprintf('no warnings; [ q(inlined), sub { my $VAR = shift; %s } ]', $type->inline_check('$VAR'));
                local $Type::Tiny::AvoidCallbacks = 1;
                push @codes, eval sprintf('no warnings; [ q(inlined avoiding callbacks), sub { my $VAR = shift; %s } ]', $type->inline_check('$VAR'));
        }
         
        my $test = "Test::Builder"->new->child(
                $message || _mk_message("%s fails type constraint $type", $value),
        );
        $test->plan(tests => $count);
        $test->ok(!$type->check($value), '->check');
        $test->ok(!$type->_strict_check($value), '->_strict_check') if $strictures;
        $test->ok(!$type->compiled_check->($value), '->compiled_check') if $compiled;
        for my $code ( @codes ) {
                $test->ok(!$code->[1]->($value), $code->[0]);
        }
        $test->finalize;
        return $test->is_passing;
}
SLOW
sub should_pass
{
        my ($value, $type, $message) = @_;
        $type = Types::TypeTiny::to_TypeTiny($type) unless blessed($type) && $type->can("check");
        @_ = (
                !!$type->check($value),
                $message || _mk_message("%s passes type constraint $type", $value),
        );
        goto \&Test::More::ok;
}
sub should_fail
{
        my ($value, $type, $message) = @_;
        $type = Types::TypeTiny::to_TypeTiny($type) unless blessed($type) && $type->can("check");
        @_ = (
                !$type->check($value),
                $message || _mk_message("%s fails type constraint $type", $value),
        );
        goto \&Test::More::ok;
}
FAST
1;
__END__
HideShow 108 lines of Pod
=pod
=encoding utf-8
=head1 NAME
Test::TypeTiny - useful functions for testing the efficacy of type constraints
=head1 SYNOPSIS
=for test_synopsis
BEGIN { die "SKIP: uses a module that doesn't exist as an example" };
   use strict;
   use warnings;
   use Test::More;
   use Test::TypeTiny;
    
   use Types::Mine qw(Integer Number);
    
   should_pass(1, Integer);
   should_pass(-1, Integer);
   should_pass(0, Integer);
   should_fail(2.5, Integer);
    
   ok_subtype(Number, Integer);
    
   done_testing;
=head1 STATUS
This module is covered by the
L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">.
=head1 DESCRIPTION
L<Test::TypeTiny> provides a few handy functions for testing type constraints.
=head2 Functions
=over
=item C<< should_pass($value, $type, $test_name) >>
=item C<< should_pass($value, $type) >>
Test that passes iff C<< $value >> passes C<< $type->check >>.
=item C<< should_fail($value, $type, $test_name) >>
=item C<< should_fail($value, $type) >>
Test that passes iff C<< $value >> fails C<< $type->check >>.
=item C<< ok_subtype($type, @subtypes) >>
Test that passes iff all C<< @subtypes >> are subtypes of C<< $type >>.
=item C<< EXTENDED_TESTING >>
Exportable boolean constant.
=item C<< matchfor(@things) >>
Assistant for matching exceptions. Not exported by default.
See also L<Test::Fatal::matchfor>.
=back
=head1 ENVIRONMENT
If the C<EXTENDED_TESTING> environment variable is set to true, this
module will promote each C<should_pass> or C<should_fail> test into a
subtest block and test the type constraint in both an inlined and
non-inlined manner.
This variable must be set at compile time (i.e. before this module is
loaded).
=head1 BUGS
Please report any bugs to
L<https://github.com/tobyink/p5-type-tiny/issues>.
=head1 SEE ALSO
L<Type::Tiny>.
For an alternative to C<should_pass>, see L<Test::Deep::Type> which will
happily accept a Type::Tiny type constraint instead of a MooseX::Types one.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2013-2014, 2017-2025 by Toby Inkster.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 DISCLAIMER OF WARRANTIES
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.