—

              
use 5.008005;
use strict;
use warnings;
use XSLoader ();
package Type::Tiny::XS;
our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.025';
__PACKAGE__->XSLoader::load( $VERSION );
use Scalar::Util qw(refaddr);
my %names = (
        map +( $_ => __PACKAGE__ . "::$_" ), qw/
                Any ArrayRef Bool ClassName CodeRef Defined
                FileHandle GlobRef HashRef Int Num Object
                Ref RegexpRef ScalarRef Str Undef Value
                PositiveInt PositiveOrZeroInt NonEmptyStr
                ArrayLike HashLike CodeLike StringLike
                Map Tuple Enum AnyOf AllOf
                /
);
$names{Item} = $names{Any};
if ( $] lt '5.010000' ) {
        require MRO::Compat;
        *Type::Tiny::XS::Util::get_linear_isa = \&mro::get_linear_isa;
         
        my $overloaded = sub {
                require overload;
                overload::Overloaded( ref $_[0] or $_[0] )
                        and overload::Method( ( ref $_[0] or $_[0] ), $_[1] );
        };
         
        no warnings qw( uninitialized redefine once );
        *StringLike = sub {
                defined( $_[0] ) && !ref( $_[0] )
                        or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[""] );
        };
        *CodeLike = sub {
                ref( $_[0] ) eq 'CODE'
                        or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[&{}] );
        };
        *HashLike = sub {
                ref( $_[0] ) eq 'HASH'
                        or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[%{}] );
        };
        *ArrayLike = sub {
                ref( $_[0] ) eq 'ARRAY'
                        or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[@{}] );
        };
} #/ if ( $] < '5.010000' [)
my %coderefs;
sub _know {
        my ( $coderef, $type ) = @_;
        $coderefs{ refaddr( $coderef ) } = $type;
}
sub is_known {
        my $coderef = shift;
        $coderefs{ refaddr( $coderef ) };
}
for ( reverse sort keys %names ) {
        no strict qw(refs);
        _know \&{ $names{$_} }, $_;
}
my $id = 0;
sub get_coderef_for {
        my $type = $_[0];
         
        return do {
                no strict qw(refs);
                \&{ $names{$type} };
        } if exists $names{$type};
         
        my $made;
         
        if ( $type =~ /^ArrayRef\[(.+)\]$/ ) {
                my $child = get_coderef_for( $1 ) or return;
                $made = _parameterize_ArrayRef_for( $child );
        }
         
        elsif ( $] ge '5.010000' and $type =~ /^ArrayLike\[(.+)\]$/ ) {
                my $child = get_coderef_for( $1 ) or return;
                $made = _parameterize_ArrayLike_for( $child );
        }
         
        elsif ( $type =~ /^HashRef\[(.+)\]$/ ) {
                my $child = get_coderef_for( $1 ) or return;
                $made = _parameterize_HashRef_for( $child );
        }
         
        elsif ( $] ge '5.010000' and $type =~ /^HashLike\[(.+)\]$/ ) {
                my $child = get_coderef_for( $1 ) or return;
                $made = _parameterize_HashLike_for( $child );
        }
         
        elsif ( $type =~ /^Map\[(.+),(.+)\]$/ ) {
                my @children;
                if ( eval { require Type::Parser } ) {
                        @children = map scalar( get_coderef_for( $_ ) ), _parse_parameters( $type );
                }
                else {
                        push @children, get_coderef_for( $1 );
                        push @children, get_coderef_for( $2 );
                }
                @children == 2 or return;
                defined        or return for @children;
                $made = _parameterize_Map_for( \@children );
        } #/ elsif ( $type =~ /^Map\[(.+),(.+)\]$/)
         
        elsif ( $type =~ /^(AnyOf|AllOf|Tuple)\[(.+)\]$/ ) {
                my $base = $1;
                my @children =
                        map scalar( get_coderef_for( $_ ) ),
                        ( eval { require Type::Parser } )
                        ? _parse_parameters( $type )
                        : split( /,/, $2 );
                defined or return for @children;
                my $maker = __PACKAGE__->can( "_parameterize_${base}_for" );
                $made = $maker->( \@children ) if $maker;
        } #/ elsif ( $type =~ /^(AnyOf|AllOf|Tuple)\[(.+)\]$/)
         
        elsif ( $type =~ /^Maybe\[(.+)\]$/ ) {
                my $child = get_coderef_for( $1 ) or return;
                $made = _parameterize_Maybe_for( $child );
        }
         
        elsif ( $type =~ /^InstanceOf\[(.+)\]$/ ) {
                my $class = $1;
                return unless Type::Tiny::XS::Util::is_valid_class_name( $class );
                $made = Type::Tiny::XS::Util::generate_isa_predicate_for( $class );
        }
         
        elsif ( $type =~ /^HasMethods\[(.+)\]$/ ) {
                my $methods = [ sort( split /,/, $1 ) ];
                /^[^\W0-9]\w*$/ or return for @$methods;
                $made = Type::Tiny::XS::Util::generate_can_predicate_for( $methods );
        }
         
        # Type::Tiny::Enum > 1.010003 double-quotes its enums
        elsif ( $type =~ /^Enum\[".*"\]$/ ) {
                if ( eval { require Type::Parser } ) {
                        my $parsed = Type::Parser::parse( $type );
                        if ( $parsed->{type} eq "parameterized" ) {
                                my @todo = $parsed->{params};
                                my @strings;
                                my $bad;
                                while ( my $todo = shift @todo ) {
                                        if ( $todo->{type} eq 'list' ) {
                                                push @todo, @{ $todo->{list} };
                                        }
                                        elsif ( $todo->{type} eq "expression"
                                                && $todo->{op}->type eq Type::Parser::COMMA() )
                                        {
                                                push @todo, $todo->{lhs}, $todo->{rhs};
                                        }
                                        elsif ( $todo->{type} eq "primary" && $todo->{token}->type eq "QUOTELIKE" ) {
                                                push @strings, eval( $todo->{token}->spelling );
                                        }
                                        else {
                                                # Unexpected entry in the parse-tree, bail out
                                                $bad = 1;
                                        }
                                } #/ while ( my $todo = shift ...)
                                $made = _parameterize_Enum_for( \@strings ) unless $bad;
                        } #/ if ( $parsed->{type} eq...)
                } #/ if ( eval { require Type::Parser...})
        } #/ elsif ( $type =~ /^Enum\[".*"\]$/)
         
        elsif ( $type =~ /^Enum\[(.+)\]$/ ) {
                my $strings = [ sort( split /,/, $1 ) ];
                $made = _parameterize_Enum_for( $strings );
        }
         
        if ( $made ) {
                no strict qw(refs);
                my $slot = sprintf( '%s::AUTO::TC%d', __PACKAGE__, ++$id );
                $names{$type} = $slot;
                _know( $made, $type );
                *$slot = $made;
                return $made;
        }
         
        return;
} #/ sub get_coderef_for
sub get_subname_for {
        my $type = $_[0];
        get_coderef_for( $type ) unless exists $names{$type};
        $names{$type};
}
sub _parse_parameters {
        my $got = Type::Parser::parse( @_ );
        $got->{params} or return;
        _handle_expr( $got->{params} );
}
sub _handle_expr {
        my $e = shift;
         
        if ( $e->{type} eq 'list' ) {
                return map _handle_expr( $_ ), @{ $e->{list} };
        }
        if ( $e->{type} eq 'parameterized' ) {
                my ( $base ) = _handle_expr( $e->{base} );
                my @params = _handle_expr( $e->{params} );
                return sprintf( '%s[%s]', $base, join( q[,], @params ) );
        }
        if ( $e->{type} eq 'expression' and $e->{op}->type eq Type::Parser::COMMA() ) {
                return _handle_expr( $e->{lhs} ), _handle_expr( $e->{rhs} );
        }
        if ( $e->{type} eq 'primary' ) {
                return $e->{token}->spelling;
        }
         
        '****';
} #/ sub _handle_expr
1;
__END__
HideShow 89 lines of Pod
=pod
=encoding utf-8
=head1 NAME
Type::Tiny::XS - provides an XS boost for some of Type::Tiny's built-in type constraints
=head1 SYNOPSIS
   use Types::Standard qw(Int);
=head1 DESCRIPTION
This module is optionally used by L<Type::Tiny> 0.045_03 and above
to provide faster, C-based implementations of some type constraints.
(This package has only core dependencies, and does not depend on
Type::Tiny, so other data validation frameworks might also consider
using it!)
Only the following three functions should be considered part of the
supported API:
=over
=item C<< Type::Tiny::XS::get_coderef_for($type) >>
Given a supported type constraint name, such as C<< "Int" >>, returns
a coderef that can be used to validate a parameter against this
constraint.
Returns undef if this module cannot provide a suitable coderef.
=item C<< Type::Tiny::XS::get_subname_for($type) >>
Like C<get_coderef_for> but returns the name of such a sub as a string.
Returns undef if this module cannot provide a suitable sub name.
=item C<< Type::Tiny::XS::is_known($coderef) >>
Returns true if the coderef was provided by Type::Tiny::XS.
=back
In addition to the above functions, the subs returned by
C<get_coderef_for> and C<get_subname_for> are considered part of the
"supported API", but only for the lifetime of the Perl process that
returned them.
To clarify, if you call C<< get_subname_for("ArrayRef[Int]") >> in a
script, this will return the name of a sub. That sub (which can be used
to validate arrayrefs of integers) is now considered part of the
supported API of Type::Tiny::XS until the script finishes running. Next
time the script runs, there is no guarantee that the sub will continue
to exist, or continue to do the same thing.
=head1 BUGS
Please report any bugs to
L<http://rt.cpan.org/Dist/Display.html?Queue=Type-Tiny-XS>.
=head1 SEE ALSO
L<Type::Tiny>, L<Types::Standard>.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt> forked all this from
L<Mouse::Util::TypeConstraints>.
B<ArrayLike>, B<HashLike>, B<CodeLike>, and B<StringLike> constraints
based on code by ikegami on StackOverflow.
L<https://stackoverflow.com/a/64019481/1990570>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2014, 2018-2020 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.