From 4955521af50238046847bce51ad9865950324f77 Mon Sep 17 00:00:00 2001 From: Carlos Rodriguez Date: Tue, 3 Mar 2020 17:42:38 -0600 Subject: [PATCH] Improved random number generator. --- CHANGES.md | 1 + Kernel/System/Environment.pm | 6 + Kernel/System/Main.pm | 1 + Kernel/cpan-lib/Crypt/Random/Source.pm | 150 ++ Kernel/cpan-lib/Crypt/Random/Source/Base.pm | 131 + .../cpan-lib/Crypt/Random/Source/Base/File.pm | 93 + .../Crypt/Random/Source/Base/Handle.pm | 222 ++ .../cpan-lib/Crypt/Random/Source/Base/Proc.pm | 116 + .../Crypt/Random/Source/Base/RandomDevice.pm | 86 + .../cpan-lib/Crypt/Random/Source/Factory.pm | 241 ++ Kernel/cpan-lib/Crypt/Random/Source/Strong.pm | 61 + .../Crypt/Random/Source/Strong/devrandom.pm | 56 + Kernel/cpan-lib/Crypt/Random/Source/Weak.pm | 61 + .../Crypt/Random/Source/Weak/devurandom.pm | 55 + .../cpan-lib/Devel/TypeTiny/Perl56Compat.pm | 85 + .../cpan-lib/Devel/TypeTiny/Perl58Compat.pm | 74 + Kernel/cpan-lib/Error/TypeTiny.pm | 305 +++ Kernel/cpan-lib/Error/TypeTiny/Assertion.pm | 213 ++ Kernel/cpan-lib/Error/TypeTiny/Compilation.pm | 96 + .../Error/TypeTiny/WrongNumberOfParameters.pm | 139 + Kernel/cpan-lib/Eval/TypeTiny.pm | 418 +++ Kernel/cpan-lib/Exporter/Shiny.pm | 116 + Kernel/cpan-lib/Exporter/Tiny.pm | 508 ++++ Kernel/cpan-lib/Math/Random/ISAAC.pm | 322 +++ Kernel/cpan-lib/Math/Random/ISAAC/PP.pm | 396 +++ Kernel/cpan-lib/Math/Random/Secure.pm | 306 +++ Kernel/cpan-lib/Math/Random/Secure/RNG.pm | 239 ++ Kernel/cpan-lib/Module/Find.pm | 371 +++ Kernel/cpan-lib/Reply/Plugin/TypeTiny.pm | 112 + Kernel/cpan-lib/Test/TypeTiny.pm | 247 ++ Kernel/cpan-lib/Type/Coercion.pm | 950 +++++++ Kernel/cpan-lib/Type/Coercion/FromMoose.pm | 127 + Kernel/cpan-lib/Type/Coercion/Union.pm | 141 ++ Kernel/cpan-lib/Type/Library.pm | 684 +++++ Kernel/cpan-lib/Type/Params.pm | 1711 +++++++++++++ Kernel/cpan-lib/Type/Parser.pm | 625 +++++ Kernel/cpan-lib/Type/Registry.pm | 540 ++++ Kernel/cpan-lib/Type/Tiny.pm | 2247 +++++++++++++++++ Kernel/cpan-lib/Type/Tiny/Class.pm | 370 +++ .../cpan-lib/Type/Tiny/ConstrainedObject.pm | 243 ++ Kernel/cpan-lib/Type/Tiny/Duck.pm | 241 ++ Kernel/cpan-lib/Type/Tiny/Enum.pm | 331 +++ Kernel/cpan-lib/Type/Tiny/Intersection.pm | 327 +++ Kernel/cpan-lib/Type/Tiny/Role.pm | 182 ++ Kernel/cpan-lib/Type/Tiny/Union.pm | 458 ++++ Kernel/cpan-lib/Type/Tiny/_HalfOp.pm | 94 + Kernel/cpan-lib/Type/Utils.pm | 1131 +++++++++ Kernel/cpan-lib/Types/Common/Numeric.pm | 341 +++ Kernel/cpan-lib/Types/Common/String.pm | 340 +++ Kernel/cpan-lib/Types/Standard.pm | 1546 ++++++++++++ Kernel/cpan-lib/Types/Standard/ArrayRef.pm | 249 ++ Kernel/cpan-lib/Types/Standard/CycleTuple.pm | 261 ++ Kernel/cpan-lib/Types/Standard/Dict.pm | 470 ++++ Kernel/cpan-lib/Types/Standard/HashRef.pm | 212 ++ Kernel/cpan-lib/Types/Standard/Map.pm | 253 ++ Kernel/cpan-lib/Types/Standard/ScalarRef.pm | 155 ++ Kernel/cpan-lib/Types/Standard/StrMatch.pm | 173 ++ Kernel/cpan-lib/Types/Standard/Tied.pm | 112 + Kernel/cpan-lib/Types/Standard/Tuple.pm | 401 +++ Kernel/cpan-lib/Types/TypeTiny.pm | 665 +++++ 60 files changed, 20807 insertions(+) create mode 100644 Kernel/cpan-lib/Crypt/Random/Source.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Base.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Base/File.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Base/Handle.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Base/Proc.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Base/RandomDevice.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Factory.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Strong.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Strong/devrandom.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Weak.pm create mode 100644 Kernel/cpan-lib/Crypt/Random/Source/Weak/devurandom.pm create mode 100644 Kernel/cpan-lib/Devel/TypeTiny/Perl56Compat.pm create mode 100644 Kernel/cpan-lib/Devel/TypeTiny/Perl58Compat.pm create mode 100644 Kernel/cpan-lib/Error/TypeTiny.pm create mode 100644 Kernel/cpan-lib/Error/TypeTiny/Assertion.pm create mode 100644 Kernel/cpan-lib/Error/TypeTiny/Compilation.pm create mode 100644 Kernel/cpan-lib/Error/TypeTiny/WrongNumberOfParameters.pm create mode 100644 Kernel/cpan-lib/Eval/TypeTiny.pm create mode 100644 Kernel/cpan-lib/Exporter/Shiny.pm create mode 100644 Kernel/cpan-lib/Exporter/Tiny.pm create mode 100644 Kernel/cpan-lib/Math/Random/ISAAC.pm create mode 100644 Kernel/cpan-lib/Math/Random/ISAAC/PP.pm create mode 100644 Kernel/cpan-lib/Math/Random/Secure.pm create mode 100644 Kernel/cpan-lib/Math/Random/Secure/RNG.pm create mode 100644 Kernel/cpan-lib/Module/Find.pm create mode 100644 Kernel/cpan-lib/Reply/Plugin/TypeTiny.pm create mode 100644 Kernel/cpan-lib/Test/TypeTiny.pm create mode 100644 Kernel/cpan-lib/Type/Coercion.pm create mode 100644 Kernel/cpan-lib/Type/Coercion/FromMoose.pm create mode 100644 Kernel/cpan-lib/Type/Coercion/Union.pm create mode 100644 Kernel/cpan-lib/Type/Library.pm create mode 100644 Kernel/cpan-lib/Type/Params.pm create mode 100644 Kernel/cpan-lib/Type/Parser.pm create mode 100644 Kernel/cpan-lib/Type/Registry.pm create mode 100644 Kernel/cpan-lib/Type/Tiny.pm create mode 100644 Kernel/cpan-lib/Type/Tiny/Class.pm create mode 100644 Kernel/cpan-lib/Type/Tiny/ConstrainedObject.pm create mode 100644 Kernel/cpan-lib/Type/Tiny/Duck.pm create mode 100644 Kernel/cpan-lib/Type/Tiny/Enum.pm create mode 100644 Kernel/cpan-lib/Type/Tiny/Intersection.pm create mode 100644 Kernel/cpan-lib/Type/Tiny/Role.pm create mode 100644 Kernel/cpan-lib/Type/Tiny/Union.pm create mode 100644 Kernel/cpan-lib/Type/Tiny/_HalfOp.pm create mode 100644 Kernel/cpan-lib/Type/Utils.pm create mode 100644 Kernel/cpan-lib/Types/Common/Numeric.pm create mode 100644 Kernel/cpan-lib/Types/Common/String.pm create mode 100644 Kernel/cpan-lib/Types/Standard.pm create mode 100644 Kernel/cpan-lib/Types/Standard/ArrayRef.pm create mode 100644 Kernel/cpan-lib/Types/Standard/CycleTuple.pm create mode 100644 Kernel/cpan-lib/Types/Standard/Dict.pm create mode 100644 Kernel/cpan-lib/Types/Standard/HashRef.pm create mode 100644 Kernel/cpan-lib/Types/Standard/Map.pm create mode 100644 Kernel/cpan-lib/Types/Standard/ScalarRef.pm create mode 100644 Kernel/cpan-lib/Types/Standard/StrMatch.pm create mode 100644 Kernel/cpan-lib/Types/Standard/Tied.pm create mode 100644 Kernel/cpan-lib/Types/Standard/Tuple.pm create mode 100644 Kernel/cpan-lib/Types/TypeTiny.pm --- a/Kernel/System/Environment.pm +++ b/Kernel/System/Environment.pm @@ -254,10 +254,12 @@ sub PerlInfoGet { CGI Class::Inspector Crypt::PasswdMD5 + Crypt::Random::Source CSS::Minifier Date::Pcalc Email::Valid Encode::Locale + Exporter::Tiny IO::Interactive JavaScript::Minifier JSON @@ -267,7 +269,10 @@ sub PerlInfoGet { LWP Mail::Address Mail::Internet + Math::Random::ISAAC + Math::Random::Secure MIME::Tools + Module::Find Module::Refresh Mozilla::CA Net::IMAP::Simple @@ -278,6 +283,7 @@ sub PerlInfoGet { Sys::Hostname::Long Text::CSV Text::Diff + Types::TypeTiny YAML URI ) --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source.pm @@ -0,0 +1,150 @@ +package Crypt::Random::Source; # git description: v0.13-4-g0edcf44 +# ABSTRACT: Get weak or strong random data from pluggable sources + +our $VERSION = '0.14'; + +use strict; +use 5.008; +use warnings; + +use Sub::Exporter -setup => { + exports => [qw( + get get_weak get_strong + factory + )], + groups => { default => [qw(get get_weak get_strong)] }, +}; + +use Crypt::Random::Source::Factory; + +our ( $factory, $weak, $strong, $any ); + +# silence some stupid destructor warnings +END { undef $weak; undef $strong; undef $any; undef $factory } + +sub factory () { $factory ||= Crypt::Random::Source::Factory->new } +sub _weak () { $weak ||= factory->get_weak } +sub _strong () { $strong ||= factory->get_strong } +sub _any () { $any ||= factory->get } + +sub get ($;@) { _any->get(@_) } +sub get_weak ($;@) { _weak->get(@_) } +sub get_strong ($;@) { _strong->get(@_) } + +# silence some stupid destructor warnings +END { undef $weak; undef $strong; undef $any; undef $factory } + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source - Get weak or strong random data from pluggable sources + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Crypt::Random::Source qw(get_strong); + + # get 10 cryptographically strong random bytes from an available source + my $bytes = get_strong(10); + +=head1 DESCRIPTION + +This module provides implementations for a number of byte oriented sources of +random data. + +See L for a more powerful way to locate +sources, and the various sources for specific implementations. + +=head1 EXPORTS + +=over 4 + +=item get + +=item get_weak + +=item get_strong + +These functions delegate to a source chosen by an instance of +L, calling get + +=back + +=head1 CAVEATS + +In versions prior to 0.13, C could be used as a result of calling +C, or C, if no random device was available. This implies that +not explicitly asking for C on a non POSIX operating system (e.g. +Win32 without the Win32 backend) could have resulted in non cryptographically +random data. + +Relatedly, the characterization of C as a weak source of randomness is +also largely a misconception, see L +for example. + +=head1 SEE ALSO + +L, L + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 CONTRIBUTORS + +=for stopwords Karen Etheridge Florian Ragwitz Graham Knop David Pottage Max Kanat-Alexander Edward Betts + +=over 4 + +=item * + +Karen Etheridge + +=item * + +Florian Ragwitz + +=item * + +Graham Knop + +=item * + +David Pottage + +=item * + +Max Kanat-Alexander + +=item * + +Edward Betts + +=back + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Base.pm @@ -0,0 +1,131 @@ +package Crypt::Random::Source::Base; +# ABSTRACT: Abstract base class for L classes + +our $VERSION = '0.14'; + +use Moo; +use namespace::clean; + +sub available { 0 } + +sub rank { 0 } + +sub seed { } + +sub get { die "abstract" } + +# cannibalized from IO::Scalar +sub read { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $read = $self->get($n); + $n = length($read); + ($off ? substr($_[1], $off) : $_[1]) = $read; + return $n; +} + +sub get_data { + my ( $self, %params ) = @_; + + if ( my $n = $params{Length} ) { + return $self->get($n); + } else { + my $size = $params{Size}; + + if (ref $size && ref $size eq "Math::Pari") { + $size = Math::Pari::pari2num($size); + } + + return $self->get( int($size / 8) + 1 ); + } +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Base - Abstract base class for L classes + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Moo; + extends qw(Crypt::Random::Source::Base); + +=head1 DESCRIPTION + +This is an abstract base class. + +In the future it will be a role. + +=head1 METHODS + +=head2 get $n, %args + +Gets C<$n> random bytes and returns them as a string. + +This method may produce fatal errors if the source was unable to provide enough +data. + +=head2 read $buf, $n, [ $off ] + +This method is cannibalized from L. It provides an L +work-alike. + +Note that subclasses override this to operate on a real handle directly if +available. + +=head2 seed @stuff + +On supporting sources this method will add C<@stuff>, whatever it may be, to +the random seed. + +Some sources may not support this, so be careful. + +=head2 available + +This is a class method, such that when it returns true calling C without +arguments on the class should provide a working source of random data. + +This is use by L. + +=head2 rank + +This is a class method, with some futz value for a ranking, to help known good +sources be tried before known bad (slower, less available) sources. + +=head2 get_data %Params + +Provided for compatibility with L + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Base/File.pm @@ -0,0 +1,93 @@ +package Crypt::Random::Source::Base::File; +# ABSTRACT: File (or device) random data sources + +our $VERSION = '0.14'; + +use Moo; + +use Carp qw(croak); + +extends qw(Crypt::Random::Source::Base::Handle); + +use IO::File; +use namespace::clean; + +has path => ( + is => "rw", + required => 1, +); + +sub open_handle { + my ( $self, $mode ) = @_; + + my $file = $self->path; + + my $fh = IO::File->new; + + $fh->open($file, $mode || "r") + or croak "open($file): $!"; + + return $fh; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Base::File - File (or device) random data sources + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Moo; + extends qw(Crypt::Random::Source::Base::File); + + has '+path' => ( + default => "/foo/bar", + ); + +=head1 DESCRIPTION + +This is a base class for file (or file like) random data sources. + +=head1 ATTRIBUTES + +=head2 path + +A required attribute, the path to the file to open. + +=head1 METHODS + +=head2 open_handle + +Uses L to open C for reading. + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Base/Handle.pm @@ -0,0 +1,222 @@ +package Crypt::Random::Source::Base::Handle; +# ABSTRACT: L based random data sources + +our $VERSION = '0.14'; + +use Moo; +use Types::Standard qw(Bool); + +use Errno; + +use Carp qw(croak); +use IO::Handle; +use namespace::clean; + +extends qw(Crypt::Random::Source::Base); + +has allow_under_read => ( + isa => Bool, + is => "rw", + default => 0, +); + +has reread_attempts => ( + is => "rw", + default => 1, +); + +has handle => ( + is => "rw", + lazy => 1, + builder => 1, + predicate => "has_handle", + clearer => "clear_handle", +); + +sub blocking { shift->handle->blocking(@_) } +sub read { shift->handle->read(@_) } +sub opened { shift->handle->opened(@_) } + +sub DEMOLISH { + my $self = shift; + $self->close; +} + +sub _build_handle { + my ( $self, @args ) = @_; + $self->open_handle; +} + +sub open_handle { + die "open_handle is an abstract method"; +} + +sub get { + my ( $self, $n, @args ) = @_; + + croak "How many bytes would you like to read?" unless $n; + + return $self->_read($self->handle, $n, @args); +} + +sub _read { + my ( $self, $handle, $n, @args) = @_; + + my $buf; + my $got = $self->read($buf, $n); + + if ( defined($got) && $got == $n || $!{EWOULDBLOCK} || $!{EAGAIN} ) { + return $buf; + } else { + croak "read error: $!" unless defined $got; + return $self->_read_too_short($buf, $got, $n, @args); + } +} + +sub _read_too_short { + my ( $self, $buf, $got, $req, %args ) = @_; + + if ( $self->allow_under_read ) { + return $buf; + } else { + if ( ($self->reread_attempts || 0) >= ($args{reread_attempt} || 0) ) { + croak "Source failed to read enough bytes (requested $req, got $got)"; + } else { + return $buf . $self->_read( $req - $got, reread_attempt => 1 + ( $args{reread_attempt} || 0 ) ); + } + } +} + +sub close { + my $self = shift; + + # During global destruction, $self->handle can be undef already, + # so we need to also check if it is defined. + if ( $self->has_handle and $self->handle ) { + $self->handle->close; # or die "close: $!"; # open "-|" returns exit status on close + $self->clear_handle; + } +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Base::Handle - L based random data sources + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Moo; + extends qw(Crypt::Random::Source::Base::Handle); + + sub open_handle { + # invoked as needed + } + + + # this class can also be used directly + Crypt::Random::Source::Base::Handle->new( handle => $file_handle ); + + + # it supports some standard methods: + + $p->blocking(0); + + $p->read( my $buf, $n ); # no error handling here + +=head1 DESCRIPTION + +This is a concrete base class for all L based random data sources. + +It implements error handling + +=head1 ATTRIBUTES + +=head2 handle + +An L or file handle to read from. + +=head2 blocking + +This is actually handled by C, and is documented in L. + +=head2 allow_under_read + +Whether or not under reading is considered an error. + +Defaults to false. + +=head2 reread_attempts + +The number of attempts to make at rereading if the handle did not provide +enough bytes on the first attempt. + +Defaults to 1. + +Only used if C is enabled. + +=head1 METHODS + +=head2 get + +See L. + +When C or C are set to a true value this method may +return fewer bytes than requested. + +=head2 read + +This delegates directly to C. + +It B provide the same validation as C would have, so no checking +for underreads is done. + +=head2 close + +Close the handle and clear it. + +=head2 _read + +C<< $self->handle->read >> but with additional error checking and different +calling conventions. + +=head2 _read_too_short + +Called by C<_read> when not enough data was read from the handle. Normally it +will either die with an error or attempt to reread. When C is +true it will just return the partial buffer. + +=head2 open_handle + +Abstract method, should return an L to use. + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Base/Proc.pm @@ -0,0 +1,116 @@ +package Crypt::Random::Source::Base::Proc; +# ABSTRACT: Base class for helper processes (e.g. C) + +our $VERSION = '0.14'; + +use Moo; + +extends qw(Crypt::Random::Source::Base::Handle); + +use Capture::Tiny 0.08 qw(capture); +use File::Spec; +use IO::File 1.14; +use Types::Standard qw(Str); +use namespace::clean; + +use 5.008; + +has command => ( is => "rw", required => 1 ); +has search_path => ( is => 'rw', isa => Str, lazy => 1, builder => 1); + +# This is a scalar so that people can customize it (which they would +# particularly need to do on Windows). +our $TAINT_PATH = + '/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin'; + +sub _build_search_path { + # In taint mode it's not safe to use $ENV{PATH}. + if (${^TAINT}) { + return $TAINT_PATH; + } + return $ENV{PATH}; +} + +sub open_handle { + my $self = shift; + + my $cmd = $self->command; + my @cmd = ref $cmd ? @$cmd : $cmd; + my $retval; + local $ENV{PATH} = $self->search_path; + my ($stdout, $stderr) = capture { $retval = system(@cmd) }; + chomp($stderr); + if ($retval) { + my $err = join(' ', @cmd) . ": $! ($?)"; + if ($stderr) { + $err .= "\n$stderr"; + } + die $err; + } + warn $stderr if $stderr; + + my $fh = IO::File->new(\$stdout, '<'); + + return $fh; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Base::Proc - Base class for helper processes (e.g. C) + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Moo; + extends qw(Crypt::Random::Source::Base::Proc); + + has '+command' => ( default => ... ); + +=head1 DESCRIPTION + +This is a base class for using command line utilities which output random data +on STDOUT as L objects. + +=head1 ATTRIBUTES + +=head2 command + +An array reference or string that is the command to run. + +=head1 METHODS + +=head2 open_handle + +Opens a pipe for reading using C. + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Base/RandomDevice.pm @@ -0,0 +1,86 @@ +package Crypt::Random::Source::Base::RandomDevice; +# ABSTRACT: Base class for random devices + +our $VERSION = '0.14'; + +use Moo; + +extends qw(Crypt::Random::Source::Base::File); +use namespace::clean; + +sub rank { 100 } # good quality, pretty fast + +has '+path' => ( + lazy => 1, + required => 0, + builder => "default_path", +); + +sub available { + -r shift->default_path; +} + +sub seed { + my ( $self, @args ) = @_; + + my $fh = $self->open_handle("w+"); + + print $fh @args; + + close $fh; +} + +sub default_path { + die "abstract"; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Base::RandomDevice - Base class for random devices + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Moo; + extends qw(Crypt::Random::Source::Base::RandomDevice); + + sub default_path { "/dev/myrandom" } + +=head1 DESCRIPTION + +This is a base class for random device sources. + +See L and +L for actual implementations. + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Factory.pm @@ -0,0 +1,241 @@ +package Crypt::Random::Source::Factory; +# ABSTRACT: Load and instantiate sources of random data + +our $VERSION = '0.14'; + +use Moo; +use Carp qw(croak); +use Module::Find; +use Module::Runtime qw(require_module); +use Types::Standard qw(ClassName Bool ArrayRef Str); +use namespace::clean; + +sub get { + my ( $self, %args ) = @_; + + my $type = delete $args{type} || "any"; + + my $method = "new_$type"; + + $self->can($method) or croak "Don't know how to create a source of type $type"; + + $self->$method(%args); +} + +sub get_weak { + my ( $self, @args ) = @_; + $self->get( @args, type => "weak" ); +} + +sub get_strong { + my ( $self, @args ) = @_; + $self->get( @args, type => "strong" ); +} + +has weak_source => ( + isa => ClassName, + is => "rw", + lazy => 1, + builder => 1, + clearer => "clear_weak_source", + predicate => "has_weak_source", + handles => { new_weak => "new" }, +); + +sub _build_weak_source { + my $self = shift; + $self->best_available(@{ $self->weak_sources }); +} + +has strong_source => ( + isa => ClassName, + is => "rw", + lazy => 1, + builder => 1, + clearer => "clear_strong_source", + predicate => 'has_strong_source', + handles => { new_strong => "new" }, +); + +sub _build_strong_source { + my $self = shift; + $self->best_available(@{ $self->strong_sources }); +} + +has any_source => ( + isa => ClassName, + is => "rw", + lazy => 1, + builder => 1, + clearer => "clear_any_source", + predicate => 'has_any_source', + handles => { new_any => 'new' }, +); + +sub _build_any_source { + my $self = shift; + $self->weak_source || $self->strong_source; +} + +has scan_inc => ( + is => "ro", + isa => Bool, + lazy => 1, + builder => 1, + clearer => 'clear_scan_inc', + predicate => 'has_scan_inc', +); + +sub _build_scan_inc { + my $self = shift; + + if ( exists $ENV{CRYPT_RANDOM_NOT_PLUGGABLE} ) { + return !$ENV{CRYPT_RANDOM_NOT_PLUGGABLE}; + } else { + return 1; + } +} + +has weak_sources => ( + isa => ArrayRef[Str], + is => "rw", + lazy => 1, + builder => 1, + clearer => 'clear_weak_sources', + predicate => 'has_weak_sources', +); + +sub _build_weak_sources { + my $self = shift; + + if ( $self->scan_inc ) { + $self->locate_sources("Weak"); + } else { + return [qw( + Crypt::Random::Source::Weak::devurandom + Crypt::Random::Source::Weak::openssl + )]; + } +} + +has strong_sources => ( + isa => ArrayRef[Str], + is => "rw", + lazy => 1, + builder => 1, + clearer => 'clear_strong_sources', + predicate => 'has_strong_sources', +); + +sub _build_strong_sources { + my $self = shift; + + if ( $self->scan_inc ) { + return $self->locate_sources("Strong"); + } else { + return [qw( + Crypt::Random::Source::Strong::devrandom + Crypt::Random::Source::Strong::egd + )]; + } +} + +sub best_available { + my ( $self, @sources ) = @_; + + my @available = grep { local $@; eval { require_module($_); $_->available }; } @sources; + + my @sorted = sort { $b->rank <=> $a->rank } @available; + + wantarray ? @sorted : $sorted[0]; +} + +sub first_available { + my ( $self, @sources ) = @_; + + foreach my $class ( @sources ) { + local $@; + return $class if eval { require_module($class); $class->available }; + } +} + +sub locate_sources { + my ( $self, $category ) = @_; + my @sources = findsubmod "Crypt::Random::Source::$category"; + # Untaint class names (which are tainted in taint mode because + # they came from the disk). + ($_) = $_ =~ /^(.*)$/ foreach @sources; + return \@sources; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Factory - Load and instantiate sources of random data + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Crypt::Random::Source::Factory; + + my $f = Crypt::Random::Source::Factory->new; + + my $strong = $f->get_strong; + + my $weak = $f->get_weak; + + my $any = $f->get; + +=head1 DESCRIPTION + +This class implements a loading and instantiation factory for +L objects. + +If C<$ENV{CRYPT_RANDOM_NOT_PLUGGABLE}> is set then only a preset list of +sources will be tried. Otherwise L will be used to locate any +installed sources, and use the first available one. + +=head1 METHODS + +=head2 get %args + +Instantiate any random source, passing %args to the constructor. + +The C argument can be C, C or C. + +=head2 get_weak %args + +=head2 get_strong %args + +Instantiate a new weak or strong random source. + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Strong.pm @@ -0,0 +1,61 @@ +package Crypt::Random::Source::Strong; +# ABSTRACT: Abstract base class for strong random data sources + +our $VERSION = '0.14'; + +use Moo; +use namespace::clean; + +sub is_strong { 1 } + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Strong - Abstract base class for strong random data sources + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Moo; + extends qw(Crypt::Random::Source::Strong); + +=head1 DESCRIPTION + +This is an abstract base class. There isn't much to describe. + +=head1 METHODS + +=head2 is_strong + +Returns true + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Strong/devrandom.pm @@ -0,0 +1,56 @@ +package Crypt::Random::Source::Strong::devrandom; +# ABSTRACT: A strong random data source using F + +our $VERSION = '0.14'; + +use Moo; + +extends qw( + Crypt::Random::Source::Strong + Crypt::Random::Source::Base::RandomDevice +); + +use namespace::clean; + +sub default_path { "/dev/random" } + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Strong::devrandom - A strong random data source using F + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Crypt::Random::Source::Strong::devrandom; + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Weak.pm @@ -0,0 +1,61 @@ +package Crypt::Random::Source::Weak; +# ABSTRACT: Abstract base class for weak random data sources + +our $VERSION = '0.14'; + +use Moo; +use namespace::clean; + +sub is_strong { 0 } + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Weak - Abstract base class for weak random data sources + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Moo; + extends qw(Crypt::Random::Source::Weak); + +=head1 DESCRIPTION + +This is an abstract base class. There isn't much to describe. + +=head1 METHODS + +=head2 is_strong + +Returns false + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Crypt/Random/Source/Weak/devurandom.pm @@ -0,0 +1,55 @@ +package Crypt::Random::Source::Weak::devurandom; +# ABSTRACT: A weak random data source using F + +our $VERSION = '0.14'; + +use Moo; + +extends qw( + Crypt::Random::Source::Weak + Crypt::Random::Source::Base::RandomDevice +); +use namespace::clean; + +sub default_path { "/dev/urandom" } + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Crypt::Random::Source::Weak::devurandom - A weak random data source using F + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Crypt::Random::Source::Weak::devurandom; + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +=head1 AUTHOR + +יובל קוג'מן (Yuval Kogman) + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2008 by Yuval Kogman. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + +__END__ + + +# ex: set sw=4 et: --- /dev/null +++ b/Kernel/cpan-lib/Devel/TypeTiny/Perl56Compat.pm @@ -0,0 +1,85 @@ +package Devel::TypeTiny::Perl56Compat; + +use 5.006; +use strict; +use warnings; + +our $AUTHORITY = 'cpan:TOBYINK'; +our $VERSION = '1.010000'; + +$VERSION =~ tr/_//d; + +#### B doesn't provide perlstring() in 5.6. Monkey patch it. + +use B (); + +unless (exists &B::perlstring) +{ + my $d; + *B::perlstring = sub { + no warnings 'uninitialized'; + require Data::Dumper; + $d ||= 'Data::Dumper'->new([])->Indent(0)->Purity(0)->Pad('')->Useqq(1)->Terse(1)->Freezer('')->Toaster(''); + my $perlstring = $d->Values([''.shift])->Dump; + ($perlstring =~ /^"/) ? $perlstring : qq["$perlstring"]; + }; +} + +unless (exists &B::cstring) +{ + *B::cstring = \&B::perlstring; +} + +push @B::EXPORT_OK, qw( perlstring cstring ); + +#### Done! + +5.6; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords pragmas + +=head1 NAME + +Devel::TypeTiny::Perl56Compat - shims to allow Type::Tiny to run on Perl 5.6.x + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This is not considered part of Type::Tiny's public API. + +Currently this module just has one job: it patches L to export a +C function, as this was only added in Perl 5.8.0. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Devel/TypeTiny/Perl58Compat.pm @@ -0,0 +1,74 @@ +package Devel::TypeTiny::Perl58Compat; + +use 5.006; +use strict; +use warnings; + +our $AUTHORITY = 'cpan:TOBYINK'; +our $VERSION = '1.010000'; + +$VERSION =~ tr/_//d; + +#### re doesn't provide is_regexp in Perl < 5.10 + +eval 'require re'; + +unless (exists &re::is_regexp) +{ + require B; + *re::is_regexp = sub { + eval { B::svref_2object($_[0])->MAGIC->TYPE eq 'r' }; + }; +} + +#### Done! + +5.8; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords pragmas + +=head1 NAME + +Devel::TypeTiny::Perl58Compat - shims to allow Type::Tiny to run on Perl 5.8.x + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This is not considered part of Type::Tiny's public API. + +Currently this module just has one job: it patches L to provide a +C function, as this was only added in Perl 5.9.5. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Error/TypeTiny.pm @@ -0,0 +1,305 @@ +package Error::TypeTiny; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Error::TypeTiny::AUTHORITY = 'cpan:TOBYINK'; + $Error::TypeTiny::VERSION = '1.010000'; +} + +$Error::TypeTiny::VERSION =~ tr/_//d; + +require Type::Tiny; +__PACKAGE__->Type::Tiny::_install_overloads( + q[""] => sub { $_[0]->to_string }, + q[bool] => sub { 1 }, +); + +our %CarpInternal; +$CarpInternal{$_}++ for qw( + Types::Standard::_Stringable + Exporter::Tiny + Eval::TypeTiny::Sandbox + + Devel::TypeTiny::Perl56Compat + Devel::TypeTiny::Perl58Compat + Error::TypeTiny + Error::TypeTiny::Assertion + Error::TypeTiny::Compilation + Error::TypeTiny::WrongNumberOfParameters + Eval::TypeTiny + Reply::Plugin::TypeTiny + Test::TypeTiny + Type::Coercion + Type::Coercion::FromMoose + Type::Coercion::Union + Type::Library + Type::Params + Type::Parser + Type::Registry + Types::Common::Numeric + Types::Common::String + Types::Standard + Types::Standard::ArrayRef + Types::Standard::CycleTuple + Types::Standard::Dict + Types::Standard::HashRef + Types::Standard::Map + Types::Standard::ScalarRef + Types::Standard::StrMatch + Types::Standard::Tied + Types::Standard::Tuple + Types::TypeTiny + Type::Tiny + Type::Tiny::Class + Type::Tiny::Duck + Type::Tiny::Enum + Type::Tiny::_HalfOp + Type::Tiny::Intersection + Type::Tiny::Role + Type::Tiny::Union + Type::Utils +); + +sub new +{ + my $class = shift; + my %params = (@_==1) ? %{$_[0]} : @_; + return bless \%params, $class; +} + +sub throw +{ + my $class = shift; + + my ($level, @caller, %ctxt) = 0; + while (do { + my $caller = caller $level; + defined $caller and $CarpInternal{$caller}; + }) { $level++ }; + if ( ((caller($level - 1))[1]||"") =~ /^(?:parameter validation for|exportable function) '(.+?)'$/ ) + { + my ($pkg, $func) = ($1 =~ m{^(.+)::(\w+)$}); + $level++ if caller($level) eq ($pkg||""); + } + # Moo's Method::Generate::Constructor puts an eval in the stack trace, + # that is useless for debugging, so show the stack frame one above. + $level++ if ( + (caller($level))[1] =~ /^\(eval \d+\)$/ and + (caller($level))[3] eq '(eval)' # (caller())[3] is $subroutine + ); + @ctxt{qw/ package file line /} = caller($level); + + my $stack = undef; + if (our $StackTrace) + { + require Devel::StackTrace; + $stack = "Devel::StackTrace"->new( + ignore_package => [ keys %CarpInternal ], + ); + } + + die( + our $LastError = $class->new( + context => \%ctxt, + stack_trace => $stack, + @_, + ) + ); +} + +sub message { $_[0]{message} ||= $_[0]->_build_message }; +sub context { $_[0]{context} }; +sub stack_trace { $_[0]{stack_trace} }; + +sub to_string +{ + my $e = shift; + my $c = $e->context; + my $m = $e->message; + + $m =~ /\n\z/s ? $m : + $c ? sprintf("%s at %s line %s.\n", $m, $c->{file}||'file?', $c->{line}||'NaN') : + sprintf("%s\n", $m); +} + +sub _build_message +{ + return 'An exception has occurred'; +} + +sub croak +{ + my ($fmt, @args) = @_; + @_ = ( + __PACKAGE__, + message => sprintf($fmt, @args), + ); + goto \&throw; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Error::TypeTiny - exceptions for Type::Tiny and friends + +=head1 SYNOPSIS + + use Data::Dumper; + use Try::Tiny; + use Types::Standard qw(Str); + + try { + Str->assert_valid(undef); + } + catch { + my $exception = shift; + warn "Encountered Error: $exception"; + warn Dumper($exception->explain) + if $exception->isa("Error::TypeTiny::Assertion"); + }; + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +When Type::Tiny and its related modules encounter an error, they throw an +exception object. These exception objects inherit from Error::TypeTiny. + +=head2 Constructors + +=over + +=item C<< new(%attributes) >> + +Moose-style constructor function. + +=item C<< throw(%attributes) >> + +Constructs an exception and passes it to C. + +Automatically populates C and C if appropriate. + +=back + +=head2 Attributes + +=over + +=item C + +The error message. + +=item C + +Hashref containing the package, file and line that generated the error. + +=item C + +A more complete stack trace. This feature requires L; +use the C<< $StackTrace >> package variable to switch it on. + +=back + +=head2 Methods + +=over + +=item C + +Returns the message, followed by the context if it is set. + +=back + +=head2 Functions + +=over + +=item C<< Error::TypeTiny::croak($format, @args) >> + +Functional-style shortcut to C method. Takes an C-style +format string and optional arguments to construct the C. + +=back + +=head2 Overloading + +=over + +=item * + +Stringification is overloaded to call C. + +=back + +=head2 Package Variables + +=over + +=item C<< %Error::TypeTiny::CarpInternal >> + +Serves a similar purpose to C<< %Carp::CarpInternal >>. + +=item C<< $Error::TypeTiny::StackTrace >> + +Boolean to toggle stack trace generation. + +=item C<< $Error::TypeTiny::LastError >> + +A reference to the last exception object thrown. + +=back + +=head1 CAVEATS + +Although Error::TypeTiny objects are thrown for errors produced by +Type::Tiny, that doesn't mean every time you use Type::Tiny you'll get +Error::TypeTinys whenever you want. + +For example, if you use a Type::Tiny type constraint in a Moose attribute, +Moose will not call the constraint's C method (which throws +an exception). Instead it will call C and C (which do +not), and will C an error message of its own. (The C<< $LastError >> +package variable may save your bacon.) + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L, +L. + +L, L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Error/TypeTiny/Assertion.pm @@ -0,0 +1,213 @@ +package Error::TypeTiny::Assertion; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + if ($] < 5.008) { require Devel::TypeTiny::Perl56Compat }; +} + +BEGIN { + $Error::TypeTiny::Assertion::AUTHORITY = 'cpan:TOBYINK'; + $Error::TypeTiny::Assertion::VERSION = '1.010000'; +} + +$Error::TypeTiny::Assertion::VERSION =~ tr/_//d; + +require Error::TypeTiny; +our @ISA = 'Error::TypeTiny'; + +sub type { $_[0]{type} }; +sub value { $_[0]{value} }; +sub varname { $_[0]{varname} ||= '$_' }; +sub attribute_step { $_[0]{attribute_step} }; +sub attribute_name { $_[0]{attribute_name} }; + +sub has_type { defined $_[0]{type} }; # sic +sub has_attribute_step { exists $_[0]{attribute_step} }; +sub has_attribute_name { exists $_[0]{attribute_name} }; + +sub new +{ + my $class = shift; + my $self = $class->SUPER::new(@_); + + # Supported but undocumented parameter is `mgaca`. + # This indicates whether Error::TypeTiny::Assertion + # should attempt to figure out which attribute caused + # the error from Method::Generate::Accessor's info. + # Can be set to true/false or not set. If not set, + # the current behaviour is true, but this may change + # in the future. If set to false, will ignore the + # $Method::Generate::Accessor::CurrentAttribute hashref. + # + + if (ref $Method::Generate::Accessor::CurrentAttribute + and $self->{mgaca} || !exists $self->{mgaca}) + { + require B; + my %d = %{$Method::Generate::Accessor::CurrentAttribute}; + $self->{attribute_name} = $d{name} if defined $d{name}; + $self->{attribute_step} = $d{step} if defined $d{step}; + + if (defined $d{init_arg}) + { + $self->{varname} = sprintf('$args->{%s}', B::perlstring($d{init_arg})); + } + elsif (defined $d{name}) + { + $self->{varname} = sprintf('$self->{%s}', B::perlstring($d{name})); + } + } + + return $self; +} + +sub message +{ + my $e = shift; + $e->varname eq '$_' + ? $e->SUPER::message + : sprintf('%s (in %s)', $e->SUPER::message, $e->varname); +} + +sub _build_message +{ + my $e = shift; + $e->has_type + ? sprintf('%s did not pass type constraint "%s"', Type::Tiny::_dd($e->value), $e->type) + : sprintf('%s did not pass type constraint', Type::Tiny::_dd($e->value)) +} + +*to_string = sub +{ + my $e = shift; + my $msg = $e->message; + + my $c = $e->context; + $msg .= sprintf(" at %s line %s", $c->{file}||'file?', $c->{line}||'NaN') if $c; + + my $explain = $e->explain; + return "$msg\n" unless @{ $explain || [] }; + + $msg .= "\n"; + for my $line (@$explain) { + $msg .= " $line\n"; + } + + return $msg; +} if $] >= 5.008; + +sub explain +{ + my $e = shift; + return undef unless $e->has_type; + $e->type->validate_explain($e->value, $e->varname); +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Error::TypeTiny::Assertion - exception when a value fails a type constraint + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +This exception is thrown when a value fails a type constraint assertion. + +This package inherits from L; see that for most +documentation. Major differences are listed below: + +=head2 Attributes + +=over + +=item C + +The type constraint that was checked against. Weakened links are involved, +so this may end up being C. + +=item C + +The value that was tested. + +=item C + +The name of the variable that was checked, if known. Defaults to C<< '$_' >>. + +=item C + +If this exception was thrown as the result of an isa check or a failed +coercion for a Moo attribute, then this will tell you which attribute (if +your Moo is new enough). + +(Hopefully one day this will support other OO frameworks.) + +=item C + +If this exception was thrown as the result of an isa check or a failed +coercion for a Moo attribute, then this will contain either C<< "isa check" >> +or C<< "coercion" >> to indicate which went wrong (if your Moo is new enough). + +(Hopefully one day this will support other OO frameworks.) + +=back + +=head2 Methods + +=over + +=item C, C, C + +Predicate methods. + +=item C + +Overridden to add C to the message if defined. + +=item C + +Attempts to explain why the value did not pass the type constraint. Returns +an arrayref of strings providing step-by-step reasoning; or returns undef if +no explanation is possible. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Error/TypeTiny/Compilation.pm @@ -0,0 +1,96 @@ +package Error::TypeTiny::Compilation; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Error::TypeTiny::Compilation::AUTHORITY = 'cpan:TOBYINK'; + $Error::TypeTiny::Compilation::VERSION = '1.010000'; +} + +$Error::TypeTiny::Compilation::VERSION =~ tr/_//d; + +require Error::TypeTiny; +our @ISA = 'Error::TypeTiny'; + +sub code { $_[0]{code} }; +sub environment { $_[0]{environment} ||= {} }; +sub errstr { $_[0]{errstr} }; + +sub _build_message +{ + my $self = shift; + sprintf("Failed to compile source because: %s", $self->errstr); +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Error::TypeTiny::Compilation - exception for Eval::TypeTiny + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Thrown when compiling a closure fails. Common causes are problems with +inlined type constraints, and syntax errors when coercions are given as +strings of Perl code. + +This package inherits from L; see that for most +documentation. Major differences are listed below: + +=head2 Attributes + +=over + +=item C + +The Perl source code being compiled. + +=item C + +Hashref of variables being closed over. + +=item C + +Error message from Perl compiler. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Error/TypeTiny/WrongNumberOfParameters.pm @@ -0,0 +1,139 @@ +package Error::TypeTiny::WrongNumberOfParameters; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Error::TypeTiny::WrongNumberOfParameters::AUTHORITY = 'cpan:TOBYINK'; + $Error::TypeTiny::WrongNumberOfParameters::VERSION = '1.010000'; +} + +$Error::TypeTiny::WrongNumberOfParameters::VERSION =~ tr/_//d; + +require Error::TypeTiny; +our @ISA = 'Error::TypeTiny'; + +sub minimum { $_[0]{minimum} }; +sub maximum { $_[0]{maximum} }; +sub got { $_[0]{got} }; + +sub has_minimum { exists $_[0]{minimum} }; +sub has_maximum { exists $_[0]{maximum} }; + +sub _build_message +{ + my $e = shift; + if ($e->has_minimum and $e->has_maximum and $e->minimum == $e->maximum) + { + return sprintf( + "Wrong number of parameters; got %d; expected %d", + $e->got, + $e->minimum, + ); + } + elsif ($e->has_minimum and $e->has_maximum and $e->minimum < $e->maximum) + { + return sprintf( + "Wrong number of parameters; got %d; expected %d to %d", + $e->got, + $e->minimum, + $e->maximum, + ); + } + elsif ($e->has_minimum) + { + return sprintf( + "Wrong number of parameters; got %d; expected at least %d", + $e->got, + $e->minimum, + ); + } + else + { + return sprintf( + "Wrong number of parameters; got %d", + $e->got, + ); + } +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Error::TypeTiny::WrongNumberOfParameters - exception for Type::Params + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Thrown when a Type::Params compiled check is called with the wrong number +of parameters. + +This package inherits from L; see that for most +documentation. Major differences are listed below: + +=head2 Attributes + +=over + +=item C + +The minimum expected number of parameters. + +=item C + +The maximum expected number of parameters. + +=item C + +The number of parameters actually passed to the compiled check. + +=back + +=head2 Methods + +=over + +=item C, C + +Predicate methods. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Eval/TypeTiny.pm @@ -0,0 +1,418 @@ +package Eval::TypeTiny; + +use strict; + +sub _clean_eval { + local $@; + local $SIG{__DIE__}; + my $r = eval $_[0]; + my $e = $@; + return ($r, $e); +} + +use warnings; + +BEGIN { + *HAS_LEXICAL_SUBS = ($] >= 5.018) ? sub(){!!1} : sub(){!!0}; +}; + +{ + # this is unused now and will be removed in a future version of Eval::TypeTiny + my $hlv; + sub HAS_LEXICAL_VARS () { + $hlv = !! eval { + require Devel::LexAlias; + exists(&Devel::LexAlias::lexalias); + } unless defined $hlv; + $hlv; + } +} + +BEGIN { + sub IMPLEMENTATION_DEVEL_LEXALIAS () { 'Devel::LexAlias' } + sub IMPLEMENTATION_PADWALKER () { 'PadWalker' } + sub IMPLEMENTATION_TIE () { 'tie' } + sub IMPLEMENTATION_NATIVE () { 'perl' } + + my $implementation; + sub ALIAS_IMPLEMENTATION () { + $implementation ||= do { + do { $] ge '5.022' } ? IMPLEMENTATION_NATIVE : + eval { require Devel::LexAlias } ? IMPLEMENTATION_DEVEL_LEXALIAS : + eval { require PadWalker } ? IMPLEMENTATION_PADWALKER : IMPLEMENTATION_TIE + }; + } + + sub _force_implementation { + $implementation = shift; + } +} + +BEGIN { + *_EXTENDED_TESTING = ($ENV{EXTENDED_TESTING}) ? sub(){!!1} : sub(){!!0}; +}; + +our $AUTHORITY = 'cpan:TOBYINK'; +our $VERSION = '1.010000'; +our @EXPORT = qw( eval_closure ); +our @EXPORT_OK = qw( + HAS_LEXICAL_SUBS HAS_LEXICAL_VARS ALIAS_IMPLEMENTATION + IMPLEMENTATION_DEVEL_LEXALIAS IMPLEMENTATION_PADWALKER + IMPLEMENTATION_NATIVE IMPLEMENTATION_TIE +); + +$VERSION =~ tr/_//d; + +# See Types::TypeTiny for an explanation of this import method. +# +sub import { + # uncoverable subroutine + no warnings "redefine"; # uncoverable statement + our @ISA = qw( Exporter::Tiny ); # uncoverable statement + require Exporter::Tiny; # uncoverable statement + my $next = \&Exporter::Tiny::import; # uncoverable statement + *import = $next; # uncoverable statement + my $class = shift; # uncoverable statement + my $opts = { ref($_[0]) ? %{+shift} : () }; # uncoverable statement + $opts->{into} ||= scalar(caller); # uncoverable statement + return $class->$next($opts, @_); # uncoverable statement +} + +sub eval_closure { + my (%args) = @_; + my $src = ref $args{source} eq "ARRAY" ? join("\n", @{$args{source}}) : $args{source}; + + $args{alias} = 0 unless defined $args{alias}; + $args{line} = 1 unless defined $args{line}; + $args{description} =~ s/[^\w .:-\[\]\(\)\{\}\']//g if defined $args{description}; + $src = qq{#line $args{line} "$args{description}"\n$src} if defined $args{description} && !($^P & 0x10); + $args{environment} ||= {}; + + if (_EXTENDED_TESTING) { + require Scalar::Util; + for my $k (sort keys %{$args{environment}}) { + next if $k =~ /^\$/ && Scalar::Util::reftype($args{environment}{$k}) =~ /^(SCALAR|REF)$/; + next if $k =~ /^\@/ && Scalar::Util::reftype($args{environment}{$k}) eq q(ARRAY); + next if $k =~ /^\%/ && Scalar::Util::reftype($args{environment}{$k}) eq q(HASH); + next if $k =~ /^\&/ && Scalar::Util::reftype($args{environment}{$k}) eq q(CODE); + + require Error::TypeTiny; + Error::TypeTiny::croak("Expected a variable name and ref; got %s => %s", $k, $args{environment}{$k}); + } + } + + my $sandpkg = 'Eval::TypeTiny::Sandbox'; + my $alias = exists($args{alias}) ? $args{alias} : 0; + my @keys = sort keys %{$args{environment}}; + my $i = 0; + my $source = join "\n" => ( + "package $sandpkg;", + "sub {", + map(_make_lexical_assignment($_, $i++, $alias), @keys), + $src, + "}", + ); + + if ($alias and ALIAS_IMPLEMENTATION eq IMPLEMENTATION_TIE) { + _manufacture_ties(); + } + + my ($compiler, $e) = _clean_eval($source); + if ($e) { + chomp $e; + require Error::TypeTiny::Compilation; + "Error::TypeTiny::Compilation"->throw( + code => (ref $args{source} eq "ARRAY" ? join("\n", @{$args{source}}) : $args{source}), + errstr => $e, + environment => $args{environment}, + ); + } + + my $code = $compiler->(@{$args{environment}}{@keys}); + undef($compiler); + + if ($alias and ALIAS_IMPLEMENTATION eq IMPLEMENTATION_DEVEL_LEXALIAS) { + require Devel::LexAlias; + Devel::LexAlias::lexalias($code, $_ => $args{environment}{$_}) for grep !/^\&/, @keys; + } + + if ($alias and ALIAS_IMPLEMENTATION eq IMPLEMENTATION_PADWALKER) { + require PadWalker; + my %env = map +($_ => $args{environment}{$_}), grep !/^\&/, @keys; + PadWalker::set_closed_over($code, \%env); + } + + return $code; +} + +my $tmp; +sub _make_lexical_assignment { + my ($key, $index, $alias) = @_; + my $name = substr($key, 1); + + if (HAS_LEXICAL_SUBS and $key =~ /^\&/) { + $tmp++; + my $tmpname = '$__LEXICAL_SUB__'.$tmp; + return + "no warnings 'experimental::lexical_subs';". + "use feature 'lexical_subs';". + "my $tmpname = \$_[$index];". + "my sub $name { goto $tmpname };"; + } + + if (!$alias) { + my $sigil = substr($key, 0, 1); + return "my $key = $sigil\{ \$_[$index] };"; + } + elsif (ALIAS_IMPLEMENTATION eq IMPLEMENTATION_NATIVE) { + return + "no warnings 'experimental::refaliasing';". + "use feature 'refaliasing';". + "my $key; \\$key = \$_[$index];" + } + elsif (ALIAS_IMPLEMENTATION eq IMPLEMENTATION_DEVEL_LEXALIAS) { + return "my $key;"; + } + elsif (ALIAS_IMPLEMENTATION eq IMPLEMENTATION_PADWALKER) { + return "my $key;"; + } + else { + my $tieclass = { + '@' => 'Eval::TypeTiny::_TieArray', + '%' => 'Eval::TypeTiny::_TieHash', + '$' => 'Eval::TypeTiny::_TieScalar', + }->{ substr($key, 0, 1) }; + + return sprintf( + 'tie(my(%s), "%s", $_[%d]);', + $key, + $tieclass, + $index, + ); + } +} + +{ my $tie; sub _manufacture_ties { $tie ||= eval <<'FALLBACK'; } } +no warnings qw(void once uninitialized numeric); +use Type::Tiny (); + +{ + package # + Eval::TypeTiny::_TieArray; + require Tie::Array; + our @ISA = qw( Tie::StdArray ); + sub TIEARRAY { + my $class = shift; + bless $_[0] => $class; + } + sub AUTOLOAD { + my $self = shift; + my ($method) = (our $AUTOLOAD =~ /(\w+)$/); + defined tied(@$self) and return tied(@$self)->$method(@_); + require Carp; + Carp::croak(qq[Can't call method "$method" on an undefined value]) unless $method eq 'DESTROY'; + } + sub can { + my $self = shift; + my $code = $self->SUPER::can(@_) + || (defined tied(@$self) and tied(@$self)->can(@_)); + return $code; + } + __PACKAGE__->Type::Tiny::_install_overloads( + q[bool] => sub { !! tied @{$_[0]} }, + q[""] => sub { '' . tied @{$_[0]} }, + q[0+] => sub { 0 + tied @{$_[0]} }, + ); +} +{ + package # + Eval::TypeTiny::_TieHash; + require Tie::Hash; + our @ISA = qw( Tie::StdHash ); + sub TIEHASH { + my $class = shift; + bless $_[0] => $class; + } + sub AUTOLOAD { + my $self = shift; + my ($method) = (our $AUTOLOAD =~ /(\w+)$/); + defined tied(%$self) and return tied(%$self)->$method(@_); + require Carp; + Carp::croak(qq[Can't call method "$method" on an undefined value]) unless $method eq 'DESTROY'; + } + sub can { + my $self = shift; + my $code = $self->SUPER::can(@_) + || (defined tied(%$self) and tied(%$self)->can(@_)); + return $code; + } + __PACKAGE__->Type::Tiny::_install_overloads( + q[bool] => sub { !! tied %{$_[0]} }, + q[""] => sub { '' . tied %{$_[0]} }, + q[0+] => sub { 0 + tied %{$_[0]} }, + ); +} +{ + package # + Eval::TypeTiny::_TieScalar; + require Tie::Scalar; + our @ISA = qw( Tie::StdScalar ); + sub TIESCALAR { + my $class = shift; + bless $_[0] => $class; + } + sub AUTOLOAD { + my $self = shift; + my ($method) = (our $AUTOLOAD =~ /(\w+)$/); + defined tied($$self) and return tied($$self)->$method(@_); + require Carp; + Carp::croak(qq[Can't call method "$method" on an undefined value]) unless $method eq 'DESTROY'; + } + sub can { + my $self = shift; + my $code = $self->SUPER::can(@_) + || (defined tied($$self) and tied($$self)->can(@_)); + return $code; + } + __PACKAGE__->Type::Tiny::_install_overloads( + q[bool] => sub { !! tied ${$_[0]} }, + q[""] => sub { '' . tied ${$_[0]} }, + q[0+] => sub { 0 + tied ${$_[0]} }, + ); +} + +1; +FALLBACK + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords pragmas coderefs + +=head1 NAME + +Eval::TypeTiny - utility to evaluate a string of Perl code in a clean environment + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +This module is used by Type::Tiny to compile coderefs from strings of +Perl code, and hashrefs of variables to close over. + +=head2 Functions + +This module exports one function, which works much like the similarly named +function from L: + +=over + +=item C<< eval_closure(source => $source, environment => \%env, %opt) >> + +=back + +=head2 Constants + +The following constants may be exported, but are not by default. + +=over + +=item C<< HAS_LEXICAL_SUBS >> + +Boolean indicating whether Eval::TypeTiny has support for lexical subs. +(This feature requires Perl 5.18.) + +=item C<< ALIAS_IMPLEMENTATION >> + +Returns a string indicating what implementation of C<< alias => 1 >> is +being used. Eval::TypeTiny will automatically choose the best implementation. +This constant can be matched against the C<< IMPLEMENTAION_* >> constants. + +=item C<< IMPLEMENTATION_NATIVE >> + +If C<< ALIAS_IMPLEMENTATION eq IMPLEMENTATION_NATIVE >> then Eval::TypeTiny is +currently using Perl 5.22's native alias feature. This requires Perl 5.22. + +=item C<< IMPLEMENTATION_DEVEL_LEXALIAS >> + +If C<< ALIAS_IMPLEMENTATION eq IMPLEMENTATION_DEVEL_LEXALIAS >> then +Eval::TypeTiny is currently using L to provide aliases. + +=item C<< IMPLEMENTATION_PADWALKER >> + +If C<< ALIAS_IMPLEMENTATION eq IMPLEMENTATION_PADWALKER >> then +Eval::TypeTiny is currently using L to provide aliases. + +=item C<< IMPLEMENTATION_TIE >> + +If C<< ALIAS_IMPLEMENTATION eq IMPLEMENTATION_TIE >> then Eval::TypeTiny is +using the fallback implementation of aliases using C. This is the +slowest implementation, and may cause problems in certain edge cases, like +trying to alias already-tied variables, but it's the only way to implement +C<< alias => 1 >> without a recent version of Perl or one of the two optional +modules mentioned above. + +=back + +=head1 EVALUATION ENVIRONMENT + +The evaluation is performed in the presence of L, but the absence of +L. (This is different to L which enables warnings for +compiled closures.) + +The L pragma is not active in the evaluation environment, so the +following will not work: + + use feature qw(say); + use Eval::TypeTiny qw(eval_closure); + + my $say_all = eval_closure( + source => 'sub { say for @_ }', + ); + $say_all->("Hello", "World"); + +The L pragma does not "carry over" into the stringy eval. It is +of course possible to import pragmas into the evaluated string as part of the +string itself: + + use Eval::TypeTiny qw(eval_closure); + + my $say_all = eval_closure( + source => 'sub { use feature qw(say); say for @_ }', + ); + $say_all->("Hello", "World"); + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L, L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Exporter/Shiny.pm @@ -0,0 +1,116 @@ +package Exporter::Shiny; + +use 5.006001; +use strict; +use warnings; + +use Exporter::Tiny (); + +our $AUTHORITY = 'cpan:TOBYINK'; +our $VERSION = '1.002001'; + +sub import { + my $me = shift; + my $caller = caller; + + (my $nominal_file = $caller) =~ s(::)(/)g; + $INC{"$nominal_file\.pm"} ||= __FILE__; + + if (@_ == 2 and $_[0] eq -setup) + { + my (undef, $opts) = @_; + @_ = @{ delete($opts->{exports}) || [] }; + + if (%$opts) { + Exporter::Tiny::_croak( + 'Unsupported Sub::Exporter-style options: %s', + join(q[, ], sort keys %$opts), + ); + } + } + + ref($_) && Exporter::Tiny::_croak('Expected sub name, got ref %s', $_) for @_; + + no strict qw(refs); + push @{"$caller\::ISA"}, 'Exporter::Tiny'; + push @{"$caller\::EXPORT_OK"}, @_; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Exporter::Shiny - shortcut for Exporter::Tiny + +=head1 SYNOPSIS + + use Exporter::Shiny qw( foo bar ); + +Is a shortcut for: + + use base "Exporter::Tiny"; + push our(@EXPORT_OK), qw( foo bar ); + +For compatibility with L, the following longer syntax is +also supported: + + use Exporter::Shiny -setup => { + exports => [qw( foo bar )], + }; + +=head1 DESCRIPTION + +This is a very small wrapper to simplify using L. + +It does the following: + +=over + +=item * Marks your package as loaded in C<< %INC >>; + +=item * Pushes any function names in the import list onto your C<< @EXPORT_OK >>; and + +=item * Pushes C<< "Exporter::Tiny" >> onto your C<< @ISA >>. + +=back + +It doesn't set up C<< %EXPORT_TAGS >> or C<< @EXPORT >>, but there's +nothing stopping you doing that yourself. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +This module is just a wrapper around L, so take a look +at L and +L for further information on what +features are available. + +Other interesting exporters: L, L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2014, 2017 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. + --- /dev/null +++ b/Kernel/cpan-lib/Exporter/Tiny.pm @@ -0,0 +1,508 @@ +package Exporter::Tiny; + +use 5.006001; +use strict; +use warnings; no warnings qw(void once uninitialized numeric redefine); + +our $AUTHORITY = 'cpan:TOBYINK'; +our $VERSION = '1.002001'; +our @EXPORT_OK = qw< mkopt mkopt_hash _croak _carp >; + +sub _croak ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::croak } +sub _carp ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::carp } + +my $_process_optlist = sub +{ + my $class = shift; + my ($global_opts, $opts, $want, $not_want) = @_; + + while (@$opts) + { + my $opt = shift @{$opts}; + my ($name, $value) = @$opt; + + ($name =~ m{\A\!(/.+/[msixpodual]+)\z}) ? + do { + my @not = $class->_exporter_expand_regexp($1, $value, $global_opts); + ++$not_want->{$_->[0]} for @not; + } : + ($name =~ m{\A\!(.+)\z}) ? + (++$not_want->{$1}) : + ($name =~ m{\A[:-](.+)\z}) ? + push(@$opts, $class->_exporter_expand_tag($1, $value, $global_opts)) : + ($name =~ m{\A/.+/[msixpodual]+\z}) ? + push(@$opts, $class->_exporter_expand_regexp($name, $value, $global_opts)) : + # else ? + push(@$want, $opt); + } +}; + +sub import +{ + my $class = shift; + my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () }; + $global_opts->{into} = caller unless exists $global_opts->{into}; + + my @want; + my %not_want; $global_opts->{not} = \%not_want; + my @args = do { no strict qw(refs); @_ ? @_ : @{"$class\::EXPORT"} }; + my $opts = mkopt(\@args); + $class->$_process_optlist($global_opts, $opts, \@want, \%not_want); + + my $permitted = $class->_exporter_permitted_regexp($global_opts); + $class->_exporter_validate_opts($global_opts); + + for my $wanted (@want) + { + next if $not_want{$wanted->[0]}; + + my %symbols = $class->_exporter_expand_sub(@$wanted, $global_opts, $permitted); + $class->_exporter_install_sub($_, $wanted->[1], $global_opts, $symbols{$_}) + for keys %symbols; + } +} + +sub unimport +{ + my $class = shift; + my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () }; + $global_opts->{into} = caller unless exists $global_opts->{into}; + $global_opts->{is_unimport} = 1; + + my @want; + my %not_want; $global_opts->{not} = \%not_want; + my @args = do { our %TRACKED; @_ ? @_ : keys(%{$TRACKED{$class}{$global_opts->{into}}}) }; + my $opts = mkopt(\@args); + $class->$_process_optlist($global_opts, $opts, \@want, \%not_want); + + my $permitted = $class->_exporter_permitted_regexp($global_opts); + $class->_exporter_validate_unimport_opts($global_opts); + + my $expando = $class->can('_exporter_expand_sub'); + $expando = undef if $expando == \&_exporter_expand_sub; + + for my $wanted (@want) + { + next if $not_want{$wanted->[0]}; + + if ($wanted->[1]) + { + _carp("Passing options to unimport '%s' makes no sense", $wanted->[0]) + unless (ref($wanted->[1]) eq 'HASH' and not keys %{$wanted->[1]}); + } + + my %symbols = defined($expando) + ? $class->$expando(@$wanted, $global_opts, $permitted) + : ($wanted->[0] => sub { "dummy" }); + $class->_exporter_uninstall_sub($_, $wanted->[1], $global_opts) + for keys %symbols; + } +} + +# Called once per import/unimport, passed the "global" import options. +# Expected to validate the options and carp or croak if there are problems. +# Can also take the opportunity to do other stuff if needed. +# +sub _exporter_validate_opts { 1 } +sub _exporter_validate_unimport_opts { 1 } + +# Called after expanding a tag or regexp to merge the tag's options with +# any sub-specific options. +# +sub _exporter_merge_opts +{ + my $class = shift; + my ($tag_opts, $global_opts, @stuff) = @_; + + $tag_opts = {} unless ref($tag_opts) eq q(HASH); + _croak('Cannot provide an -as option for tags') + if exists $tag_opts->{-as} && ref $tag_opts->{-as} ne 'CODE'; + + my $optlist = mkopt(\@stuff); + for my $export (@$optlist) + { + next if defined($export->[1]) && ref($export->[1]) ne q(HASH); + + my %sub_opts = ( %{ $export->[1] or {} }, %$tag_opts ); + $sub_opts{-prefix} = sprintf('%s%s', $tag_opts->{-prefix}, $export->[1]{-prefix}) + if exists($export->[1]{-prefix}) && exists($tag_opts->{-prefix}); + $sub_opts{-suffix} = sprintf('%s%s', $export->[1]{-suffix}, $tag_opts->{-suffix}) + if exists($export->[1]{-suffix}) && exists($tag_opts->{-suffix}); + $export->[1] = \%sub_opts; + } + return @$optlist; +} + +# Given a tag name, looks it up in %EXPORT_TAGS and returns the list of +# associated functions. The default implementation magically handles tags +# "all" and "default". The default implementation interprets any undefined +# tags as being global options. +# +sub _exporter_expand_tag +{ + no strict qw(refs); + + my $class = shift; + my ($name, $value, $globals) = @_; + my $tags = \%{"$class\::EXPORT_TAGS"}; + + return $class->_exporter_merge_opts($value, $globals, $tags->{$name}->($class, @_)) + if ref($tags->{$name}) eq q(CODE); + + return $class->_exporter_merge_opts($value, $globals, @{$tags->{$name}}) + if exists $tags->{$name}; + + return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"}) + if $name eq 'all'; + + return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"}) + if $name eq 'default'; + + $globals->{$name} = $value || 1; + return; +} + +# Given a regexp-like string, looks it up in @EXPORT_OK and returns the +# list of matching functions. +# +sub _exporter_expand_regexp +{ + no strict qw(refs); + our %TRACKED; + + my $class = shift; + my ($name, $value, $globals) = @_; + my $compiled = eval("qr$name"); + + my @possible = $globals->{is_unimport} + ? keys( %{$TRACKED{$class}{$globals->{into}}} ) + : @{"$class\::EXPORT_OK"}; + + $class->_exporter_merge_opts($value, $globals, grep /$compiled/, @possible); +} + +# Helper for _exporter_expand_sub. Returns a regexp matching all subs in +# the exporter package which are available for export. +# +sub _exporter_permitted_regexp +{ + no strict qw(refs); + my $class = shift; + my $re = join "|", map quotemeta, sort { + length($b) <=> length($a) or $a cmp $b + } @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"}; + qr{^(?:$re)$}ms; +} + +# Given a sub name, returns a hash of subs to install (usually just one sub). +# Keys are sub names, values are coderefs. +# +sub _exporter_expand_sub +{ + my $class = shift; + my ($name, $value, $globals, $permitted) = @_; + $permitted ||= $class->_exporter_permitted_regexp($globals); + + no strict qw(refs); + + my $sigil = "&"; + if ($name =~ /\A([&\$\%\@\*])(.+)\z/) { + $sigil = $1; + $name = $2; + if ($sigil eq '*') { + _croak("Cannot export symbols with a * sigil"); + } + } + my $sigilname = $sigil eq '&' ? $name : "$sigil$name"; + + if ($sigilname =~ $permitted) + { + my $generatorprefix = { + '&' => "_generate_", + '$' => "_generateScalar_", + '@' => "_generateArray_", + '%' => "_generateHash_", + }->{$sigil}; + + my $generator = $class->can("$generatorprefix$name"); + return $sigilname => $class->$generator($sigilname, $value, $globals) if $generator; + + my $sub = $class->can($name); + return $sigilname => $sub if $sub; + + # Could do this more cleverly, but this works. + if ($sigil ne '&') { + my $evalled = eval "\\${sigil}${class}::${name}"; + return $sigilname => $evalled if $evalled; + } + } + + $class->_exporter_fail(@_); +} + +# Called by _exporter_expand_sub if it is unable to generate a key-value +# pair for a sub. +# +sub _exporter_fail +{ + my $class = shift; + my ($name, $value, $globals) = @_; + return if $globals->{is_unimport}; + _croak("Could not find sub '%s' exported by %s", $name, $class); +} + +# Actually performs the installation of the sub into the target package. This +# also handles renaming the sub. +# +sub _exporter_install_sub +{ + my $class = shift; + my ($name, $value, $globals, $sym) = @_; + + my $into = $globals->{into}; + my $installer = $globals->{installer} || $globals->{exporter}; + + $name = + ref $globals->{as} ? $globals->{as}->($name) : + ref $value->{-as} ? $value->{-as}->($name) : + exists $value->{-as} ? $value->{-as} : + $name; + + return unless defined $name; + + my $sigil = "&"; + unless (ref($name)) { + if ($name =~ /\A([&\$\%\@\*])(.+)\z/) { + $sigil = $1; + $name = $2; + if ($sigil eq '*') { + _croak("Cannot export symbols with a * sigil"); + } + } + my ($prefix) = grep defined, $value->{-prefix}, $globals->{prefix}, q(); + my ($suffix) = grep defined, $value->{-suffix}, $globals->{suffix}, q(); + $name = "$prefix$name$suffix"; + } + + my $sigilname = $sigil eq '&' ? $name : "$sigil$name"; + +# if ({qw/$ SCALAR @ ARRAY % HASH & CODE/}->{$sigil} ne ref($sym)) { +# warn $sym; +# warn $sigilname; +# _croak("Reference type %s does not match sigil %s", ref($sym), $sigil); +# } + + return ($$name = $sym) if ref($name) eq q(SCALAR); + return ($into->{$sigilname} = $sym) if ref($into) eq q(HASH); + + no strict qw(refs); + our %TRACKED; + + if (ref($sym) eq 'CODE' and exists &{"$into\::$name"} and \&{"$into\::$name"} != $sym) + { + my ($level) = grep defined, $value->{-replace}, $globals->{replace}, q(0); + my $action = { + carp => \&_carp, + 0 => \&_carp, + '' => \&_carp, + warn => \&_carp, + nonfatal => \&_carp, + croak => \&_croak, + fatal => \&_croak, + die => \&_croak, + }->{$level} || sub {}; + + # Don't complain about double-installing the same sub. This isn't ideal + # because the same named sub might be generated in two different ways. + $action = sub {} if $TRACKED{$class}{$into}{$sigilname}; + + $action->( + $action == \&_croak + ? "Refusing to overwrite existing sub '%s::%s' with sub '%s' exported by %s" + : "Overwriting existing sub '%s::%s' with sub '%s' exported by %s", + $into, + $name, + $_[0], + $class, + ); + } + + $TRACKED{$class}{$into}{$sigilname} = $sym; + + no warnings qw(prototype); + $installer + ? $installer->($globals, [$sigilname, $sym]) + : (*{"$into\::$name"} = $sym); +} + +sub _exporter_uninstall_sub +{ + our %TRACKED; + my $class = shift; + my ($name, $value, $globals, $sym) = @_; + my $into = $globals->{into}; + ref $into and return; + + no strict qw(refs); + + my $sigil = "&"; + if ($name =~ /\A([&\$\%\@\*])(.+)\z/) { + $sigil = $1; + $name = $2; + if ($sigil eq '*') { + _croak("Cannot export symbols with a * sigil"); + } + } + my $sigilname = $sigil eq '&' ? $name : "$sigil$name"; + + if ($sigil ne '&') { + _croak("Unimporting non-code symbols not supported yet"); + } + + # Cowardly refuse to uninstall a sub that differs from the one + # we installed! + my $our_coderef = $TRACKED{$class}{$into}{$name}; + my $cur_coderef = exists(&{"$into\::$name"}) ? \&{"$into\::$name"} : -1; + return unless $our_coderef == $cur_coderef; + + my $stash = \%{"$into\::"}; + my $old = delete $stash->{$name}; + my $full_name = join('::', $into, $name); + foreach my $type (qw(SCALAR HASH ARRAY IO)) # everything but the CODE + { + next unless defined(*{$old}{$type}); + *$full_name = *{$old}{$type}; + } + + delete $TRACKED{$class}{$into}{$name}; +} + +sub mkopt +{ + my $in = shift or return []; + my @out; + + $in = [map(($_ => ref($in->{$_}) ? $in->{$_} : ()), sort keys %$in)] + if ref($in) eq q(HASH); + + for (my $i = 0; $i < @$in; $i++) + { + my $k = $in->[$i]; + my $v; + + ($i == $#$in) ? ($v = undef) : + !defined($in->[$i+1]) ? (++$i, ($v = undef)) : + !ref($in->[$i+1]) ? ($v = undef) : + ($v = $in->[++$i]); + + push @out, [ $k => $v ]; + } + + \@out; +} + +sub mkopt_hash +{ + my $in = shift or return; + my %out = map +($_->[0] => $_->[1]), @{ mkopt($in) }; + \%out; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords frobnicate greps regexps + +=head1 NAME + +Exporter::Tiny - an exporter with the features of Sub::Exporter but only core dependencies + +=head1 SYNOPSIS + + package MyUtils; + use base "Exporter::Tiny"; + our @EXPORT = qw(frobnicate); + sub frobnicate { ... } + 1; + + package MyScript; + use MyUtils "frobnicate" => { -as => "frob" }; + print frob(42); + exit; + +=head1 DESCRIPTION + +Exporter::Tiny supports many of Sub::Exporter's external-facing features +including renaming imported functions with the C<< -as >>, C<< -prefix >> and +C<< -suffix >> options; explicit destinations with the C<< into >> option; +and alternative installers with the C<< installer >> option. But it's written +in only about 40% as many lines of code and with zero non-core dependencies. + +Its internal-facing interface is closer to Exporter.pm, with configuration +done through the C<< @EXPORT >>, C<< @EXPORT_OK >> and C<< %EXPORT_TAGS >> +package variables. + +If you are trying to B a module that inherits from Exporter::Tiny, +then look at: + +=over + +=item * + +L + +=item * + +L + +=back + +If you are trying to B a module that inherits from Exporter::Tiny, +then look at: + +=over + +=item * + +L + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SUPPORT + +B<< IRC: >> support is available through in the I<< #moops >> channel +on L. + +=head1 SEE ALSO + +Simplified interface to this module: L. + +Other interesting exporters: L, L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017 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. + --- /dev/null +++ b/Kernel/cpan-lib/Math/Random/ISAAC.pm @@ -0,0 +1,322 @@ +package Math::Random::ISAAC; +BEGIN { + $Math::Random::ISAAC::VERSION = '1.004'; +} +# ABSTRACT: Perl interface to the ISAAC PRNG algorithm + +use strict; +use warnings; +use Carp (); + +our $DRIVER = 'PP'; + +# Try to load the XS version first +eval { + require Math::Random::ISAAC::XS; + $DRIVER = 'XS'; +}; + +# Fall back on the Perl version +if ($@) { + require Math::Random::ISAAC::PP; +} + + +# Wrappers around the actual methods +sub new { + my ($class, @seed) = @_; + + Carp::croak('You must call this as a class method') if ref($class); + + my $self = { + }; + + if ($DRIVER eq 'XS') { + $self->{backend} = Math::Random::ISAAC::XS->new(@seed); + } + else { + $self->{backend} = Math::Random::ISAAC::PP->new(@seed); + } + + bless($self, $class); + return $self; +} + + +# This package should have an interface similar to the builtin Perl +# random number routines; these are methods, not functions, so they +# are not problematic +## no critic (ProhibitBuiltinHomonyms) + +sub rand { + my ($self) = @_; + + Carp::croak('You must call this method as an object') unless ref($self); + + return $self->{backend}->rand(); +} + + +sub irand { + my ($self) = @_; + + Carp::croak('You must call this method as an object') unless ref($self); + + return $self->{backend}->irand(); +} + + +1; + +__END__ +=pod + +=head1 NAME + +Math::Random::ISAAC - Perl interface to the ISAAC PRNG algorithm + +=head1 VERSION + +version 1.004 + +=head1 SYNOPSIS + + use Math::Random::ISAAC; + + my $rng = Math::Random::ISAAC->new(@seeds); + + for (0..30) { + print 'Result: ' . $rng->irand() . "\n"; + } + +=head1 DESCRIPTION + +As with other Pseudo-Random Number Generator (PRNG) algorithms like the +Mersenne Twister (see L), this algorithm is designed to +take some seed information and produce seemingly random results as output. + +However, ISAAC (Indirection, Shift, Accumulate, Add, and Count) has different +goals than these commonly used algorithms. In particular, it's really fast - +on average, it requires only 18.75 machine cycles to generate a 32-bit value. +This makes it suitable for applications where a significant amount of random +data needs to be produced quickly, such solving using the Monte Carlo method +or for games. + +The results are uniformly distributed, unbiased, and unpredictable unless +you know the seed. The algorithm was published by Bob Jenkins in the late +90s and despite the best efforts of many security researchers, no feasible +attacks have been found to date. + +=head2 USAGE WARNING + +There was no method supplied to provide the initial seed data by the author. +On his web site, Bob Jenkins writes: + + Seeding a random number generator is essentially the same problem as + encrypting the seed with a block cipher. + +In the same spirit, by default, this module does not seed the algorithm at +all -- it simply fills the state with zeroes -- if no seed is provided. +The idea is to remind users that selecting good seed data for their purpose +is important, and for the module to conveniently set it to something like +C behind-the-scenes hurts users in the long run, since they don't +understand the limitations of doing so. + +The type of seed you might want to use depends entirely on the purpose of +using this algorithm in your program in the first place. Here are some +possible seeding methods: + +=over + +=item 1 Math::TrulyRandom + +The L module provides a way of obtaining truly random +data by using timing interrupts. This is probably one of the better ways +to seed the algorithm. + +=item 2 /dev/random + +Using the system random device is, in principle, the best idea, since it +gathers entropy from various sources including interrupt timing, other +device interrupts, etc. However, it's not portable to anything other than +Unix-like platforms, and might not produce good data on some systems. + +=item 3 localtime() + +This works for basic things like simulations, but results in not-so-random +output, especially if you create new instances quickly (as the seeds would +be the same within per-second resolution). + +=item 4 Time::HiRes + +In theory, using L is the same as option (2), but you get a +higher resolution time so you're less likely to have the same seed twice. +Note that you need to transform the output into an integer somehow, perhaps +by taking the least significant bits or using a hash function. This would +be less prone to duplicate instances, but it's still not ideal. + +=back + +=head1 METHODS + +=head2 new + + Math::Random::ISAAC->new( @seeds ) + +Creates a C object, based upon either the optimized +C/XS version of the algorithm, L, or falls back +to the included Pure Perl module, L. + +Example code: + + my $rng = Math::Random::ISAAC->new(time); + +This method will return an appropriate B object or +throw an exception on error. + +=head2 rand + + $rng->rand() + +Returns a random double-precision floating point number which is normalized +between 0 and 1 (inclusive; it's a closed interval). + +Internally, this simply takes the uniformly distributed unsigned integer from +C<$rng-Eirand()> and divides it by C<2**32-1> (maximum unsigned integer +size) + +Example code: + + my $next = $rng->rand(); + +This method will return a double-precision floating point number or throw an +exception on error. + +=head2 irand + + $rng->irand() + +Returns the next unsigned 32-bit random integer. It will return a value with +a value such that: B<0 E= x E= 2**32-1>. + +Example code: + + my $next = $rng->irand(); + +This method will return a 32-bit unsigned integer or throw an exception on +error. + +=head1 PURPOSE + +The intent of this module is to provide single simple interface to the two +compatible implementations of this module, namely, L +and L. + +If, for some reason, you need to determine what version of the module is +actually being included by C, then: + + print 'Backend type: ', $Math::Random::ISAAC::DRIVER, "\n"; + +In order to force use of one or the other, simply load the appropriate module: + + use Math::Random::ISAAC::XS; + my $rng = Math::Random::ISAAC::XS->new(); + # or + use Math::Random::ISAAC::PP; + my $rng = Math::Random::ISAAC::PP->new(); + +=head1 ACKNOWLEDGEMENTS + +=over + +=item * + +Special thanks to Bob Jenkins Ebob_jenkins@burtleburtle.netE for +devising this very clever algorithm and releasing it into the public domain. + +=item * + +Thanks to John L. Allen (contact unknown) for providing a Perl port of the +original ISAAC code, upon which C is heavily based. +His version is available on Bob's web site, in the SEE ALSO section. + +=back + +=head1 SEE ALSO + +L, the C/XS optimized version of this module, which +will be used automatically if available. + +L, Bob Jenkins' page about +ISAAC, which explains the algorithm as well as potential attacks. + +L, a paper entitled "On the pseudo-random +generator ISAAC," which claims there are many seeds which will produce +non-uniform results. The author, Jean-Philippe Aumasson, argues ISAAC should +be using rotations (circular shifts) instead of normal shifts to increase +diffusion of the state, among other things. + +L, a paper by Marina Pudovkina discussing +plaintext attacks on the ISAAC keystream generator. Among other things, it +notes that the time complexity is B, so it remains a +secure cipher for practical applications. + +=head1 CAVEATS + +=over + +=item * + +There is no method that allows re-seeding of algorithms. This is not really +necessary because one can simply call C again with the new seed data +periodically. + +But he also provides a simple workaround: + + As ISAAC is intended to be a secure cipher, if you want to reseed it, + one way is to use some other cipher to seed some initial version of ISAAC, + then use ISAAC's output as a seed for other instances of ISAAC whenever + they need to be reseeded. + +=item * + +There is no way to clone a PRNG instance. I'm not sure why this is might +even be necessary or useful. File a bug report with an explanation why and +I'll consider adding it to the next release. + +=back + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +http://rt.cpan.org/NoAuth/Bugs.html?Dist=Math-Random-ISAAC + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Jonathan Yu + +=head1 COPYRIGHT AND LICENSE + +Legally speaking, this package and its contents are: + + Copyright (c) 2011 by Jonathan Yu . + +But this is really just a legal technicality that allows the author to +offer this package under the public domain and also a variety of licensing +options. For all intents and purposes, this is public domain software, +which means you can do whatever you want with it. + +The software is provided "AS IS", without warranty of any kind, express or +implied, including but not limited to the warranties of merchantability, +fitness for a particular purpose and noninfringement. In no event shall the +authors or copyright holders be liable for any claim, damages or other +liability, whether in an action of contract, tort or otherwise, arising from, +out of or in connection with the software or the use or other dealings in +the software. + +=cut + --- /dev/null +++ b/Kernel/cpan-lib/Math/Random/ISAAC/PP.pm @@ -0,0 +1,396 @@ +package Math::Random::ISAAC::PP; +BEGIN { + $Math::Random::ISAAC::PP::VERSION = '1.004'; +} +# ABSTRACT: Pure Perl port of the ISAAC PRNG algorithm + +use strict; +use warnings; +use Carp (); + + +sub new { + my ($class, @seed) = @_; + + my $seedsize = scalar(@seed); + + my @mm; + $#mm = $#seed = 255; # predeclare arrays with 256 slots + + # Zero-fill our seed data + for ($seedsize .. 255) { + $seed[$_] = 0; + } + + my $self = { + randrsl => \@seed, + randcnt => 0, + randmem => \@mm, + + randa => 0, + randb => 0, + randc => 0, + }; + + bless($self, $class); + + $self->_randinit(); + + return $self; +} + + +# This package should have an interface similar to the builtin Perl +# random number routines; these are methods, not functions, so they +# are not problematic +## no critic (ProhibitBuiltinHomonyms) + +sub rand { + my ($self) = @_; + + return ($self->irand() / (2**32-1)); +} + + +sub irand { + my ($self) = @_; + + # Reset the sequence if we run out of random stuff + if (!$self->{randcnt}--) + { + # Call method like this because of our hack above + _isaac($self); + $self->{randcnt} = 255; + } + + return sprintf('%u', $self->{randrsl}->[$self->{randcnt}]); +} + +# C-style for loops are used a lot since this is a port of the C version +## no critic (ProhibitCStyleForLoops) + +# Numbers are specified in hex, so they don't need separators +## no critic (RequireNumberSeparators) + +sub _isaac { + my ($self) = @_; + + # Use integer math + use integer; + + my $mm = $self->{randmem}; + my $r = $self->{randrsl}; + + # $a and $b are reserved (see 'sort') + my $aa = $self->{randa}; + my $bb = ($self->{randb} + (++$self->{randc})) & 0xffffffff; + + my ($x, $y); # temporary storage + + # The C code deals with two halves of the randmem separately; we deal with + # it here in one loop, by adding the &0xff parts. These calls represent the + # rngstep() macro, but it's inlined here for speed. + for (my $i = 0; $i < 256; $i += 4) + { + $x = $mm->[$i ]; + $aa = (($aa ^ ($aa << 13)) + $mm->[($i + 128) & 0xff]); + $aa &= 0xffffffff; # Mask out high bits for 64-bit systems + $mm->[$i ] = $y = ($mm->[($x >> 2) & 0xff] + $aa + $bb) & 0xffffffff; + $r->[$i ] = $bb = ($mm->[($y >> 10) & 0xff] + $x) & 0xffffffff; + + # I don't actually know why the "0x03ffffff" stuff is for. It was in + # John L. Allen's code. If you can explain this please file a bug report. + $x = $mm->[$i+1]; + $aa = (($aa ^ (0x03ffffff & ($aa >> 6))) + $mm->[($i+1+128) & 0xff]); + $aa &= 0xffffffff; + $mm->[$i+1] = $y = ($mm->[($x >> 2) & 0xff] + $aa + $bb) & 0xffffffff; + $r->[$i+1] = $bb = ($mm->[($y >> 10) & 0xff] + $x) & 0xffffffff; + + $x = $mm->[$i+2]; + $aa = (($aa ^ ($aa << 2)) + $mm->[($i+2 + 128) & 0xff]); + $aa &= 0xffffffff; + $mm->[$i+2] = $y = ($mm->[($x >> 2) & 0xff] + $aa + $bb) & 0xffffffff; + $r->[$i+2] = $bb = ($mm->[($y >> 10) & 0xff] + $x) & 0xffffffff; + + $x = $mm->[$i+3]; + $aa = (($aa ^ (0x0000ffff & ($aa >> 16))) + $mm->[($i+3 + 128) & 0xff]); + $aa &= 0xffffffff; + $mm->[$i+3] = $y = ($mm->[($x >> 2) & 0xff] + $aa + $bb) & 0xffffffff; + $r->[$i+3] = $bb = ($mm->[($y >> 10) & 0xff] + $x) & 0xffffffff; + } + + $self->{randb} = $bb; + $self->{randa} = $aa; + + return; +} + +sub _randinit +{ + my ($self) = @_; + + use integer; + + # $a and $b are reserved (see 'sort'); $i is the iterator + my ($c, $d, $e, $f, $g, $h, $j, $k); + $c=$d=$e=$f=$g=$h=$j=$k = 0x9e3779b9; # The golden ratio + + my $mm = $self->{randmem}; + my $r = $self->{randrsl}; + + for (1..4) + { + $c ^= $d << 11; + $f += $c; + $d += $e; + + $d ^= 0x3fffffff & ($e >> 2); + $g += $d; + $e += $f; + + $e ^= $f << 8; + $h += $e; + $f += $g; + + $f ^= 0x0000ffff & ($g >> 16); + $j += $f; + $g += $h; + + $g ^= $h << 10; + $k += $g; + $h += $j; + + $h ^= 0x0fffffff & ($j >> 4); + $c += $h; + $j += $k; + + $j ^= $k << 8; + $d += $j; + $k += $c; + + $k ^= 0x007fffff & ($c >> 9); + $e += $k; + $c += $d; + } + + for (my $i = 0; $i < 256; $i += 8) + { + $c += $r->[$i ]; + $d += $r->[$i+1]; + $e += $r->[$i+2]; + $f += $r->[$i+3]; + $g += $r->[$i+4]; + $h += $r->[$i+5]; + $j += $r->[$i+6]; + $k += $r->[$i+7]; + + $c ^= $d << 11; + $f += $c; + $d += $e; + + $d ^= 0x3fffffff & ($e >> 2); + $g += $d; + $e += $f; + + $e ^= $f << 8; + $h += $e; + $f += $g; + + $f ^= 0x0000ffff & ($g >> 16); + $j += $f; + $g += $h; + + $g ^= $h << 10; + $k += $g; + $h += $j; + + $h ^= 0x0fffffff & ($j >> 4); + $c += $h; + $j += $k; + + $j ^= $k << 8; + $d += $j; + $k += $c; + + $k ^= 0x007fffff & ($c >> 9); + $e += $k; + $c += $d; + + $mm->[$i ] = $c; + $mm->[$i+1] = $d; + $mm->[$i+2] = $e; + $mm->[$i+3] = $f; + $mm->[$i+4] = $g; + $mm->[$i+5] = $h; + $mm->[$i+6] = $j; + $mm->[$i+7] = $k; + } + + for (my $i = 0; $i < 256; $i += 8) + { + $c += $mm->[$i ]; + $d += $mm->[$i+1]; + $e += $mm->[$i+2]; + $f += $mm->[$i+3]; + $g += $mm->[$i+4]; + $h += $mm->[$i+5]; + $j += $mm->[$i+6]; + $k += $mm->[$i+7]; + + $c ^= $d << 11; + $f += $c; + $d += $e; + + $d ^= 0x3fffffff & ($e >> 2); + $g += $d; + $e += $f; + + $e ^= $f << 8; + $h += $e; + $f += $g; + + $f ^= 0x0000ffff & ($g >> 16); + $j += $f; + $g += $h; + + $g ^= $h << 10; + $k += $g; + $h += $j; + + $h ^= 0x0fffffff & ($j >> 4); + $c += $h; + $j += $k; + + $j ^= $k << 8; + $d += $j; + $k += $c; + + $k ^= 0x007fffff & ($c >> 9); + $e += $k; + $c += $d; + + $mm->[$i ] = $c; + $mm->[$i+1] = $d; + $mm->[$i+2] = $e; + $mm->[$i+3] = $f; + $mm->[$i+4] = $g; + $mm->[$i+5] = $h; + $mm->[$i+6] = $j; + $mm->[$i+7] = $k; + } + + $self->_isaac(); + $self->{randcnt} = 256; + + return; +} + + +1; + +__END__ +=pod + +=head1 NAME + +Math::Random::ISAAC::PP - Pure Perl port of the ISAAC PRNG algorithm + +=head1 VERSION + +version 1.004 + +=head1 SYNOPSIS + +This module implements the same interface as C and can be +used as a drop-in replacement. However, it is recommended that you let the +C module decide whether to use the PurePerl or XS version +of this module, instead of choosing manually. + +Selecting the backend to use manually really only has two uses: + +=over + +=item * + +If you are trying to avoid the small overhead incurred with dispatching method +calls to the appropriate backend modules. + +=item * + +If you are testing the module for performance and wish to explicitly decide +which module you would like to use. + +=back + +Example code: + + # With Math::Random::ISAAC + my $rng = Math::Random::ISAAC->new(time); + my $rand = $rng->rand(); + + # With Math::Random::ISAAC::PP + my $rng = Math::Random::ISAAC::PP->new(time); + my $rand = $rng->rand(); + +=head1 DESCRIPTION + +See L for the full description. + +=head1 METHODS + +=head2 new + + Math::Random::ISAAC::PP->new( @seeds ) + +Implements the interface as specified in C + +=head2 rand + + $rng->rand() + +Implements the interface as specified in C + +=head2 irand + + $rng->irand() + +Implements the interface as specified in C + +=head1 SEE ALSO + +L + +=head1 BUGS + +Please report any bugs or feature requests on the bugtracker website +http://rt.cpan.org/NoAuth/Bugs.html?Dist=Math-Random-ISAAC + +When submitting a bug or request, please include a test-file or a +patch to an existing test-file that illustrates the bug or desired +feature. + +=head1 AUTHOR + +Jonathan Yu + +=head1 COPYRIGHT AND LICENSE + +Legally speaking, this package and its contents are: + + Copyright (c) 2011 by Jonathan Yu . + +But this is really just a legal technicality that allows the author to +offer this package under the public domain and also a variety of licensing +options. For all intents and purposes, this is public domain software, +which means you can do whatever you want with it. + +The software is provided "AS IS", without warranty of any kind, express or +implied, including but not limited to the warranties of merchantability, +fitness for a particular purpose and noninfringement. In no event shall the +authors or copyright holders be liable for any claim, damages or other +liability, whether in an action of contract, tort or otherwise, arising from, +out of or in connection with the software or the use or other dealings in +the software. + +=cut + --- /dev/null +++ b/Kernel/cpan-lib/Math/Random/Secure.pm @@ -0,0 +1,306 @@ +package Math::Random::Secure; +$Math::Random::Secure::VERSION = '0.080001'; +# ABSTRACT: Cryptographically-secure, cross-platform replacement for rand() + +use strict; +use 5.008; +use base qw(Exporter); +use Math::Random::Secure::RNG; + +# ISAAC, a 32-bit generator, should only be capable of generating numbers +# between 0 and 2^32 - 1. We want _to_float to generate numbers possibly +# including 0, but always less than 1.0. Dividing the integer produced +# by irand() by this number should do that exactly. +use constant DIVIDE_BY => 2**32; + +our $RNG; + +our @EXPORT_OK = qw(rand srand irand); + +sub rand (;$) { + my ($limit) = @_; + my $int = irand(); + return _to_float($int, $limit); +} + +sub irand (;$) { + my ($limit) = @_; + Math::Random::Secure::srand() if !defined $RNG; + my $int = $RNG->irand(); + if (defined $limit) { + # We can't just use the mod operator because it will bias + # our output. Search for "modulo bias" on the Internet for + # details. This is slower than mod(), but does not have a bias, + # as demonstrated by our uniform.t test. + return int(_to_float($int, $limit)); + } + return $int; +} + +sub srand (;$) { + my ($value) = @_; + if (defined $RNG) { + if (defined $value) { + $RNG->seed($value); + } + else { + $RNG->clear_seed; + } + $RNG->clear_rng; + } + else { + my %args; + if (defined $value) { + $args{seed} = $value; + } + $RNG = Math::Random::Secure::RNG->new(%args); + } + # This makes srand return the seed and also makes sure that we + # get the seed right now, if no $value was passed. + return $RNG->seed; +} + +sub _to_float { + my ($integer, $limit) = @_; + $limit = 1 if !$limit; + return ($integer / DIVIDE_BY) * $limit; +} + +__PACKAGE__ + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Math::Random::Secure - Cryptographically-secure, cross-platform replacement for rand() + +=head1 VERSION + +version 0.080001 + +=head1 SYNOPSIS + + # Replace rand(). + use Math::Random::Secure qw(rand); + + # Get a random number between 0 and 1 + my $float = rand(); + + # Get a random integer (faster than int(rand)) + use Math::Random::Secure qw(irand); + my $int = irand(); + + # Random integer between 0 and 9 inclusive. + $int = irand(10); + + # Random floating-point number greater than or equal to 0.0 and + # less than 10.0. + $float = rand(10); + +=head1 DESCRIPTION + +This module is intended to provide a cryptographically-secure replacement +for Perl's built-in C function. "Crytographically secure", in this +case, means: + +=over + +=item * + +No matter how many numbers you see generated by the random number generator, +you cannot guess the future numbers, and you cannot guess the seed. + +=item * + +There are so many possible seeds that it would take decades, centuries, +or millenia for an attacker to try them all. + +=item * + +The seed comes from a source that generates relatively strong random data +on your platform, so the seed itself will be as random as possible. + +See L for more information about the underlying +systems used to implement all of these guarantees, and some important +caveats if you're going to use this module for some very-high-security +purpose. + +=back + +=head1 METHODS + +=head2 rand + +Should work exactly like Perl's built-in C. Will automatically +call C if C has never been called in this process or +thread. + +There is one limitation--Math::Random::Secure is backed by a 32-bit +random number generator. So if you are on a 64-bit platform and you +specify a limit that is greater than 2^32, you are likely to get +less-random data. + +=head2 srand + +B Under normal circumstances, you should B call this function, +as C and C will automatically call it for you the first time +they are used in a thread or process. + +Seeds the random number generator, much like Perl's built-in C, +except that it uses a much larger and more secure seed. The seed should +be passed as a string of bytes, at least 8 bytes in length, and more +ideally between 32 and 64 bytes. (See L +for more info.) + +If you do not pass a seed, a seed will be generated automatically using +a secure mechanism. See L for more information. + +This function returns the seed that generated (or the seed that was passed +in, if you passed one in). + +=head2 irand + +Works somewhat like L, except that it returns a 32-bit integer +between 0 and 2^32. Should be faster than doing C. + +Note that because it returns 32-bit integers, specifying a limit +greater than 2^32 will have no effect. + +=head1 IMPLEMENTATION DETAILS + +Currently, Math::Random::Secure is backed by L, a +cryptographically-strong random number generator with no known serious +weaknesses. If there are significant weaknesses found in ISAAC, we will +change our backend to a more-secure random number generator. The goal is +for Math::Random::Secure to be cryptographically strong, not to represent +some specific random number generator. + +Math::Random::Secure seeds itself using L. The +underlying implementation uses F on Unix-like platforms, and the +C or C functions on Windows 2000 and +above. (There is no support for versions of Windows before Windows 2000.) +If any of these seeding sources are not available and you have other +L modules installed, Math::Random::Secure will use +those other sources to seed itself. + +=head2 Making Math::Random::Secure Even More Secure + +We use F on Unix-like systems, because one of the requirements +of duplicating C is that we never block waiting for seed data, +and F could do that. However, it's possible that F +could run out of "truly random" data and start to use its built-in +pseudo-random number generator to generate data. On most systems, this should +still provide a very good seed for nearly all uses, but it may not be suitable +for very high-security cryptographic circumstances. + +For Windows, there are known issues with C on Windows 2000 +and versions of Windows XP before Service Pack 3. However, there is no +other built-in method of getting secure random data on Windows, and I suspect +that these issues will not be significant for most applications of +Math::Random::Secure. + +If either of these situations are a problem for your use, you can create +your own L object with a different "seeder" +argument, and set C<$Math::Random::Secure::RNG> to your own instance of +L. The "seeder" is an instance of +L, which should allow you to use most +random-data sources in existence for your seeder, should you wish. + +=head2 Seed Exhaustion + +Perl's built-in C reads 32 bits from F. By default, +we read 512 bits. This means that we are more likely to exhaust available +truly-random data than the built-in C is, and cause F +to fall back on its psuedo-random number generator. Normally this is not +a problem, since L is only called once per Perl process or thread, +but it is something that you should be aware of if you are going to +be in a situation where you have many new Perl processes or threads +and you have very high security requirements (on the order of generating +private SSH or GPG keypairs, SSL private keys, etc.). + +=head1 SEE ALSO + +=over + +=item L + +Describes the requirements and nature of a cryptographically-secure +random number generator. + +=item L, + +More information about the Windows functions we use to seed ourselves. The +article also has some information about the weaknesses in Windows 2000's +C implementation. + +=item L + +A news article about the Windows 2000/XP CryptGenRandom weakness, fixed +in Vista and XP Service Pack 3. + +=item L + +A description of ways to attack a random number generator, which can +help in understanding why such a generator needs to be secure. + +=item L + +The underlying random-number generator and seeding code for +Math::Random::Secure. + +=item L + +=item L + +=item L + +All of these modules contain generators for "truly random" data, but they +don't contain a simple C replacement and they can be very slow. + +=back + +=head1 SUPPORT + +Right now, the best way to get support for Math::Random::Secure is to email +the author using the email address in the L section below. + +=head1 BUGS + +Math::Random::Secure is relatively new, as of December 2010, but the +modules that underlie it are very well-tested and have a long history. +However, the author still welcomes all feedback and bug reports, particularly +those having to do with the security assurances provided by this module. + +You can report a bug by emailing C or +by using the RT web interface at +L. If +your bug report is security-sensitive, you may also email it directly to the +author using the email address in the L section below. + +=head1 AUTHORS + +=over 4 + +=item * + +Max Kanat-Alexander + +=item * + +Arthur Axel "fREW" Schmidt + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2010 by BugzillaSource, Inc. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +=cut --- /dev/null +++ b/Kernel/cpan-lib/Math/Random/Secure/RNG.pm @@ -0,0 +1,239 @@ +package Math::Random::Secure::RNG; +$Math::Random::Secure::RNG::VERSION = '0.080001'; +# ABSTRACT: The underlying PRNG, as an object. + +use Moo; +use Math::Random::ISAAC; +use Crypt::Random::Source::Factory; +use constant ON_WINDOWS => $^O =~ /Win32/i ? 1 : 0; +use if ON_WINDOWS, 'Crypt::Random::Source::Strong::Win32'; + +has seeder => ( + is => 'ro', + lazy => 1, + builder => '_build_seeder', +); +# Default to a 512-bit key, which should be impossible to break. I wrote +# to the author of ISAAC and he said it's fine to not use a full 256 +# integers to seed ISAAC. +has seed_size => ( + is => 'ro', + # isa => 'Int', + default => 64, +); + +has seed => ( + is => 'rw', + isa => \&_check_seed, + lazy => 1, + builder => '_build_seed', + clearer => 'clear_seed', + predicate => 'has_seed', +); + +has rng => ( + is => 'ro', + lazy => 1, + builder => '_build_rng', + handles => ['irand', 'rand'], + clearer => 'clear_rng', +); + +has _for_pid => ( + is => 'rw', + default => sub { $$ }, +); + +sub _clear_for_pid { shift->_for_pid($$) } + +before qw(irand rand) => '_maybe_clear_seed'; + +sub _maybe_clear_seed { + my $self = shift; + + if ($self->_for_pid != $$) { + $self->clear_seed; + $self->_clear_for_pid; + } +} + + +sub BUILD { + my ($self) = @_; + + if ($self->seed_size < 8) { + warn "Setting seed_size to less than 8 is not recommended"; + } +} + +sub _check_seed { + my ($seed) = @_; + if (length($seed) < 8) { + warn "Your seed is less than 8 bytes (64 bits). It could be" + . " easy to crack"; + } + # If it looks like we were seeded with a 32-bit integer, warn the + # user that they are making a dangerous, easily-crackable mistake. + # We do this during BUILD so that it happens during srand() in + # Math::Secure::RNG. + elsif (length($seed) <= 10 and $seed =~ /^\d+$/) { + warn "RNG seeded with a 32-bit integer, this is easy to crack"; + } + + # _check_seed is used as a type constraint, so needs to return 1. + return 1; +} + +sub _build_seeder { + my $factory = Crypt::Random::Source::Factory->new(); + # On Windows, we want to always pick Crypt::Random::Source::Strong::Win32, + # which this will do. + if (ON_WINDOWS) { + return $factory->get_strong; + } + + my $source = $factory->get; + # Never allow rand() to be used as a source, it cannot possibly be + # cryptographically strong with 2^15 or 2^32 bits for its seed. + if ($source->isa('Crypt::Random::Source::Weak::rand')) { + $source = $factory->get_strong; + } + return $source; +} + +sub _build_seed { + my ($self) = @_; + return $self->seeder->get($self->seed_size); +} + +sub _build_rng { + my ($self) = @_; + my @seed_ints = unpack('L*', $self->seed); + my $rng = Math::Random::ISAAC->new(@seed_ints); + # One part of having a cryptographically-secure RNG is not being + # able to see the seed in the internal state of the RNG. + $self->clear_seed; + # It's faster to skip the frontend interface of Math::Random::ISAAC + # and just use the backend directly. However, in case the internal + # code of Math::Random::ISAAC changes at some point, we do make sure + # that the {backend} element actually exists first. + return $rng->{backend} ? $rng->{backend} : $rng; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Math::Random::Secure::RNG - The underlying PRNG, as an object. + +=head1 VERSION + +version 0.080001 + +=head1 SYNOPSIS + + use Math::Random::Secure::RNG; + my $rng = Math::Random::Secure::RNG->new(); + my $int = $rng->irand(); + +=head1 DESCRIPTION + +This represents a random number generator, as an object. + +Generally, you shouldn't have to worry about this, and you should just use +L. But if for some reason you want to modify how the +random number generator works or you want an object-oriented interface +to a random-number generator, you can use this. + +=head1 METHODS + +=head2 irand + +Generates a random unsigned 32-bit integer. + +=head2 rand + +Generates a random floating-point number greater than or equal to 0 +and less than 1. + +=head1 ATTRIBUTES + +These are all options that can be passed to C or called as methods +on an existing object. + +=head2 rng + +The underlying random number generator. Defaults to an instance of +L. + +=head2 seed + +The random data used to seed L, as a string of bytes. This should +be large enough to properly seed L. This means I, it +should be 8 bytes (64 bits) and more ideally, 32 bytes (256 bits) or 64 +bytes (512 bits). For an idea of how large your seed should be, see +L for information +on how long it would take to brute-force seeds of each size. + +Note that C should not be an integer, but a B. + +It is very important that the seed be large enough, and also that the seed +be very random. B + +By default, we use a 512-bit (64 byte) seed. If +L continues to hold +true, it will be approximately 1000 years before computers can brute-force a +512-bit (64 byte) seed at any reasonable speed (and physics suggests that +computers will never actually become that fast, although there could always +be improvements or new methods of computing we can't now imagine, possibly +making Moore's Law continue to hold true forever). + +If you pass this to C, L and L will be ignored. + +=head2 seeder + +An instance of L that will be used to +get the seed for L. + +=head2 seed_size + +How much data (in bytes) should be read using L to seed L. +Defaults to 64 bytes (which is 512 bits). + +See L for more info about what is a reasonable seed size. + +=head1 SEE ALSO + +L + +=head1 AUTHORS + +=over 4 + +=item * + +Max Kanat-Alexander + +=item * + +Arthur Axel "fREW" Schmidt + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2010 by BugzillaSource, Inc. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +=cut --- /dev/null +++ b/Kernel/cpan-lib/Module/Find.pm @@ -0,0 +1,371 @@ +package Module::Find; + +use 5.006001; +use strict; +use warnings; + +use File::Spec; +use File::Find; + +our $VERSION = '0.15'; + +our $basedir = undef; +our @results = (); +our $prune = 0; +our $followMode = 1; + +our @ISA = qw(Exporter); + +our @EXPORT = qw(findsubmod findallmod usesub useall setmoduledirs); + +our @EXPORT_OK = qw(followsymlinks ignoresymlinks); + +=encoding utf-8 + +=head1 NAME + +Module::Find - Find and use installed modules in a (sub)category + +=head1 SYNOPSIS + + use Module::Find; + + # use all modules in the Plugins/ directory + @found = usesub Mysoft::Plugins; + + # use modules in all subdirectories + @found = useall Mysoft::Plugins; + + # find all DBI::... modules + @found = findsubmod DBI; + + # find anything in the CGI/ directory + @found = findallmod CGI; + + # set your own search dirs (uses @INC otherwise) + setmoduledirs(@INC, @plugindirs, $appdir); + + # not exported by default + use Module::Find qw(ignoresymlinks followsymlinks); + + # ignore symlinks + ignoresymlinks(); + + # follow symlinks (default) + followsymlinks(); + +=head1 DESCRIPTION + +Module::Find lets you find and use modules in categories. This can be very +useful for auto-detecting driver or plugin modules. You can differentiate +between looking in the category itself or in all subcategories. + +If you want Module::Find to search in a certain directory on your +harddisk (such as the plugins directory of your software installation), +make sure you modify C<@INC> before you call the Module::Find functions. + +=head1 FUNCTIONS + +=over + +=item C + +Sets the directories to be searched for modules. If not set, Module::Find +will use @INC. If you use this function, @INC will I be included +automatically, so add it if you want it. Set to undef to revert to +default behaviour. + +=cut + +sub setmoduledirs { + return @Module::Find::ModuleDirs = grep { defined } @_; +} + +=item C<@found = findsubmod Module::Category> + +Returns modules found in the Module/Category subdirectories of your perl +installation. E.g. C will return C, but +not C . + +=cut + +sub findsubmod(*) { + $prune = 1; + + return _find($_[0]); +} + +=item C<@found = findallmod Module::Category> + +Returns modules found in the Module/Category subdirectories of your perl +installation. E.g. C will return C and also +C . + +=cut + +sub findallmod(*) { + $prune = 0; + + return _find($_[0]); +} + +=item C<@found = usesub Module::Category> + +Uses and returns modules found in the Module/Category subdirectories of your perl +installation. E.g. C will return C, but +not C . + +If any module dies during loading, usesub will also die at this point. + +=cut + +sub usesub(*) { + $prune = 1; + + my @r = _find($_[0]); + + local @INC = @Module::Find::ModuleDirs + if (@Module::Find::ModuleDirs); + + foreach my $m (@r) { + eval " require $m; import $m ; "; + die $@ if $@; + } + + return @r; +} + +=item C<@found = useall Module::Category> + +Uses and returns modules found in the Module/Category subdirectories of your perl installation. E.g. C will return C and also +C . + +If any module dies during loading, useall will also die at this point. + +=cut + +sub useall(*) { + $prune = 0; + + my @r = _find($_[0]); + + local @INC = @Module::Find::ModuleDirs + if (@Module::Find::ModuleDirs); + + foreach my $m (@r) { + eval " require $m; import $m; "; + die $@ if $@; + } + + return @r; +} + +# 'wanted' functions for find() +# you know, this would be a nice application for currying... +sub _wanted { + my $name = File::Spec->abs2rel($_, $basedir); + return unless $name && $name ne File::Spec->curdir() && substr($name, 0, 1) ne '.'; + + if (-d && $prune) { + $File::Find::prune = 1; + return; + } + + return unless /\.pm$/; + + $name =~ s|\.pm$||; + $name = join('::', File::Spec->splitdir($name)); + + push @results, $name; +} + + +# helper functions for finding files + +sub _find(*) { + my ($category) = @_; + return undef unless defined $category; + + my $dir = File::Spec->catdir(split(/::|'/, $category)); + + @results = (); + + foreach my $inc (@Module::Find::ModuleDirs ? @Module::Find::ModuleDirs : @INC) { + if (ref $inc) { + if (my @files = eval { $inc->files }) { + push @results, + map { s/^\Q$category\E::// ? $_ : () } + map { s{/}{::}g; s{\.pm$}{}; $_ } + grep { /\.pm$/ } + @files; + } + } + else { + our $basedir = File::Spec->catdir($inc, $dir); + + next unless -d $basedir; + find({wanted => \&_wanted, + no_chdir => 1, + follow => $followMode}, $basedir); + } + } + + # filter duplicate modules + my %seen = (); + @results = grep { not $seen{$_}++ } @results; + + @results = map "$category\::$_", @results; + + @results = map { + ($_ =~ m{^(\w+(?:(?:::|')\w+)*)$})[0] || die "$_ does not look like a package name" + } @results; + + return @results; +} + +=item C + +Do not follow symlinks. This function is not exported by default. + +=cut + +sub ignoresymlinks { + $followMode = 0; +} + +=item C + +Follow symlinks (default behaviour). This function is not exported by default. + +=cut + +sub followsymlinks { + $followMode = 1; +} + +=back + +=head1 HISTORY + +=over 8 + +=item 0.01, 2004-04-22 + +Original version; created by h2xs 1.22 + +=item 0.02, 2004-05-25 + +Added test modules that were left out in the first version. Thanks to +Stuart Johnston for alerting me to this. + +=item 0.03, 2004-06-18 + +Fixed a bug (non-localized $_) by declaring a loop variable in use functions. +Thanks to Stuart Johnston for alerting me to this and providing a fix. + +Fixed non-platform compatibility by using File::Spec. +Thanks to brian d foy. + +Added setmoduledirs and updated tests. Idea shamelessly stolen from +...errm... inspired by brian d foy. + +=item 0.04, 2005-05-20 + +Added POD tests. + +=item 0.05, 2005-11-30 + +Fixed issue with bugfix in PathTools-3.14. + +=item 0.06, 2008-01-26 + +Module::Find now won't report duplicate modules several times anymore (thanks to Uwe Völker for the report and the patch) + +=item 0.07, 2009-09-08 + +Fixed RT#38302: Module::Find now follows symlinks by default (can be disabled). + +=item 0.08, 2009-09-08 + +Fixed RT#49511: Removed Mac OS X extended attributes from distribution + +=item 0.09, 2010-02-26 + +Fixed RT#38302: Fixed META.yml generation (thanks very much to cpanservice for the help). + +=item 0.10, 2010-02-26 + +Fixed RT#55010: Removed Unicode BOM from Find.pm. + +=item 0.11, 2012-05-22 + +Fixed RT#74251: defined(@array) is deprecated under Perl 5.15.7. +Thanks to Roman F, who contributed the implementation. + +=item 0.12, 2014-02-08 + +Fixed RT#81077: useall fails in taint mode +Thanks to Aran Deltac, who contributed the implementation and test. + +Fixed RT#83596: Documentation doesn't describe behaviour if a module fails to load +Clarified documentation for useall and usesub. + +Fixed RT#62923: setmoduledirs(undef) doesn't reset to searching @INC +Added more explicit tests. +Thanks to Colin Robertson for his input. + +=item 0.13, 2015-03-09 + +This release contains two contributions from Moritz Lenz: + +Link to Module::Pluggable and Class::Factory::Util in "SEE ALSO" + +Align package name parsing with how perl does it (allowing single quotes as module separator) + +Also, added a test for meta.yml + +=item 0.14, 2019-12-25 + +A long overdue update. Thank you for the many contributions! + +Fixed RT#99055: Removed file readability check (pull request contributed by Moritz Lenz) + +Now supports @INC hooks (pull request contributed by Graham Knop) + +Now filters out filenames starting with a dot (pull request contributed by Desmond Daignault) + +Now uses strict (pull request contributed by Shlomi Fish) + +Fixed RT#122016: test/ files show up in metacpan (bug report contributed by Karen Etheridge) + +=item 0.15, 2019-12-26 + +Fixed RT#127657 (bug report contributed by Karen Etheridge): Module::Find now uses @ModuleDirs +(if specified) for loading modules. Previously, when using setmoduledirs() to set an array of +directories that did not contain @INC, Module::Find would find the modules correctly, but load +them from @INC. + +=back + +=head1 DEVELOPMENT NOTES + +Please report any bugs using the CPAN RT system. The development repository for this module is hosted on GitHub: L. + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Christian Renz, Ecrenz@web42.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004-2019 by Christian Renz . All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; --- /dev/null +++ b/Kernel/cpan-lib/Reply/Plugin/TypeTiny.pm @@ -0,0 +1,112 @@ +package Reply::Plugin::TypeTiny; + +use strict; +use warnings; + +BEGIN { + $Reply::Plugin::TypeTiny::AUTHORITY = 'cpan:TOBYINK'; + $Reply::Plugin::TypeTiny::VERSION = '1.010000'; +}; + +$Reply::Plugin::TypeTiny::VERSION =~ tr/_//d; + +require Reply::Plugin; +our @ISA = 'Reply::Plugin'; + +use Scalar::Util qw(blessed); +use Term::ANSIColor; + +sub mangle_error { + my $self = shift; + my ($err) = @_; + + if (blessed $err and $err->isa("Error::TypeTiny::Assertion")) + { + my $explain = $err->explain; + if ($explain) + { + print color("cyan"); + print "Error::TypeTiny::Assertion explain:\n"; + $self->_explanation($explain, ""); + local $| = 1; + print "\n"; + print color("reset"); + } + } + + return @_; +} + +sub _explanation +{ + my $self = shift; + my ($ex, $indent) = @_; + + for my $line (@$ex) + { + if (ref($line) eq q(ARRAY)) + { + print "$indent * Explain:\n"; + $self->_explanation($line, "$indent "); + } + else + { + print "$indent * $line\n"; + } + } +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Reply::Plugin::TypeTiny - improved type constraint exceptions in Reply + +=head1 STATUS + +This module is not covered by the +L. + +=head1 DESCRIPTION + +This is a small plugin to improve error messages in L. +Not massively tested. + +=begin trustme + +=item mangle_error + +=end trustme + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L, L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Test/TypeTiny.pm @@ -0,0 +1,247 @@ +package Test::TypeTiny; + +use strict; +use warnings; + +use Test::More qw(); +use Scalar::Util qw(blessed); +use Types::TypeTiny qw(to_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 = '1.010000'; +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; + } + __PACKAGE__; + }; +} + +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 = to_TypeTiny($type) unless blessed($type) && $type->can("check"); + + my $strictures = $type->can("_strict_check"); + + my $test = "Test::Builder"->new->child( + $message || _mk_message("%s passes type constraint $type", $value), + ); + $test->plan(tests => ($strictures ? 2 : 1)); + $test->ok(!!$type->check($value), '->check'); + $test->ok(!!$type->_strict_check($value), '->_strict_check') if $strictures; + $test->finalize; + return $test->is_passing; +} + +sub should_fail +{ + my ($value, $type, $message) = @_; + $type = to_TypeTiny($type) unless blessed($type) && $type->can("check"); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + my $strictures = $type->can("_strict_check"); + + my $test = "Test::Builder"->new->child( + $message || _mk_message("%s fails type constraint $type", $value), + ); + $test->plan(tests => ($strictures ? 2 : 1)); + $test->ok(!$type->check($value), '->check'); + $test->ok(!$type->_strict_check($value), '->_strict_check') if $strictures; + $test->finalize; + return $test->is_passing; +} + +SLOW + +sub should_pass +{ + my ($value, $type, $message) = @_; + $type = 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 = 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__ + +=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. + +=head1 DESCRIPTION + +L 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. + +=back + +=head1 ENVIRONMENT + +If the C environment variable is set to true, this +module will promote each C or C 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. + +=head1 SEE ALSO + +L. + +For an alternative to C, see L which will +happily accept a Type::Tiny type constraint instead of a MooseX::Types one. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Coercion.pm @@ -0,0 +1,950 @@ +package Type::Coercion; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Coercion::AUTHORITY = 'cpan:TOBYINK'; + $Type::Coercion::VERSION = '1.010000'; +} + +$Type::Coercion::VERSION =~ tr/_//d; + +use Eval::TypeTiny qw<>; +use Scalar::Util qw< blessed >; +use Types::TypeTiny qw<>; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +require Type::Tiny; + +__PACKAGE__->Type::Tiny::_install_overloads( + q("") => sub { caller =~ m{^(Moo::HandleMoose|Sub::Quote)} ? $_[0]->_stringify_no_magic : $_[0]->display_name }, + q(bool) => sub { 1 }, + q(&{}) => "_overload_coderef", +); + +__PACKAGE__->Type::Tiny::_install_overloads( + q(~~) => sub { $_[0]->has_coercion_for_value($_[1]) }, +) if Type::Tiny::SUPPORT_SMARTMATCH(); + +sub _overload_coderef +{ + my $self = shift; + + if ("Sub::Quote"->can("quote_sub") && $self->can_be_inlined) + { + $self->{_overload_coderef} = Sub::Quote::quote_sub($self->inline_coercion('$_[0]')) + if !$self->{_overload_coderef} || !$self->{_sub_quoted}++; + } + else + { + Scalar::Util::weaken(my $weak = $self); + $self->{_overload_coderef} ||= sub { $weak->coerce(@_) }; + } + + $self->{_overload_coderef}; +} + +sub new +{ + my $class = shift; + my %params = (@_==1) ? %{$_[0]} : @_; + + $params{name} = '__ANON__' unless exists($params{name}); + my $C = delete($params{type_coercion_map}) || []; + my $F = delete($params{frozen}); + + my $self = bless \%params, $class; + $self->add_type_coercions(@$C) if @$C; + $self->_preserve_type_constraint; + Scalar::Util::weaken($self->{type_constraint}); # break ref cycle + $self->{frozen} = $F if $F; + + unless ($self->is_anon) + { + # First try a fast ASCII-only expression, but fall back to Unicode + $self->name =~ /^_{0,2}[A-Z][A-Za-z0-9_]+$/sm + or eval q( use 5.008; $self->name =~ /^_{0,2}\p{Lu}[\p{L}0-9_]+$/sm ) + or _croak '"%s" is not a valid coercion name', $self->name; + } + + return $self; +} + +sub _stringify_no_magic { + sprintf('%s=%s(0x%08x)', blessed($_[0]), Scalar::Util::reftype($_[0]), Scalar::Util::refaddr($_[0])); +} + +sub name { $_[0]{name} } +sub display_name { $_[0]{display_name} ||= $_[0]->_build_display_name } +sub library { $_[0]{library} } +sub type_constraint { $_[0]{type_constraint} ||= $_[0]->_maybe_restore_type_constraint } +sub type_coercion_map { $_[0]{type_coercion_map} ||= [] } +sub moose_coercion { $_[0]{moose_coercion} ||= $_[0]->_build_moose_coercion } +sub compiled_coercion { $_[0]{compiled_coercion} ||= $_[0]->_build_compiled_coercion } +sub frozen { $_[0]{frozen} ||= 0 } +sub coercion_generator { $_[0]{coercion_generator} } +sub parameters { $_[0]{parameters} } +sub parameterized_from { $_[0]{parameterized_from} } + +sub has_library { exists $_[0]{library} } +sub has_type_constraint { defined $_[0]->type_constraint } # sic +sub has_coercion_generator { exists $_[0]{coercion_generator} } +sub has_parameters { exists $_[0]{parameters} } + +sub _preserve_type_constraint +{ + my $self = shift; + $self->{_compiled_type_constraint_check} = $self->{type_constraint}->compiled_check + if $self->{type_constraint}; +} + +sub _maybe_restore_type_constraint +{ + my $self = shift; + if ( my $check = $self->{_compiled_type_constraint_check} ) + { + return Type::Tiny->new(constraint => $check); + } + return; # uncoverable statement +} + +sub add +{ + my $class = shift; + my ($x, $y, $swap) = @_; + + Types::TypeTiny::TypeTiny->check($x) and return $x->plus_fallback_coercions($y); + Types::TypeTiny::TypeTiny->check($y) and return $y->plus_coercions($x); + + _croak "Attempt to add $class to something that is not a $class" + unless blessed($x) && blessed($y) && $x->isa($class) && $y->isa($class); + + ($y, $x) = ($x, $y) if $swap; + + my %opts; + if ($x->has_type_constraint and $y->has_type_constraint and $x->type_constraint == $y->type_constraint) + { + $opts{type_constraint} = $x->type_constraint; + } + elsif ($x->has_type_constraint and $y->has_type_constraint) + { +# require Type::Tiny::Union; +# $opts{type_constraint} = "Type::Tiny::Union"->new( +# type_constraints => [ $x->type_constraint, $y->type_constraint ], +# ); + } + $opts{display_name} ||= "$x+$y"; + delete $opts{display_name} if $opts{display_name} eq '__ANON__+__ANON__'; + + my $new = $class->new(%opts); + $new->add_type_coercions( @{$x->type_coercion_map} ); + $new->add_type_coercions( @{$y->type_coercion_map} ); + return $new; +} + +sub _build_display_name +{ + shift->name; +} + +sub qualified_name +{ + my $self = shift; + + if ($self->has_library and not $self->is_anon) + { + return sprintf("%s::%s", $self->library, $self->name); + } + + return $self->name; +} + +sub is_anon +{ + my $self = shift; + $self->name eq "__ANON__"; +} + +sub _clear_compiled_coercion +{ + delete $_[0]{_overload_coderef}; + delete $_[0]{compiled_coercion}; +} + +sub freeze { $_[0]{frozen} = 1; $_[0] } +sub i_really_want_to_unfreeze { $_[0]{frozen} = 0; $_[0] } + +sub coerce +{ + my $self = shift; + return $self->compiled_coercion->(@_); +} + +sub assert_coerce +{ + my $self = shift; + my $r = $self->coerce(@_); + $self->type_constraint->assert_valid($r) + if $self->has_type_constraint; + return $r; +} + +sub has_coercion_for_type +{ + my $self = shift; + my $type = Types::TypeTiny::to_TypeTiny($_[0]); + + return "0 but true" + if $self->has_type_constraint && $type->is_a_type_of($self->type_constraint); + + my $c = $self->type_coercion_map; + for (my $i = 0; $i <= $#$c; $i += 2) + { + return !!1 if $type->is_a_type_of($c->[$i]); + } + return; +} + +sub has_coercion_for_value +{ + my $self = shift; + local $_ = $_[0]; + + return "0 but true" + if $self->has_type_constraint && $self->type_constraint->check(@_); + + my $c = $self->type_coercion_map; + for (my $i = 0; $i <= $#$c; $i += 2) + { + return !!1 if $c->[$i]->check(@_); + } + return; +} + +sub add_type_coercions +{ + my $self = shift; + my @args = @_; + + _croak "Attempt to add coercion code to a Type::Coercion which has been frozen" if $self->frozen; + + while (@args) + { + my $type = Types::TypeTiny::to_TypeTiny(shift @args); + + if (blessed $type and my $method = $type->can('type_coercion_map')) + { + push @{$self->type_coercion_map}, @{$method->($type)}; + } + else + { + my $coercion = shift @args; + _croak "Types must be blessed Type::Tiny objects" + unless Types::TypeTiny::TypeTiny->check($type); + _croak "Coercions must be code references or strings" + unless Types::TypeTiny::StringLike->check($coercion) || Types::TypeTiny::CodeLike->check($coercion); + push @{$self->type_coercion_map}, $type, $coercion; + } + } + + $self->_clear_compiled_coercion; + return $self; +} + +sub _build_compiled_coercion +{ + my $self = shift; + + my @mishmash = @{$self->type_coercion_map}; + return sub { $_[0] } unless @mishmash; + + if ($self->can_be_inlined) + { + return Eval::TypeTiny::eval_closure( + source => sprintf('sub ($) { %s }', $self->inline_coercion('$_[0]')), + description => sprintf("compiled coercion '%s'", $self), + ); + } + + # These arrays will be closed over. + my (@types, @codes); + while (@mishmash) + { + push @types, shift @mishmash; + push @codes, shift @mishmash; + } + if ($self->has_type_constraint) + { + unshift @types, $self->type_constraint; + unshift @codes, undef; + } + + my @sub; + + for my $i (0..$#types) + { + push @sub, + $types[$i]->can_be_inlined ? sprintf('if (%s)', $types[$i]->inline_check('$_[0]')) : + sprintf('if ($checks[%d]->(@_))', $i); + push @sub, + !defined($codes[$i]) + ? sprintf(' { return $_[0] }') : + Types::TypeTiny::StringLike->check($codes[$i]) + ? sprintf(' { local $_ = $_[0]; return scalar(%s); }', $codes[$i]) : + sprintf(' { local $_ = $_[0]; return scalar($codes[%d]->(@_)) }', $i); + } + + push @sub, 'return $_[0];'; + + return Eval::TypeTiny::eval_closure( + source => sprintf('sub ($) { %s }', join qq[\n], @sub), + description => sprintf("compiled coercion '%s'", $self), + environment => { + '@checks' => [ map $_->compiled_check, @types ], + '@codes' => \@codes, + }, + ); +} + +sub can_be_inlined +{ + my $self = shift; + + return unless $self->frozen; + + return + if $self->has_type_constraint + && !$self->type_constraint->can_be_inlined; + + my @mishmash = @{$self->type_coercion_map}; + while (@mishmash) + { + my ($type, $converter) = splice(@mishmash, 0, 2); + return unless $type->can_be_inlined; + return unless Types::TypeTiny::StringLike->check($converter); + } + return !!1; +} + +sub _source_type_union +{ + my $self = shift; + + my @r; + push @r, $self->type_constraint if $self->has_type_constraint; + + my @mishmash = @{$self->type_coercion_map}; + while (@mishmash) + { + my ($type) = splice(@mishmash, 0, 2); + push @r, $type; + } + + require Type::Tiny::Union; + return "Type::Tiny::Union"->new(type_constraints => \@r, tmp => 1); +} + +sub inline_coercion +{ + my $self = shift; + my $varname = $_[0]; + + _croak "This coercion cannot be inlined" unless $self->can_be_inlined; + + my @mishmash = @{$self->type_coercion_map}; + return "($varname)" unless @mishmash; + + my (@types, @codes); + while (@mishmash) + { + push @types, shift @mishmash; + push @codes, shift @mishmash; + } + if ($self->has_type_constraint) + { + unshift @types, $self->type_constraint; + unshift @codes, undef; + } + + my @sub; + + for my $i (0..$#types) + { + push @sub, sprintf('(%s) ?', $types[$i]->inline_check($varname)); + push @sub, + (defined($codes[$i]) && ($varname eq '$_')) + ? sprintf('scalar(do { %s }) :', $codes[$i]) : + defined($codes[$i]) + ? sprintf('scalar(do { local $_ = %s; %s }) :', $varname, $codes[$i]) : + sprintf('%s :', $varname); + } + + push @sub, "$varname"; + + "@sub"; +} + +sub _build_moose_coercion +{ + my $self = shift; + + my %options = (); + $options{type_coercion_map} = [ $self->freeze->_codelike_type_coercion_map('moose_type') ]; + $options{type_constraint} = $self->type_constraint if $self->has_type_constraint; + + require Moose::Meta::TypeCoercion; + my $r = "Moose::Meta::TypeCoercion"->new(%options); + + return $r; +} + +sub _codelike_type_coercion_map +{ + my $self = shift; + my $modifier = $_[0]; + + my @orig = @{ $self->type_coercion_map }; + my @new; + + while (@orig) + { + my ($type, $converter) = splice(@orig, 0, 2); + + push @new, $modifier ? $type->$modifier : $type; + + if (Types::TypeTiny::CodeLike->check($converter)) + { + push @new, $converter; + } + else + { + push @new, Eval::TypeTiny::eval_closure( + source => sprintf('sub { local $_ = $_[0]; %s }', $converter), + description => sprintf("temporary compiled converter from '%s'", $type), + ); + } + } + + return @new; +} + +sub is_parameterizable +{ + shift->has_coercion_generator; +} + +sub is_parameterized +{ + shift->has_parameters; +} + +sub parameterize +{ + my $self = shift; + return $self unless @_; + $self->is_parameterizable + or _croak "Constraint '%s' does not accept parameters", "$self"; + + @_ = map Types::TypeTiny::to_TypeTiny($_), @_; + + return ref($self)->new( + type_constraint => $self->type_constraint, + type_coercion_map => [ $self->coercion_generator->($self, $self->type_constraint, @_) ], + parameters => \@_, + frozen => 1, + parameterized_from => $self, + ); +} + +sub _reparameterize +{ + my $self = shift; + my ($target_type) = @_; + + $self->is_parameterized or return $self; + my $parent = $self->parameterized_from; + + return ref($self)->new( + type_constraint => $target_type, + type_coercion_map => [ $parent->coercion_generator->($parent, $target_type, @{$self->parameters}) ], + parameters => \@_, + frozen => 1, + parameterized_from => $parent, + ); +} + +sub isa +{ + my $self = shift; + + if ($INC{"Moose.pm"} and blessed($self) and $_[0] eq 'Moose::Meta::TypeCoercion') + { + return !!1; + } + + if ($INC{"Moose.pm"} + and blessed($self) + and $_[0] =~ /^(Class::MOP|MooseX?)::/) + { + my $r = $self->moose_coercion->isa(@_); + return $r if $r; + } + + $self->SUPER::isa(@_); +} + +sub can +{ + my $self = shift; + + my $can = $self->SUPER::can(@_); + return $can if $can; + + if ($INC{"Moose.pm"} + and blessed($self) + and my $method = $self->moose_coercion->can(@_)) + { + return sub { $method->(shift->moose_coercion, @_) }; + } + + return; +} + +sub AUTOLOAD +{ + my $self = shift; + my ($m) = (our $AUTOLOAD =~ /::(\w+)$/); + return if $m eq 'DESTROY'; + + if ($INC{"Moose.pm"} and blessed($self) and my $method = $self->moose_coercion->can($m)) + { + return $method->($self->moose_coercion, @_); + } + + _croak q[Can't locate object method "%s" via package "%s"], $m, ref($self)||$self; +} + +# Private Moose method, but Moo uses this... +sub _compiled_type_coercion +{ + my $self = shift; + if (@_) + { + my $thing = $_[0]; + if (blessed($thing) and $thing->isa("Type::Coercion")) + { + $self->add_type_coercions(@{$thing->type_coercion_map}); + } + elsif (Types::TypeTiny::CodeLike->check($thing)) + { + require Types::Standard; + $self->add_type_coercions(Types::Standard::Any(), $thing); + } + } + $self->compiled_coercion; +} + +*compile_type_coercion = \&compiled_coercion; +sub meta { _croak("Not really a Moose::Meta::TypeCoercion. Sorry!") } + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Coercion - a set of coercions to a particular target type constraint + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +=head2 Constructors + +=over + +=item C<< new(%attributes) >> + +Moose-style constructor function. + +=item C<< add($c1, $c2) >> + +Create a Type::Coercion from two existing Type::Coercion objects. + +=back + +=head2 Attributes + +Attributes are named values that may be passed to the constructor. For +each attribute, there is a corresponding reader method. For example: + + my $c = Type::Coercion->new( type_constraint => Int ); + my $t = $c->type_constraint; # Int + +=head3 Important attributes + +These are the attributes you are likely to be most interested in +providing when creating your own type coercions, and most interested +in reading when dealing with coercion objects. + +=over + +=item C + +Weak reference to the target type constraint (i.e. the type constraint which +the output of coercion coderefs is expected to conform to). + +=item C + +Arrayref of source-type/code pairs. + +=item C + +Boolean; default false. A frozen coercion cannot have C +called upon it. + +=item C + +A name for the coercion. These need to conform to certain naming +rules (they must begin with an uppercase letter and continue using only +letters, digits 0-9 and underscores). + +Optional; if not supplied will be an anonymous coercion. + +=item C + +A name to display for the coercion when stringified. These don't have +to conform to any naming rules. Optional; a default name will be +calculated from the C. + +=item C + +The package name of the type library this coercion is associated with. +Optional. Informational only: setting this attribute does not install +the coercion into the package. + +=back + +=head3 Attributes related to parameterizable and parameterized coercions + +The following attributes are used for parameterized coercions, but are not +fully documented because they may change in the near future: + +=over + +=item C<< coercion_generator >> + +=item C<< parameters >> + +=item C<< parameterized_from >> + +=back + +=head3 Lazy generated attributes + +The following attributes should not be usually passed to the constructor; +unless you're doing something especially unusual, you should rely on the +default lazily-built return values. + +=over + +=item C<< compiled_coercion >> + +Coderef to coerce a value (C<< $_[0] >>). + +The general point of this attribute is that you should not set it, but +rely on the lazily-built default. Type::Coerce will usually generate a +pretty fast coderef, inlining all type constraint checks, etc. + +=item C + +A L object equivalent to this one. Don't set this +manually; rely on the default built one. + +=back + +=head2 Methods + +=head3 Predicate methods + +These methods return booleans indicating information about the coercion. +They are each tightly associated with a particular attribute. +(See L.) + +=over + +=item C, C + +Simple Moose-style predicate methods indicating the presence or +absence of an attribute. + +=item C + +Returns true iff the coercion does not have a C. + +=back + +The following predicates are used for parameterized coercions, but are not +fully documented because they may change in the near future: + +=over + +=item C<< has_coercion_generator >> + +=item C<< has_parameters >> + +=item C<< is_parameterizable >> + +=item C<< is_parameterized >> + +=back + +=head3 Coercion + +The following methods are used for coercing values to a type constraint: + +=over + +=item C<< coerce($value) >> + +Coerce the value to the target type. + +Returns the coerced value, or the original value if no coercion was +possible. + +=item C<< assert_coerce($value) >> + +Coerce the value to the target type, and throw an exception if the result +does not validate against the target type constraint. + +Returns the coerced value. + +=back + +=head3 Coercion code definition methods + +These methods all return C<< $self >> so are suitable for chaining. + +=over + +=item C<< add_type_coercions($type1, $code1, ...) >> + +Takes one or more pairs of L constraints and coercion code, +creating an ordered list of source types and coercion codes. + +Coercion codes can be expressed as either a string of Perl code (this +includes objects which overload stringification), or a coderef (or object +that overloads coderefification). In either case, the value to be coerced +is C<< $_ >>. + +C<< add_type_coercions($coercion_object) >> also works, and can be used +to copy coercions from another type constraint: + + $type->coercion->add_type_coercions($othertype->coercion)->freeze; + +=item C<< freeze >> + +Sets the C attribute to true. Called automatically by L +sometimes. + +=item C<< i_really_want_to_unfreeze >> + +If you really want to unfreeze a coercion, call this method. + +Don't call this method. It will potentially lead to subtle bugs. + +This method is considered unstable; future versions of Type::Tiny may +alter its behaviour (e.g. to throw an exception if it has been detected +that unfreezing this particular coercion will cause bugs). + +=back + +=head3 Parameterization + +The following method is used for parameterized coercions, but is not +fully documented because it may change in the near future: + +=over + +=item C<< parameterize(@params) >> + +=back + +=head3 Type coercion introspection methods + +These methods allow you to determine a coercion's relationship to type +constraints: + +=over + +=item C<< has_coercion_for_type($source_type) >> + +Returns true iff this coercion has a coercion from the source type. + +Returns the special string C<< "0 but true" >> if no coercion should +actually be necessary for this type. (For example, if a coercion coerces +to a theoretical "Number" type, there is probably no coercion necessary +for values that already conform to the "Integer" type.) + +=item C<< has_coercion_for_value($value) >> + +Returns true iff the value could be coerced by this coercion. + +Returns the special string C<< "0 but true" >> if no coercion would be +actually be necessary for this value (due to it already meeting the target +type constraint). + +=back + +The C attribute provides a type constraint object for the +target type constraint of the coercion. See L. + +=head3 Inlining methods + +=for stopwords uated + +The following methods are used to generate strings of Perl code which +may be pasted into stringy Cuated subs to perform type coercions: + +=over + +=item C<< can_be_inlined >> + +Returns true iff the coercion can be inlined. + +=item C<< inline_coercion($varname) >> + +Much like C from L. + +=back + +=head3 Other methods + +=over + +=item C<< qualified_name >> + +For non-anonymous coercions that have a library, returns a qualified +C<< "MyLib::MyCoercion" >> sort of name. Otherwise, returns the same +as C. + +=item C<< isa($class) >>, C<< can($method) >>, C<< AUTOLOAD(@args) >> + +If Moose is loaded, then the combination of these methods is used to mock +a Moose::Meta::TypeCoercion. + +=back + +The following methods exist for Moose/Mouse compatibility, but do not do +anything useful. + +=over + +=item C<< compile_type_coercion >> + +=item C<< meta >> + +=back + +=head2 Overloading + +=over + +=item * + +Boolification is overloaded to always return true. + +=item * + +Coderefification is overloaded to call C. + +=item * + +On Perl 5.10.1 and above, smart match is overloaded to call C. + +=back + +Previous versions of Type::Coercion would overload the C<< + >> operator +to call C. Support for this was dropped after 0.040. + +=head1 DIAGNOSTICS + +=over + +=item I<< Attempt to add coercion code to a Type::Coercion which has been frozen >> + +Type::Tiny type constraints are designed as immutable objects. Once you've +created a constraint, rather than modifying it you generally create child +constraints to do what you need. + +Type::Coercion objects, on the other hand, are mutable. Coercion routines +can be added at any time during the object's lifetime. + +Sometimes Type::Tiny needs to freeze a Type::Coercion object to prevent this. +In L and L code this is likely to happen as soon as you use a +type constraint in an attribute. + +Workarounds: + +=over + +=item * + +Define as many of your coercions as possible within type libraries, not +within the code that uses the type libraries. The type library will be +evaluated relatively early, likely before there is any reason to freeze +a coercion. + +=item * + +If you do need to add coercions to a type within application code outside +the type library, instead create a subtype and add coercions to that. The +C method provided by L should make this simple. + +=back + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L, L, L, L. + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + + --- /dev/null +++ b/Kernel/cpan-lib/Type/Coercion/FromMoose.pm @@ -0,0 +1,127 @@ +package Type::Coercion::FromMoose; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Coercion::FromMoose::AUTHORITY = 'cpan:TOBYINK'; + $Type::Coercion::FromMoose::VERSION = '1.010000'; +} + +$Type::Coercion::FromMoose::VERSION =~ tr/_//d; + +use Scalar::Util qw< blessed >; +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +require Type::Coercion; +our @ISA = 'Type::Coercion'; + +sub type_coercion_map +{ + my $self = shift; + + my @from; + if ($self->type_constraint) + { + my $moose = $self->type_constraint->{moose_type}; + @from = @{ $moose->coercion->type_coercion_map } if $moose && $moose->has_coercion; + } + else + { + _croak "The type constraint attached to this coercion has been garbage collected... PANIC"; + } + + my @return; + while (@from) + { + my ($type, $code) = splice(@from, 0, 2); + $type = Moose::Util::TypeConstraints::find_type_constraint($type) + unless ref $type; + push @return, Types::TypeTiny::to_TypeTiny($type), $code; + } + + return \@return; +} + +sub add_type_coercions +{ + my $self = shift; + _croak "Adding coercions to Type::Coercion::FromMoose not currently supported" if @_; +} + +sub _build_moose_coercion +{ + my $self = shift; + + if ($self->type_constraint) + { + my $moose = $self->type_constraint->{moose_type}; + return $moose->coercion if $moose && $moose->has_coercion; + } + + $self->SUPER::_build_moose_coercion(@_); +} + +sub can_be_inlined +{ + 0; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Coercion::FromMoose - a set of coercions borrowed from Moose + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This package inherits from L; see that for most documentation. +The major differences are that C always throws an +exception, and the C is automatically populated from +Moose. + +This is mostly for internal purposes. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Coercion/Union.pm @@ -0,0 +1,141 @@ +package Type::Coercion::Union; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Coercion::Union::AUTHORITY = 'cpan:TOBYINK'; + $Type::Coercion::Union::VERSION = '1.010000'; +} + +$Type::Coercion::Union::VERSION =~ tr/_//d; + +use Scalar::Util qw< blessed >; +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +require Type::Coercion; +our @ISA = 'Type::Coercion'; + +sub _preserve_type_constraint +{ + my $self = shift; + $self->{_union_of} = $self->{type_constraint}->type_constraints + if $self->{type_constraint}; +} + +sub _maybe_restore_type_constraint +{ + my $self = shift; + if ( my $union = $self->{_union_of} ) + { + return Type::Tiny::Union->new(type_constraints => $union); + } + return; # uncoverable statement +} + +sub type_coercion_map +{ + my $self = shift; + + Types::TypeTiny::TypeTiny->assert_valid(my $type = $self->type_constraint); + $type->isa('Type::Tiny::Union') + or _croak "Type::Coercion::Union must be used in conjunction with Type::Tiny::Union"; + + my @c; + for my $tc (@$type) + { + next unless $tc->has_coercion; + push @c, @{$tc->coercion->type_coercion_map}; + } + return \@c; +} + +sub add_type_coercions +{ + my $self = shift; + _croak "Adding coercions to Type::Coercion::Union not currently supported" if @_; +} + +sub _build_moose_coercion +{ + my $self = shift; + + my %options = (); + $options{type_constraint} = $self->type_constraint if $self->has_type_constraint; + + require Moose::Meta::TypeCoercion::Union; + my $r = "Moose::Meta::TypeCoercion::Union"->new(%options); + + return $r; +} + +sub can_be_inlined +{ + my $self = shift; + + Types::TypeTiny::TypeTiny->assert_valid(my $type = $self->type_constraint); + + for my $tc (@$type) + { + next unless $tc->has_coercion; + return !!0 unless $tc->coercion->can_be_inlined; + } + + !!1; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Coercion::Union - a set of coercions to a union type constraint + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +This package inherits from L; see that for most documentation. +The major differences are that C always throws an +exception, and the C is automatically populated from +the child constraints of the union type constraint. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Library.pm @@ -0,0 +1,684 @@ +package Type::Library; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Library::AUTHORITY = 'cpan:TOBYINK'; + $Type::Library::VERSION = '1.010000'; +} + +$Type::Library::VERSION =~ tr/_//d; + +use Eval::TypeTiny qw< eval_closure >; +use Scalar::Util qw< blessed refaddr >; +use Type::Tiny; +use Types::TypeTiny qw< TypeTiny to_TypeTiny >; + +require Exporter::Tiny; +our @ISA = 'Exporter::Tiny'; + +BEGIN { *NICE_PROTOTYPES = ($] >= 5.014) ? sub () { !!1 } : sub () { !!0 } }; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +{ + my $subname; + my %already; # prevent renaming established functions + sub _subname ($$) + { + $subname = + eval { require Sub::Util } ? \&Sub::Util::set_subname : + eval { require Sub::Name } ? \&Sub::Name::subname : + 0 + if not defined $subname; + !$already{refaddr($_[1])}++ and return($subname->(@_)) + if $subname; + return $_[1]; + } +} + +sub _exporter_validate_opts +{ + my $class = shift; + + no strict "refs"; + my $into = $_[0]{into}; + push @{"$into\::ISA"}, $class if $_[0]{base}; + + return $class->SUPER::_exporter_validate_opts(@_); +} + +sub _exporter_expand_tag +{ + my $class = shift; + my ($name, $value, $globals) = @_; + + $name eq 'types' and return map [ "$_" => $value ], $class->type_names; + $name eq 'is' and return map [ "is_$_" => $value ], $class->type_names; + $name eq 'assert' and return map [ "assert_$_" => $value ], $class->type_names; + $name eq 'to' and return map [ "to_$_" => $value ], $class->type_names; + $name eq 'coercions' and return map [ "$_" => $value ], $class->coercion_names; + + if ($name eq 'all') + { + no strict "refs"; + return ( + map( + [ "+$_" => $value ], + $class->type_names, + ), + map( + [ $_ => $value ], + $class->coercion_names, + @{"$class\::EXPORT"}, + @{"$class\::EXPORT_OK"}, + ), + ); + } + + return $class->SUPER::_exporter_expand_tag(@_); +} + +sub _mksub +{ + my $class = shift; + my ($type, $post_method) = @_; + $post_method ||= q(); + + my $source = $type->is_parameterizable + ? sprintf( + q{ + sub (%s) { + return $_[0]->complete($type) if ref($_[0]) eq 'Type::Tiny::_HalfOp'; + my $params; $params = shift if ref($_[0]) eq q(ARRAY); + my $t = $params ? $type->parameterize(@$params) : $type; + @_ && wantarray ? return($t%s, @_) : return $t%s; + } + }, + NICE_PROTOTYPES ? q(;$) : q(;@), + $post_method, + $post_method, + ) + : sprintf( + q{ sub () { $type%s if $] } }, + $post_method, + ); + + return _subname( + $type->qualified_name, + eval_closure( + source => $source, + description => sprintf("exportable function '%s::%s'", $class, $type), + environment => {'$type' => \$type}, + ), + ); +} + +sub _exporter_permitted_regexp +{ + my $class = shift; + + my $inherited = $class->SUPER::_exporter_permitted_regexp(@_); + my $types = join "|", map quotemeta, sort { + length($b) <=> length($a) or $a cmp $b + } $class->type_names; + my $coercions = join "|", map quotemeta, sort { + length($b) <=> length($a) or $a cmp $b + } $class->coercion_names; + + qr{^(?: + $inherited + | (?: (?:is_|to_|assert_)? (?:$types) ) + | (?:$coercions) + )$}xms; +} + +sub _exporter_expand_sub +{ + my $class = shift; + my ($name, $value, $globals) = @_; + + if ($name =~ /^\+(.+)/ and $class->has_type($1)) + { + my $type = $1; + my $value2 = +{%{$value||{}}}; + + return map $class->_exporter_expand_sub($_, $value2, $globals), + $type, "is_$type", "assert_$type", "to_$type"; + } + + my $typename = $name; + my $thingy = undef; + if ($name =~ /^(is|assert|to)_(.+)$/) + { + $thingy = $1; + $typename = $2; + } + + if (my $type = $class->get_type($typename)) + { + my $custom_type = 0; + for my $param (qw/ of where /) + { + exists $value->{$param} or next; + defined $value->{-as} + or _croak("Parameter '-as' not supplied"); + $type = $type->$param($value->{$param}); + $name = $value->{-as}; + ++$custom_type; + } + + if (!defined $thingy) + { + my $post_method = q(); + $post_method = '->mouse_type' if $globals->{mouse}; + $post_method = '->moose_type' if $globals->{moose}; + return ($name => $class->_mksub($type, $post_method)) if $post_method || $custom_type; + } + elsif ($thingy eq 'is') + { + return ($value->{-as} || "is_$typename" => $type->compiled_check) if $custom_type; + } + elsif ($thingy eq 'assert') + { + return ($value->{-as} || "assert_$typename" => $type->_overload_coderef) if $custom_type; + } + elsif ($thingy eq 'to') + { + my $to_type = $type->has_coercion && $type->coercion->frozen + ? $type->coercion->compiled_coercion + : sub ($) { $type->coerce($_[0]) }; + return ($value->{-as} || "to_$typename" => $to_type) if $custom_type; + } + } + + return $class->SUPER::_exporter_expand_sub(@_); +} + +sub _exporter_install_sub +{ + my $class = shift; + my ($name, $value, $globals, $sym) = @_; + + my $package = $globals->{into}; + my $type = $class->get_type($name); + + Exporter::Tiny::_carp( + "Exporting deprecated type %s to %s", + $type->qualified_name, + ref($package) ? "reference" : "package $package", + ) if (defined $type and $type->deprecated and not $globals->{allow_deprecated}); + + if (!ref $package and defined $type) + { + my ($prefix) = grep defined, $value->{-prefix}, $globals->{prefix}, q(); + my ($suffix) = grep defined, $value->{-suffix}, $globals->{suffix}, q(); + my $as = $prefix . ($value->{-as} || $name) . $suffix; + + $INC{'Type/Registry.pm'} + ? 'Type::Registry'->for_class($package)->add_type($type, $as) + : ($Type::Registry::DELAYED{$package}{$as} = $type); + } + + $class->SUPER::_exporter_install_sub(@_); +} + +sub _exporter_fail +{ + my $class = shift; + my ($name, $value, $globals) = @_; + + my $into = $globals->{into} + or _croak("Parameter 'into' not supplied"); + + if ($globals->{declare}) + { + my $declared = sub (;$) + { + my $params; $params = shift if ref($_[0]) eq "ARRAY"; + my $type = $into->get_type($name); + my $t; + + if ($type) { + my $t = $params ? $type->parameterize(@$params) : $type; + } + else + { + _croak "Cannot parameterize a non-existant type" if $params; + $t = Type::Tiny::_DeclaredType->new(library => $into, name => $name); + } + + @_ && wantarray ? return($t, @_) : return $t; + }; + + return( + $name, + _subname( + "$class\::$name", + NICE_PROTOTYPES ? sub (;$) { goto $declared } : sub (;@) { goto $declared }, + ), + ); + } + + return $class->SUPER::_exporter_fail(@_); +} + +{ + package Type::Tiny::_DeclaredType; + our @ISA = 'Type::Tiny'; + sub new { + my $class = shift; + my %opts = @_==1 ? %{+shift} : @_; + my $library = delete $opts{library}; + my $name = delete $opts{name}; + $opts{display_name} = $name; + $opts{constraint} = sub { + my $val = @_ ? pop : $_; + $library->get_type($name)->check($val); + }; + $opts{inlined} = sub { + my $val = @_ ? pop : $_; + sprintf('%s::is_%s(%s)', $library, $name, $val); + }; + $class->SUPER::new(%opts); + } +} + +sub meta +{ + no strict "refs"; + no warnings "once"; + return $_[0] if blessed $_[0]; + ${"$_[0]\::META"} ||= bless {}, $_[0]; +} + +sub add_type +{ + my $meta = shift->meta; + my $class = blessed($meta); + + my $type = + ref($_[0]) =~ /^Type::Tiny\b/ ? $_[0] : + blessed($_[0]) ? to_TypeTiny($_[0]) : + ref($_[0]) eq q(HASH) ? "Type::Tiny"->new(library => $class, %{$_[0]}) : + "Type::Tiny"->new(library => $class, @_); + my $name = $type->{name}; + + $meta->{types} ||= {}; + _croak 'Type %s already exists in this library', $name if $meta->has_type($name); + _croak 'Type %s conflicts with coercion of same name', $name if $meta->has_coercion($name); + _croak 'Cannot add anonymous type to a library' if $type->is_anon; + $meta->{types}{$name} = $type; + + no strict "refs"; + no warnings "redefine", "prototype"; + + my $to_type = $type->has_coercion && $type->coercion->frozen + ? $type->coercion->compiled_coercion + : sub ($) { $type->coerce($_[0]) }; + + *{"$class\::$name"} = $class->_mksub($type); + *{"$class\::is_$name"} = _subname "$class\::is_$name", $type->compiled_check; + *{"$class\::to_$name"} = _subname "$class\::to_$name", $to_type; + *{"$class\::assert_$name"} = _subname "$class\::assert_$name", $type->_overload_coderef; + + return $type; +} + +sub get_type +{ + my $meta = shift->meta; + $meta->{types}{$_[0]}; +} + +sub has_type +{ + my $meta = shift->meta; + exists $meta->{types}{$_[0]}; +} + +sub type_names +{ + my $meta = shift->meta; + keys %{ $meta->{types} }; +} + +sub add_coercion +{ + require Type::Coercion; + my $meta = shift->meta; + my $c = blessed($_[0]) ? $_[0] : "Type::Coercion"->new(@_); + my $name = $c->name; + + $meta->{coercions} ||= {}; + _croak 'Coercion %s already exists in this library', $name if $meta->has_coercion($name); + _croak 'Coercion %s conflicts with type of same name', $name if $meta->has_type($name); + _croak 'Cannot add anonymous type to a library' if $c->is_anon; + $meta->{coercions}{$name} = $c; + + no strict "refs"; + no warnings "redefine", "prototype"; + + my $class = blessed($meta); + *{"$class\::$name"} = $class->_mksub($c); + + return $c; +} + +sub get_coercion +{ + my $meta = shift->meta; + $meta->{coercions}{$_[0]}; +} + +sub has_coercion +{ + my $meta = shift->meta; + exists $meta->{coercions}{$_[0]}; +} + +sub coercion_names +{ + my $meta = shift->meta; + keys %{ $meta->{coercions} }; +} + +sub make_immutable +{ + my $meta = shift->meta; + my $class = ref($meta); + + for my $type (values %{$meta->{types}}) + { + $type->coercion->freeze; + + no strict "refs"; + no warnings "redefine", "prototype"; + + my $to_type = $type->has_coercion && $type->coercion->frozen + ? $type->coercion->compiled_coercion + : sub ($) { $type->coerce($_[0]) }; + my $name = $type->name; + + *{"$class\::to_$name"} = _subname "$class\::to_$name", $to_type; + } + + 1; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords Moo(se)-compatible MooseX::Types-like + +=head1 NAME + +Type::Library - tiny, yet Moo(se)-compatible type libraries + +=head1 SYNOPSIS + +=for test_synopsis +BEGIN { die "SKIP: crams multiple modules into single example" }; + + package Types::Mine { + use Scalar::Util qw(looks_like_number); + use Type::Library -base; + use Type::Tiny; + + my $NUM = "Type::Tiny"->new( + name => "Number", + constraint => sub { looks_like_number($_) }, + message => sub { "$_ ain't a number" }, + ); + + __PACKAGE__->meta->add_type($NUM); + + __PACKAGE__->meta->make_immutable; + } + + package Ermintrude { + use Moo; + use Types::Mine qw(Number); + has favourite_number => (is => "ro", isa => Number); + } + + package Bullwinkle { + use Moose; + use Types::Mine qw(Number); + has favourite_number => (is => "ro", isa => Number); + } + + package Maisy { + use Mouse; + use Types::Mine qw(Number); + has favourite_number => (is => "ro", isa => Number); + } + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +L is a tiny class for creating MooseX::Types-like type +libraries which are compatible with Moo, Moose and Mouse. + +If you're reading this because you want to create a type library, then +you're probably better off reading L. + +=head2 Methods + +A type library is a singleton class. Use the C method to get a blessed +object which other methods can get called on. For example: + + Types::Mine->meta->add_type($foo); + +=begin trustme + +=item meta + +=end trustme + +=over + +=item C<< add_type($type) >> or C<< add_type(%opts) >> + +Add a type to the library. If C<< %opts >> is given, then this method calls +C<< Type::Tiny->new(%opts) >> first, and adds the resultant type. + +Adding a type named "Foo" to the library will automatically define four +functions in the library's namespace: + +=over + +=item C<< Foo >> + +Returns the Type::Tiny object. + +=item C<< is_Foo($value) >> + +Returns true iff $value passes the type constraint. + +=item C<< assert_Foo($value) >> + +Returns $value iff $value passes the type constraint. Dies otherwise. + +=item C<< to_Foo($value) >> + +Coerces the value to the type. + +=back + +=item C<< get_type($name) >> + +Gets the C object corresponding to the name. + +=item C<< has_type($name) >> + +Boolean; returns true if the type exists in the library. + +=item C<< type_names >> + +List all types defined by the library. + +=item C<< add_coercion($c) >> or C<< add_coercion(%opts) >> + +Add a standalone coercion to the library. If C<< %opts >> is given, then +this method calls C<< Type::Coercion->new(%opts) >> first, and adds the +resultant coercion. + +Adding a coercion named "FooFromBar" to the library will automatically +define a function in the library's namespace: + +=over + +=item C<< FooFromBar >> + +Returns the Type::Coercion object. + +=back + +=item C<< get_coercion($name) >> + +Gets the C object corresponding to the name. + +=item C<< has_coercion($name) >> + +Boolean; returns true if the coercion exists in the library. + +=item C<< coercion_names >> + +List all standalone coercions defined by the library. + +=item C<< import(@args) >> + +Type::Library-based libraries are exporters. + +=item C<< make_immutable >> + +A shortcut for calling C<< $type->coercion->freeze >> on every +type constraint in the library. + +=back + +=head2 Constants + +=over + +=item C<< NICE_PROTOTYPES >> + +If this is true, then Type::Library will give parameterizable type constraints +slightly the nicer prototype of C<< (;$) >> instead of the default C<< (;@) >>. +This allows constructs like: + + ArrayRef[Int] | HashRef[Int] + +... to "just work". + +=back + +=head2 Export + +Type libraries are exporters. For the purposes of the following examples, +assume that the C library defines types C and C. + + # Exports nothing. + # + use Types::Mine; + + # Exports a function "String" which is a constant returning + # the String type constraint. + # + use Types::Mine qw( String ); + + # Exports both String and Number as above. + # + use Types::Mine qw( String Number ); + + # Same. + # + use Types::Mine qw( :types ); + + # Exports "coerce_String" and "coerce_Number", as well as any other + # coercions + # + use Types::Mine qw( :coercions ); + + # Exports a sub "is_String" so that "is_String($foo)" is equivalent + # to "String->check($foo)". + # + use Types::Mine qw( is_String ); + + # Exports "is_String" and "is_Number". + # + use Types::Mine qw( :is ); + + # Exports a sub "assert_String" so that "assert_String($foo)" is + # equivalent to "String->assert_return($foo)". + # + use Types::Mine qw( assert_String ); + + # Exports "assert_String" and "assert_Number". + # + use Types::Mine qw( :assert ); + + # Exports a sub "to_String" so that "to_String($foo)" is equivalent + # to "String->coerce($foo)". + # + use Types::Mine qw( to_String ); + + # Exports "to_String" and "to_Number". + # + use Types::Mine qw( :to ); + + # Exports "String", "is_String", "assert_String" and "coerce_String". + # + use Types::Mine qw( +String ); + + # Exports everything. + # + use Types::Mine qw( :all ); + +Type libraries automatically inherit from L; see the +documentation of that module for tips and tricks importing from libraries. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L, L, L, L. + +L, +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + + --- /dev/null +++ b/Kernel/cpan-lib/Type/Params.pm @@ -0,0 +1,1711 @@ +package Type::Params; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + if ($] < 5.008) { require Devel::TypeTiny::Perl56Compat }; +} + +BEGIN { + $Type::Params::AUTHORITY = 'cpan:TOBYINK'; + $Type::Params::VERSION = '1.010000'; +} + +$Type::Params::VERSION =~ tr/_//d; + +use B qw(); +use Eval::TypeTiny; +use Scalar::Util qw(refaddr); +use Error::TypeTiny; +use Error::TypeTiny::Assertion; +use Error::TypeTiny::WrongNumberOfParameters; +use Types::Standard -types; +use Types::TypeTiny qw(CodeLike TypeTiny ArrayLike StringLike to_TypeTiny); + +require Exporter::Tiny; +our @ISA = 'Exporter::Tiny'; + +our @EXPORT = qw( compile compile_named ); +our @EXPORT_OK = qw( multisig validate validate_named compile_named_oo Invocant wrap_subs wrap_methods ); + +sub english_list { + require Type::Utils; + goto \&Type::Utils::english_list; +} + +my $QUOTE = \&B::perlstring; + +{ + my $Invocant; + sub Invocant () { + $Invocant ||= do { + require Type::Tiny::Union; + require Types::Standard; + 'Type::Tiny::Union'->new( + name => 'Invocant', + type_constraints => [ + Types::Standard::Object(), + Types::Standard::ClassName(), + ], + ); + }; + } +} + +sub _mkslurpy +{ + my ($name, $type, $tc, $i) = @_; + $name = 'local $_' if $name eq '$_'; + + $type eq '@' + ? sprintf( + '%s = [ @_[%d..$#_] ];', + $name, + $i, + ) + : sprintf( + '%s = (@_==%d and ref $_[%d] eq "HASH") ? +{ %%{$_[%d]} } : (($#_-%d)%%2)==0 ? "Error::TypeTiny::WrongNumberOfParameters"->throw(message => sprintf("Odd number of elements in %%s", %s)) : +{ @_[%d..$#_] };', + $name, + $i + 1, + $i, + $i, + $i, + $QUOTE->("$tc"), + $i, + ); +} + +sub _mkdefault +{ + my $param_options = shift; + my $default; + + if (exists $param_options->{default}) { + $default = $param_options->{default}; + if (ArrayRef->check($default) and not @$default) { + $default = '[]'; + } + elsif (HashRef->check($default) and not %$default) { + $default = '{}'; + } + elsif (Str->check($default)) { + $default = $QUOTE->($default); + } + elsif (Undef->check($default)) { + $default = 'undef'; + } + elsif (not CodeLike->check($default)) { + Error::TypeTiny::croak("Default expected to be string, coderef, undef, or reference to an empty hash or array"); + } + } + + $default; +} + +sub _deal_with_head_and_tail { + my $options = shift; + $options->{arg_fudge_factor} = 0; + $options->{arg_fudge_factor_head} = 0; + my @lines; + my %env; + + for my $position (qw/ head tail /) { + next unless defined $options->{$position}; + + $options->{$position} = [ (Types::Standard::Any) x (0+ $options->{$position}) ] + if !ref $options->{$position}; + + my $count = @{ $options->{$position} }; + $options->{arg_fudge_factor} += $count; + $options->{arg_fudge_factor_head} += $count if $position eq 'head'; + + push @lines => ( + $position eq 'head' + ? "\@head = splice(\@_, 0, $count);" + : "\@tail = splice(\@_, -$count);", + ); + + for my $i (0 .. $count-1) { + my $constraint = $options->{$position}[$i]; + $constraint = $options->{$position}[$i] = Types::Standard::Any + if !ref $constraint && $constraint eq 1; + Types::TypeTiny::TypeTiny->assert_valid($constraint); + + my $is_optional = 0; + $is_optional += grep $_->{uniq} == Optional->{uniq}, $constraint->parents; + Error::TypeTiny::croak("The $position may not contain optional parameters") if $is_optional; + + my $varname = sprintf('$%s[%d]', $position, $i); + my $display_var = $position eq 'head' + ? sprintf('$_[%d]', $i) + : sprintf('$_[%d]', $i-$count); + + if ($constraint->has_coercion and $constraint->coercion->can_be_inlined) + { + push @lines, sprintf( + '%s = do { %s };', + $varname, + $constraint->coercion->inline_coercion($varname), + ); + } + elsif ($constraint->has_coercion) + { + $env{'@coerce_'.$position}[$i] = $constraint->coercion->compiled_coercion; + push @lines, sprintf( + '%s = $coerce_%s[%d]->(%s);', + $varname, + $position, + $i, + $varname, + ); + } + + undef $Type::Tiny::ALL_TYPES{ $constraint->{uniq} }; + $Type::Tiny::ALL_TYPES{ $constraint->{uniq} } = $constraint; + + if ($constraint == Types::Standard::Any) + { + # don't really need to check! + } + elsif ($constraint->can_be_inlined) + { + push @lines, sprintf( + '(%s) or Type::Tiny::_failed_check(%d, %s, %s, varname => %s);', + $constraint->inline_check($varname), + $constraint->{uniq}, + $QUOTE->($constraint), + $varname, + $QUOTE->($display_var), + ); + } + else + { + $env{'@check_'.$position}[$i] = $constraint->compiled_check; + push @lines, sprintf( + '%s or Type::Tiny::_failed_check(%d, %s, %s, varname => %s);', + sprintf(sprintf '$check_%s[%d]->(%s)', $position, $i, $varname), + $constraint->{uniq}, + $QUOTE->($constraint), + $varname, + $QUOTE->($display_var), + ); + } + } + } + + if (@lines) { + unshift @lines => sprintf( + '"Error::TypeTiny::WrongNumberOfParameters"->throw("Not enough parameters to satisfy required head and tail of parameter list") if @_ < %d;', + $options->{arg_fudge_factor}, + ); + unshift @lines, 'my (@head, @tail);'; + } + + \%env, @lines; +} + +sub compile +{ + my (@code, %env); + + push @code, '#placeholder', '#placeholder'; # @code[0,1] + + my %options; + while (ref($_[0]) eq "HASH" && !$_[0]{slurpy}) { + %options = (%options, %{+shift}); + } + + my $arg = -1; + my $saw_slurpy = 0; + my $min_args = 0; + my $max_args = 0; + my $saw_opt = 0; + + my $return_list = '@_'; + $code[0] = 'my (%tmp, $tmp);'; + PARAM: for my $param (@_) { + if (HashRef->check($param)) { + $code[0] = 'my (@R, %tmp, $tmp, $dtmp);'; + $return_list = '@R'; + last PARAM; + } + elsif (not Bool->check($param)) { + if ($param->has_coercion) { + $code[0] = 'my (@R, %tmp, $tmp, $dtmp);'; + $return_list = '@R'; + last PARAM; + } + } + } + + my ($extra_env, @extra_lines) = _deal_with_head_and_tail(\%options); + if (@extra_lines) { + push @code, @extra_lines; + %env = (%$extra_env, %env); + $return_list = '(@head, @R, @tail)'; + } + + my @default_indices; + my @default_values; + + while (@_) + { + ++$arg; + my $constraint = shift; + my $is_optional; + my $really_optional; + my $is_slurpy; + my $varname; + + my $param_options = {}; + $param_options = shift if HashRef->check($_[0]) && !exists $_[0]{slurpy}; + my $default = _mkdefault($param_options); + + if ($param_options->{optional} or defined $default) { + $is_optional = 1; + } + + if (Bool->check($constraint)) + { + $constraint = $constraint ? Any : Optional[Any]; + } + + if (HashRef->check($constraint) and exists $constraint->{slurpy}) + { + $constraint = to_TypeTiny( + $constraint->{slurpy} + or Error::TypeTiny::croak("Slurpy parameter malformed") + ); + push @code, + $constraint->is_a_type_of(Dict) ? _mkslurpy('$_', '%', $constraint => $arg) : + $constraint->is_a_type_of(Map) ? _mkslurpy('$_', '%', $constraint => $arg) : + $constraint->is_a_type_of(Tuple) ? _mkslurpy('$_', '@', $constraint => $arg) : + $constraint->is_a_type_of(HashRef) ? _mkslurpy('$_', '%', $constraint => $arg) : + $constraint->is_a_type_of(ArrayRef) ? _mkslurpy('$_', '@', $constraint => $arg) : + Error::TypeTiny::croak("Slurpy parameter not of type HashRef or ArrayRef"); + $varname = '$_'; + $is_slurpy++; + $saw_slurpy++; + } + else + { + Error::TypeTiny::croak("Parameter following slurpy parameter") if $saw_slurpy; + + $is_optional += grep $_->{uniq} == Optional->{uniq}, $constraint->parents; + $really_optional = $is_optional && $constraint->parent && $constraint->parent->{uniq} eq Optional->{uniq} && $constraint->type_parameter; + + if (ref $default) { + $env{'@default'}[$arg] = $default; + push @code, sprintf( + '$dtmp = ($#_ < %d) ? $default[%d]->() : $_[%d];', + $arg, + $arg, + $arg, + ); + $saw_opt++; + $max_args++; + $varname = '$dtmp'; + } + elsif (defined $default) { + push @code, sprintf( + '$dtmp = ($#_ < %d) ? %s : $_[%d];', + $arg, + $default, + $arg, + ); + $saw_opt++; + $max_args++; + $varname = '$dtmp'; + } + elsif ($is_optional) + { + push @code, sprintf( + 'return %s if $#_ < %d;', + $return_list, + $arg, + ); + $saw_opt++; + $max_args++; + $varname = sprintf '$_[%d]', $arg; + } + else + { + Error::TypeTiny::croak("Non-Optional parameter following Optional parameter") if $saw_opt; + $min_args++; + $max_args++; + $varname = sprintf '$_[%d]', $arg; + } + } + + if ($constraint->has_coercion and $constraint->coercion->can_be_inlined) + { + push @code, sprintf( + '$tmp%s = %s;', + ($is_optional ? '{x}' : ''), + $constraint->coercion->inline_coercion($varname) + ); + $varname = '$tmp'.($is_optional ? '{x}' : ''); + } + elsif ($constraint->has_coercion) + { + $env{'@coerce'}[$arg] = $constraint->coercion->compiled_coercion; + push @code, sprintf( + '$tmp%s = $coerce[%d]->(%s);', + ($is_optional ? '{x}' : ''), + $arg, + $varname, + ); + $varname = '$tmp'.($is_optional ? '{x}' : ''); + } + + # unweaken the constraint in the cache + undef $Type::Tiny::ALL_TYPES{ $constraint->{uniq} }; + $Type::Tiny::ALL_TYPES{ $constraint->{uniq} } = $constraint; + + if ($constraint->can_be_inlined) + { + push @code, sprintf( + '(%s) or Type::Tiny::_failed_check(%d, %s, %s, varname => %s);', + $really_optional + ? $constraint->type_parameter->inline_check($varname) + : $constraint->inline_check($varname), + $constraint->{uniq}, + $QUOTE->($constraint), + $varname, + $is_slurpy ? 'q{$SLURPY}' : sprintf('q{$_[%d]}', $arg+$options{arg_fudge_factor_head}), + ); + } + else + { + $env{'@check'}[$arg] = $really_optional + ? $constraint->type_parameter->compiled_check + : $constraint->compiled_check; + push @code, sprintf( + '%s or Type::Tiny::_failed_check(%d, %s, %s, varname => %s);', + sprintf(sprintf '$check[%d]->(%s)', $arg, $varname), + $constraint->{uniq}, + $QUOTE->($constraint), + $varname, + $is_slurpy ? 'q{$SLURPY}' : sprintf('q{$_[%d]}', $arg+$options{arg_fudge_factor_head}), + ); + } + + unless ($return_list eq '@_') { + push @code, sprintf 'push @R, %s;', $varname; + } + } + + my $thang = 'scalar(@_)'; + + if ($min_args == $max_args and not $saw_slurpy) + { + $code[1] = sprintf( + '"Error::TypeTiny::WrongNumberOfParameters"->throw(got => %s, minimum => %d, maximum => %d) if @_ != %d;', + $thang, + $min_args + $options{arg_fudge_factor}, + $max_args + $options{arg_fudge_factor}, + $min_args + $options{arg_fudge_factor}, + ); + } + elsif ($min_args < $max_args and not $saw_slurpy) + { + $code[1] = sprintf( + '"Error::TypeTiny::WrongNumberOfParameters"->throw(got => %s, minimum => %d, maximum => %d) if @_ < %d || @_ > %d;', + $thang, + $min_args + $options{arg_fudge_factor}, + $max_args + $options{arg_fudge_factor}, + $min_args + $options{arg_fudge_factor}, + $max_args + $options{arg_fudge_factor}, + ); + } + elsif ($min_args and $saw_slurpy) + { + $code[1] = sprintf( + '"Error::TypeTiny::WrongNumberOfParameters"->throw(got => %s, minimum => %d) if @_ < %d;', + $thang, + $min_args + $options{arg_fudge_factor}, + $min_args + $options{arg_fudge_factor}, + ); + } + + push @code, $return_list; + + my $source = "sub { no warnings; ".join("\n", @code)." };"; + + return $source if $options{want_source}; + + my $closure = eval_closure( + source => $source, + description => $options{description}||sprintf("parameter validation for '%s'", $options{subname}||[caller(1+($options{caller_level}||0))]->[3] || '__ANON__'), + environment => \%env, + ); + + return { + min_args => $options{arg_fudge_factor}+($min_args||0), + max_args => $saw_slurpy ? undef : $options{arg_fudge_factor}+($max_args||0), + closure => $closure, + source => $source, + environment => \%env, + } if $options{want_details}; + + return $closure; +} + +sub compile_named +{ + my (@code, %env); + + push @code, 'my (%R, %tmp, $tmp);'; + push @code, '#placeholder'; # $code[1] + + my %options; + while (ref($_[0]) eq "HASH" && !$_[0]{slurpy}) { + %options = (%options, %{+shift}); + } + my $arg = -1; + my $had_slurpy; + + my ($extra_env, @extra_lines) = _deal_with_head_and_tail(\%options); + if (@extra_lines) { + push @code, @extra_lines; + %env = (%$extra_env, %env); + } + + push @code, 'my %in = ((@_==1) && ref($_[0]) eq "HASH") ? %{$_[0]} : (@_ % 2) ? "Error::TypeTiny::WrongNumberOfParameters"->throw(message => "Odd number of elements in hash") : @_;'; + my @names; + + while (@_) { + ++$arg; + my ($name, $constraint) = splice(@_, 0, 2); + push @names, $name; + + my $is_optional; + my $really_optional; + my $is_slurpy; + my $varname; + my $default; + + Str->check($name) + or Error::TypeTiny::croak("Expected parameter name as string, got $name"); + + my $param_options = {}; + $param_options = shift @_ if HashRef->check($_[0]) && !exists $_[0]{slurpy}; + $default = _mkdefault($param_options); + + if ($param_options->{optional} or defined $default) { + $is_optional = 1; + } + + if (Bool->check($constraint)) + { + $constraint = $constraint ? Any : Optional[Any]; + } + + if (HashRef->check($constraint) and exists $constraint->{slurpy}) + { + $constraint = to_TypeTiny($constraint->{slurpy}); + ++$is_slurpy; + ++$had_slurpy; + } + else + { + $is_optional += grep $_->{uniq} == Optional->{uniq}, $constraint->parents; + $really_optional = $is_optional && $constraint->parent && $constraint->parent->{uniq} eq Optional->{uniq} && $constraint->type_parameter; + + $constraint = $constraint->type_parameter if $really_optional; + } + + if (ref $default) { + $env{'@default'}[$arg] = $default; + push @code, sprintf( + 'exists($in{%s}) or $in{%s} = $default[%d]->();', + $QUOTE->($name), + $QUOTE->($name), + $arg, + ); + } + elsif (defined $default) { + push @code, sprintf( + 'exists($in{%s}) or $in{%s} = %s;', + $QUOTE->($name), + $QUOTE->($name), + $default, + ); + } + elsif (not $is_optional||$is_slurpy) { + push @code, sprintf( + 'exists($in{%s}) or "Error::TypeTiny::WrongNumberOfParameters"->throw(message => sprintf "Missing required parameter: %%s", %s);', + $QUOTE->($name), + $QUOTE->($name), + ); + } + + my $need_to_close_if = 0; + + if ($is_slurpy) { + $varname = '\\%in'; + } + elsif ($is_optional) { + push @code, sprintf('if (exists($in{%s})) {', $QUOTE->($name)); + push @code, sprintf('$tmp = delete($in{%s});', $QUOTE->($name)); + $varname = '$tmp'; + ++$need_to_close_if; + } + else { + push @code, sprintf('$tmp = delete($in{%s});', $QUOTE->($name)); + $varname = '$tmp'; + } + + if ($constraint->has_coercion) { + if ($constraint->coercion->can_be_inlined) { + push @code, sprintf( + '$tmp = %s;', + $constraint->coercion->inline_coercion($varname) + ); + } + else { + $env{'@coerce'}[$arg] = $constraint->coercion->compiled_coercion; + push @code, sprintf( + '$tmp = $coerce[%d]->(%s);', + $arg, + $varname, + ); + } + $varname = '$tmp'; + } + + if ($constraint->can_be_inlined) + { + push @code, sprintf( + '(%s) or Type::Tiny::_failed_check(%d, %s, %s, varname => %s);', + $constraint->inline_check($varname), + $constraint->{uniq}, + $QUOTE->($constraint), + $varname, + $is_slurpy ? 'q{$SLURPY}' : sprintf('q{$_{%s}}', $QUOTE->($name)), + ); + } + else + { + $env{'@check'}[$arg] = $constraint->compiled_check; + push @code, sprintf( + '%s or Type::Tiny::_failed_check(%d, %s, %s, varname => %s);', + sprintf(sprintf '$check[%d]->(%s)', $arg, $varname), + $constraint->{uniq}, + $QUOTE->($constraint), + $varname, + $is_slurpy ? 'q{$SLURPY}' : sprintf('q{$_{%s}}', $QUOTE->($name)), + ); + } + + push @code, sprintf('$R{%s} = %s;', $QUOTE->($name), $varname); + + push @code, '}' if $need_to_close_if; + } + + if (!$had_slurpy) { + push @code, 'keys(%in) and "Error::TypeTiny"->throw(message => sprintf "Unrecognized parameter%s: %s", keys(%in)>1?"s":"", Type::Params::english_list(sort keys %in));' + } + + if ($options{named_to_list}) { + Error::TypeTiny::croak("named_to_list option cannot be used with slurpy") if $had_slurpy; + my @order = ref $options{named_to_list} ? @{$options{named_to_list}} : @names; + push @code, sprintf('@R{%s}', join ",", map $QUOTE->($_), @order); + } + elsif ($options{bless}) { + push @code, sprintf('bless \\%%R, %s;', $QUOTE->($options{bless})); + } + elsif (ArrayRef->check($options{class})) { + push @code, sprintf('(%s)->%s(\\%%R);', $QUOTE->($options{class}[0]), $options{class}[1]||'new'); + } + elsif ($options{class}) { + push @code, sprintf('(%s)->%s(\\%%R);', $QUOTE->($options{class}), $options{constructor}||'new'); + } + else { + push @code, '\\%R;'; + } + + if ($options{head} || $options{tail}) { + $code[-1] = 'my @R = ' . $code[-1]; + push @code, 'unshift @R, @head;' if $options{head}; + push @code, 'push @R, @tail;' if $options{tail}; + push @code, '@R;'; + } + + my $source = "sub { no warnings; ".join("\n", @code)." };"; + return $source if $options{want_source}; + + my $closure = eval_closure( + source => $source, + description => $options{description}||sprintf("parameter validation for '%s'", $options{subname}||[caller(1+($options{caller_level}||0))]->[3] || '__ANON__'), + environment => \%env, + ); + + my $max_args = undef; + if (!$had_slurpy) { + $max_args = 2 * ($arg+1); + $max_args += $options{arg_fudge_factor}; + } + + return { + min_args => $options{arg_fudge_factor}, + max_args => $max_args, + closure => $closure, + source => $source, + environment => \%env, + } if $options{want_details}; + + return $closure; +} + +my %klasses; +my $kls_id = 0; +my $has_cxsa; +my $want_cxsa; +sub _mkklass +{ + my $klass = sprintf('%s::OO::Klass%d', __PACKAGE__, ++$kls_id); + + if (!defined $has_cxsa or !defined $want_cxsa) { + $has_cxsa = !! eval { + require Class::XSAccessor; + 'Class::XSAccessor'->VERSION('1.17'); # exists_predicates, June 2013 + 1; + }; + + $want_cxsa = + $ENV{PERL_TYPE_PARAMS_XS} ? 'XS' : + exists($ENV{PERL_TYPE_PARAMS_XS}) ? 'PP' : + $has_cxsa ? 'XS' : 'PP'; + + if ($want_cxsa eq 'XS' and not $has_cxsa) { + Error::TypeTiny::croak("Cannot load Class::XSAccessor"); # uncoverable statement + } + } + + if ($want_cxsa eq 'XS') { + eval { + 'Class::XSAccessor'->import( + redefine => 1, + class => $klass, + getters => { map { defined($_->{getter}) ? ($_->{getter} => $_->{slot}) : () } values %{$_[0]} }, + exists_predicates => { map { defined($_->{predicate}) ? ($_->{predicate} => $_->{slot}) : () } values %{$_[0]} }, + ); + 1; + } ? return($klass) : die($@); + } + + for my $attr (values %{$_[0]}) { + defined($attr->{getter}) and eval sprintf( + 'package %s; sub %s { $_[0]{%s} }; 1', + $klass, + $attr->{getter}, + $attr->{slot}, + ) || die($@); + defined($attr->{predicate}) and eval sprintf( + 'package %s; sub %s { exists $_[0]{%s} }; 1', + $klass, + $attr->{predicate}, + $attr->{slot}, + ) || die($@); + } + + $klass; +} + +sub compile_named_oo +{ + my %options; + while (ref($_[0]) eq "HASH" && !$_[0]{slurpy}) { + %options = (%options, %{+shift}); + } + my @rest = @_; + + my %attribs; + while (@_) { + my ($name, $type) = splice(@_, 0, 2); + my $opts = (HashRef->check($_[0]) && !exists $_[0]{slurpy}) ? shift(@_) : {}; + + my $is_optional = 0+!! $opts->{optional}; + $is_optional += grep $_->{uniq} == Optional->{uniq}, $type->parents; + + my $getter = exists($opts->{getter}) + ? $opts->{getter} + : $name; + + Error::TypeTiny::croak("Bad accessor name: $getter") + unless $getter =~ /\A[A-Za-z][A-Za-z0-9_]*\z/; + + my $predicate = exists($opts->{predicate}) + ? ($opts->{predicate} eq '1' ? "has_$getter" : $opts->{predicate} eq '0' ? undef : $opts->{predicate}) + : ($is_optional ? "has_$getter" : undef); + + $attribs{$name} = { + slot => $name, + getter => $getter, + predicate => $predicate, + }; + } + + my $kls = join '//', + map sprintf('%s*%s*%s', $attribs{$_}{slot}, $attribs{$_}{getter}, $attribs{$_}{predicate}||'0'), + sort keys %attribs; + + $klasses{$kls} ||= _mkklass(\%attribs); + + compile_named({ %options, bless => $klasses{$kls} }, @rest); +} + +# Would be faster to inline this into validate and validate_named, but +# that would complicate them. :/ +sub _mk_key { + local $_; + join ':', map { + HashRef->check($_) ? do { my %h = %$_; sprintf('{%s}', _mk_key(map {; $_ => $h{$_} } sort keys %h)) } : + TypeTiny->check($_) ? sprintf('TYPE=%s', $_->{uniq}) : + Ref->check($_) ? sprintf('REF=%s', refaddr($_)) : + Undef->check($_) ? sprintf('UNDEF') : + $QUOTE->($_) + } @_; +} + +my %compiled; +sub validate +{ + my $arg = shift; + my $sub = ($compiled{_mk_key(@_)} ||= compile( + { caller_level => 1, %{ref($_[0])eq'HASH'?shift(@_):+{}} }, + @_, + )); + @_ = @$arg; + goto $sub; +} + +my %compiled_named; +sub validate_named +{ + my $arg = shift; + my $sub = ($compiled_named{_mk_key(@_)} ||= compile_named( + { caller_level => 1, %{ref($_[0])eq'HASH'?shift(@_):+{}} }, + @_, + )); + @_ = @$arg; + goto $sub; +} + +sub multisig +{ + my %options = (ref($_[0]) eq "HASH" && !$_[0]{slurpy}) ? %{+shift} : (); + $options{message} ||= "Parameter validation failed"; + $options{description} ||= sprintf("parameter validation for '%s'", [caller(1+($options{caller_level}||0))]->[3] || '__ANON__'); + for my $key ( qw[ message description ] ) + { + StringLike->check($options{$key}) + or Error::TypeTiny::croak("Option '$key' expected to be string or stringifiable object"); + } + + my @multi = map { + CodeLike->check($_) ? { closure => $_ } : + ArrayLike->check($_) ? compile({ want_details => 1 }, @$_) : + $_; + } @_; + + my @code = 'sub { my $r; '; + + for my $i (0 .. $#multi) + { + my $flag = sprintf('${^TYPE_PARAMS_MULTISIG} = %d', $i); + my $sig = $multi[$i]; + my @cond; + push @cond, sprintf('@_ >= %s', $sig->{min_args}) if defined $sig->{min_args}; + push @cond, sprintf('@_ <= %s', $sig->{max_args}) if defined $sig->{max_args}; + if (defined $sig->{max_args} and defined $sig->{min_args}) { + @cond = sprintf('@_ == %s', $sig->{min_args}) + if $sig->{max_args} == $sig->{min_args}; + } + push @code, sprintf('if (%s){', join(' and ', @cond)) if @cond; + push @code, sprintf('eval { $r = [ $multi[%d]{closure}->(@_) ]; %s };', $i, $flag); + push @code, 'return(@$r) if $r;'; + push @code, '}' if @cond; + } + + push @code, sprintf('"Error::TypeTiny"->throw(message => "%s");', quotemeta("$options{message}")); + push @code, '}'; + + eval_closure( + source => \@code, + description => $options{description}, + environment => { '@multi' => \@multi }, + ); +} + +sub wrap_methods { + my $opts = ref($_[0]) eq 'HASH' ? shift : {}; + $opts->{caller} ||= caller; + $opts->{skip_invocant} = 1; + $opts->{use_can} = 1; + unshift @_, $opts; + goto \&_wrap_subs; +} + +sub wrap_subs { + my $opts = ref($_[0]) eq 'HASH' ? shift : {}; + $opts->{caller} ||= caller; + $opts->{skip_invocant} = 0; + $opts->{use_can} = 0; + unshift @_, $opts; + goto \&_wrap_subs; +} + +sub _wrap_subs { + my $opts = shift; + my $subname = + eval { require Sub::Util } ? \&Sub::Util::set_subname : + eval { require Sub::Name } ? \&Sub::Name::subname : 0; + while (@_) { + my ($name, $proto) = splice @_, 0, 2; + my $fullname = ($name =~ /::/) ? $name : sprintf('%s::%s', $opts->{caller}, $name); + my $orig = do { + no strict 'refs'; + exists &$fullname + ? \&$fullname + : $opts->{use_can} ? ($opts->{caller}->can($name)||sub{}) : sub {} + }; + my $check = ref($proto) eq 'CODE' ? $proto : undef; + my $co = { description => "parameter validation for '$name'" }; + my $new = $opts->{skip_invocant} + ? sub { my $s = shift; $check ||= compile($co, @$proto); @_ = ($s, &$check); goto $orig } + : sub { $check ||= compile($co, @$proto); @_ = (&$check); goto $orig }; + $new = $subname->($fullname, $new) if $subname; + no strict 'refs'; + no warnings 'redefine'; + *$fullname = $new; + } + 1; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords evals invocant + +=head1 NAME + +Type::Params - Params::Validate-like parameter validation using Type::Tiny type constraints and coercions + +=head1 SYNOPSIS + + use v5.12; + use strict; + use warnings; + + package Horse { + use Moo; + use Types::Standard qw( Object ); + use Type::Params qw( compile ); + use namespace::autoclean; + + ...; # define attributes, etc + + sub add_child { + state $check = compile( Object, Object ); # method signature + + my ($self, $child) = $check->(@_); # unpack @_ + push @{ $self->children }, $child; + + return $self; + } + } + + package main; + + my $boldruler = Horse->new; + + $boldruler->add_child( Horse->new ); + + $boldruler->add_child( 123 ); # dies (123 is not an Object!) + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +This documents the details of the L package. +L is a better starting place if you're new. + +Type::Params uses L constraints to validate the parameters to a +sub. It takes the slightly unorthodox approach of separating validation +into two stages: + +=over + +=item 1. + +Compiling the parameter specification into a coderef; then + +=item 2. + +Using the coderef to validate parameters. + +=back + +The first stage is slow (it might take a couple of milliseconds), but you +only need to do it the first time the sub is called. The second stage is +fast; according to my benchmarks faster even than the XS version of +L. + +If you're using a modern version of Perl, you can use the C keyword +which was a feature added to Perl in 5.10. If you're stuck on Perl 5.8, the +example from the SYNOPSIS could be rewritten as: + + my $add_child_check; + sub add_child { + $add_child_check ||= compile( Object, Object ); + + my ($self, $child) = $add_child_check->(@_); # unpack @_ + push @{ $self->children }, $child; + + return $self; + } + +Not quite as neat, but not awful either. + +If you don't like the two step, there's a shortcut reducing it to one step: + + use Type::Params qw( validate ); + + sub add_child { + my ($self, $child) = validate(\@_, Object, Object); + push @{ $self->children }, $child; + return $self; + } + +Type::Params has a few tricks up its sleeve to make sure performance doesn't +suffer too much with the shortcut, but it's never going to be as fast as the +two stage compile/execute. + +=head2 Functions + +=head3 C<< compile(@spec) >> + +Given specifications for positional parameters, compiles a coderef +that can check against them. + +The generalized form of specifications for positional parameters is: + + state $check = compile( + \%general_opts, + $type_for_arg_1, \%opts_for_arg_1, + $type_for_arg_2, \%opts_for_arg_2, + $type_for_arg_3, \%opts_for_arg_3, + ..., + slurpy($slurpy_type), + ); + +If a hashref of options is empty, it can simply be omitted. Much of the +time, you won't need to specify any options. + + # In this example, we omit all the hashrefs + # + my $check = compile( + Str, + Int, + Optional[ArrayRef], + ); + + my ($str, $int, $arr) = $check->("Hello", 42, []); # ok + my ($str, $int, $arr) = $check->("", -1); # ok + my ($str, $int, $arr) = $check->("", -1, "bleh"); # dies + +The coderef returned (i.e. C<< $check >>) will check the arguments +passed to it conform to the spec (coercing them if appropriate), +and return them as a list if they do. If they don't, it will throw +an exception. + +The first hashref, before any type constraints, is for general options +which affect the entire compiled coderef. Currently supported general +options are: + +=over + +=item C<< head >> B<< Int|ArrayRef[TypeTiny] >> + +Parameters to shift off C<< @_ >> before doing the main type check. +These parameters may also be checked, and cannot be optional or slurpy. +They may not have defaults. + + my $check = compile( + { head => [ Int, Int ] }, + Str, + Str, + ); + + # ... is basically the same as... + + my $check = compile( + Int, + Int, + Str, + Str, + ); + +A number may be given if you do not care to check types: + + my $check = compile( + { head => 2 }, + Str, + Str, + ); + + # ... is basically the same as... + + my $check = compile( + Any, + Any, + Str, + Str, + ); + +This is mostly useless for C, but can be useful for +C and C. + +=item C<< tail >> B<< Int|ArrayRef[TypeTiny] >> + +Similar to C, but pops parameters off the end of C<< @_ >> instead. +This is actually useful for C because it allows you to sneak in +some required parameters I a slurpy or optional parameter. + + my $check = compile( + { tail => [ CodeRef ] }, + slurpy ArrayRef[Str], + ); + + my ($strings, $coderef) = $check->("foo", "bar", sub { ... }); + +=item C<< want_source >> B<< Bool >> + +Instead of returning a coderef, return Perl source code string. Handy +for debugging. + +=item C<< want_details >> B<< Bool >> + +Instead of returning a coderef, return a hashref of stuff including the +coderef. This is mostly for people extending Type::Params and I won't go +into too many details about what else this hashref contains. + +=item C<< description >> B<< Str >> + +Description of the coderef that will show up in stack traces. Defaults to +"parameter validation for X" where X is the caller sub name. + +=item C<< subname >> B<< Str >> + +If you wish to use the default description, but need to change the sub name, +use this. + +=item C<< caller_level >> B<< Int >> + +If you wish to use the default description, but need to change the caller +level for detecting the sub name, use this. + +=back + +The types for each parameter may be any L type constraint, or +anything that Type::Tiny knows how to coerce into a Type::Tiny type +constraint, such as a MooseX::Types type constraint or a coderef. + +Type coercions are automatically applied for all types that have +coercions. + +If you wish to avoid coercions for a type, use Type::Tiny's +C method. + + my $check = compile( + Int, + ArrayRef->of(Bool)->no_coercions, + ); + +Note that having any coercions in a specification, even if they're not +used in a particular check, will slightly slow down C<< $check >> +because it means that C<< $check >> can't just check C<< @_ >> and return +it unaltered if it's valid — it needs to build a new array to return. + +Optional parameters can be given using the B<< Optional[] >> type +constraint. In the example above, the third parameter is optional. +If it's present, it's required to be an arrayref, but if it's absent, +it is ignored. + +Optional parameters need to be I required parameters in the +spec. + +An alternative way to specify optional parameters is using a parameter +options hashref. + + my $check = compile( + Str, + Int, + ArrayRef, { optional => 1 }, + ); + +The following parameter options are supported: + +=over + +=item C<< optional >> B<< Bool >> + +This is an alternative way of indicating that a parameter is optional. + + state $check = compile( + Int, + Int, { optional => 1 }, + Optional[Int], + ); + +The two are not I equivalent. The exceptions thrown will +differ in the type name they mention. (B versus B<< Optional[Int] >>.) + +=item C<< default >> B<< CodeRef|Ref|Str|Undef >> + +A default may be provided for a parameter. + + state $check = compile( + Int, + Int, { default => "666" }, + Int, { default => "999" }, + ); + +Supported defaults are any strings (including numerical ones), C, +and empty hashrefs and arrayrefs. Non-empty hashrefs and arrayrefs are +I<< not allowed as defaults >>. + +Alternatively, you may provide a coderef to generate a default value: + + state $check = compile( + Int, + Int, { default => sub { 6 * 111 } }, + Int, { default => sub { 9 * 111 } }, + ); + +That coderef may generate any value, including non-empty arrayrefs and +non-empty hashrefs. For undef, simple strings, numbers, and empty +structures, avoiding using a coderef will make your parameter processing +faster. + +The default I be validated against the type constraint, and +potentially coerced. + +Note that having any defaults in a specification, even if they're not +used in a particular check, will slightly slow down C<< $check >> +because it means that C<< $check >> can't just check C<< @_ >> and return +it unaltered if it's valid — it needs to build a new array to return. + +=back + +As a special case, the numbers 0 and 1 may be used as shortcuts for +B<< Optional[Any] >> and B<< Any >>. + + # Positional parameters + state $check = compile(1, 0, 0); + my ($foo, $bar, $baz) = $check->(@_); # $bar and $baz are optional + +After any required and optional parameters may be a slurpy parameter. +Any additional arguments passed to C<< $check >> will be slurped into +an arrayref or hashref and checked against the slurpy parameter. +Defaults are not supported for slurpy parameters. + +Example with a slurpy ArrayRef: + + sub xyz { + state $check = compile(Int, Int, slurpy ArrayRef[Int]); + my ($foo, $bar, $baz) = $check->(@_); + } + + xyz(1..5); # $foo = 1 + # $bar = 2 + # $baz = [ 3, 4, 5 ] + +Example with a slurpy HashRef: + + my $check = compile( + Int, + Optional[Str], + slurpy HashRef[Int], + ); + + my ($x, $y, $z) = $check->(1, "y", foo => 666, bar => 999); + # $x is 1 + # $y is "y" + # $z is { foo => 666, bar => 999 } + +Any type constraints derived from B or B should work, +but a type does need to inherit from one of those because otherwise +Type::Params cannot know what kind of structure to slurp the remaining +arguments into. + +B<< slurpy Any >> is also allowed as a special case, and is treated as +B<< slurpy ArrayRef >>. + +From Type::Params 1.005000 onwards, slurpy hashrefs can be passed in as a +true hashref (which will be shallow cloned) rather than key-value pairs. + + sub xyz { + state $check = compile(Int, slurpy HashRef); + my ($num, $hr) = $check->(@_); + ... + } + + xyz( 5, foo => 1, bar => 2 ); # works + xyz( 5, { foo => 1, bar => 2 } ); # works from 1.005000 + +This feature is only implemented for slurpy hashrefs, not slurpy arrayrefs. + +Note that having a slurpy parameter will slightly slow down C<< $check >> +because it means that C<< $check >> can't just check C<< @_ >> and return +it unaltered if it's valid — it needs to build a new array to return. + +=head3 C<< validate(\@_, @spec) >> + +This example of C: + + sub foo { + state $check = compile(@spec); + my @args = $check->(@_); + ...; + } + +Can be written using C as: + + sub foo { + my @args = validate(\@_, @spec); + ...; + } + +Performance using C will I beat C though. + +=head3 C<< compile_named(@spec) >> + +C is a variant of C for named parameters instead +of positional parameters. + +The format of the specification is changed to include names for each +parameter: + + state $check = compile_named( + \%general_opts, + foo => $type_for_foo, \%opts_for_foo, + bar => $type_for_bar, \%opts_for_bar, + baz => $type_for_baz, \%opts_for_baz, + ..., + extra => slurpy($slurpy_type), + ); + +The C<< $check >> coderef will return a hashref. + + my $check = compile_named( + foo => Int, + bar => Str, { default => "hello" }, + ); + + my $args = $check->(foo => 42); + # $args->{foo} is 42 + # $args->{bar} is "hello" + +The C<< %general_opts >> hash supports the same options as C +plus a few additional options: + +=over + +=item C<< class >> B<< ClassName >> + +The check coderef will, instead of returning a simple hashref, call +C<< $class->new($hashref) >> and return the result. + +=item C<< constructor >> B<< Str >> + +Specifies an alternative method name instead of C for the C +option described above. + +=item C<< class >> B<< Tuple[ClassName, Str] >> + +Shortcut for declaring both the C and C options at once. + +=item C<< bless >> B<< ClassName >> + +Like C, but bypass the constructor and directly bless the hashref. + +=item C<< named_to_list >> B<< Bool >> + +Instead of returning a hashref, return a hash slice. + + myfunc(bar => "x", foo => "y"); + + sub myfunc { + state $check = compile_named( + { named_to_list => 1 }, + foo => Str, { optional => 1 }, + bar => Str, { optional => 1 }, + ); + my ($foo, $bar) = $check->(@_); + ...; ## $foo is "y" and $bar is "x" + } + +The order of keys for the hash slice is the same as the order of the names +passed to C. For missing named parameters, C is +returned in the list. + +Basically in the above example, C takes named parameters, but +receieves positional parameters. + +=item C<< named_to_list >> B<< ArrayRef[Str] >> + +As above, but explicitly specify the keys of the hash slice. + +=back + +Like C, the numbers 0 and 1 may be used as shortcuts for +B<< Optional[Any] >> and B<< Any >>. + + state $check = compile_named(foo => 1, bar => 0, baz => 0); + my $args = $check->(@_); # $args->{bar} and $args->{baz} are optional + +Slurpy parameters are slurped into a nested hashref. + + my $check = compile( + foo => Str, + bar => Optional[Str], + extra => slurpy HashRef[Str], + ); + my $args = $check->(foo => "aaa", quux => "bbb"); + + print $args->{foo}, "\n"; # aaa + print $args->{extra}{quux}, "\n"; # bbb + +B<< slurpy Any >> is treated as B<< slurpy HashRef >>. + +The C and C options are supported. This allows for a +mixture of positional and named arguments, as long as the positional +arguments are non-optional and at the head and tail of C<< @_ >>. + + my $check = compile( + { head => [ Int, Int ], tail => [ CodeRef ] }, + foo => Str, + bar => Str, + baz => Str, + ); + + my ($int1, $int2, $args, $coderef) + = $check->( 666, 999, foo=>'x', bar=>'y', baz=>'z', sub {...} ); + + say $args->{bar}; # 'y' + +This can be combined with C: + + my $check = compile( + { head => [ Int, Int ], tail => [ CodeRef ], named_to_list => 1 }, + foo => Str, + bar => Str, + baz => Str, + ); + + my ($int1, $int2, $foo, $bar, $baz, $coderef) + = $check->( 666, 999, foo=>'x', bar=>'y', baz=>'z', sub {...} ); + + say $bar; # 'y' + +=head3 C<< validate_named(\@_, @spec) >> + +Like C has C, C has C. +Just like C, it's the slower way to do things, so stick with +C. + +=head3 C<< compile_named_oo(@spec) >> + +Here's a quick example function: + + sub add_contact_to_database { + state $check = compile_named( + dbh => Object, + id => Int, + name => Str, + ); + my $arg = $check->(@_); + + my $sth = $arg->{db}->prepare('INSERT INTO contacts VALUES (?, ?)'); + $sth->execute($arg->{id}, $arg->{name}); + } + +Looks simple, right? Did you spot that it will always die with an error +message I<< Can't call method "prepare" on an undefined value >>? + +This is because we defined a parameter called 'dbh' but later tried to +refer to it as C<< $arg{db} >>. Here, Perl gives us a pretty clear +error, but sometimes the failures will be far more subtle. Wouldn't it +be nice if instead we could do this? + + sub add_contact_to_database { + state $check = compile_named_oo( + dbh => Object, + id => Int, + name => Str, + ); + my $arg = $check->(@_); + + my $sth = $arg->dbh->prepare('INSERT INTO contacts VALUES (?, ?)'); + $sth->execute($arg->id, $arg->name); + } + +If we tried to call C<< $arg->db >>, it would fail because there was +no such method. + +Well, that's exactly what C does. + +As well as giving you nice protection against mistyped parameter names, +It also looks kinda pretty, I think. Hash lookups are a little faster +than method calls, of course (though Type::Params creates the methods +using L if it's installed, so they're still pretty +fast). + +An optional parameter C will also get a nifty C<< $arg->has_foo >> +predicate method. Yay! + +C gives you some extra options for parameters. + + sub add_contact_to_database { + state $check = compile_named_oo( + dbh => Object, + id => Int, { default => '0', getter => 'identifier' }, + name => Str, { optional => 1, predicate => 'has_name' }, + ); + my $arg = $check->(@_); + + my $sth = $arg->dbh->prepare('INSERT INTO contacts VALUES (?, ?)'); + $sth->execute($arg->identifier, $arg->name) if $arg->has_name; + } + +=over + +=item C<< getter >> B<< Str >> + +The C option lets you choose the method name for getting the +argument value. + +=item C<< predicate >> B<< Str >> + +The C option lets you choose the method name for checking +the existence of an argument. By setting an explicit predicate method +name, you can force a predicate method to be generated for non-optional +arguments. + +=back + +The objects returned by C are blessed into lightweight +classes which have been generated on the fly. Don't expect the names of +the classes to be stable or predictable. It's probably a bad idea to be +checking C, C, or C on any of these objects. If you're +doing that, you've missed the point of them. + +They don't have any constructor (C method). The C<< $check >> +coderef effectively I the constructor. + +=head3 C<< validate_named_oo(\@_, @spec) >> + +This function doesn't even exist. :D + +=head3 C<< multisig(@alternatives) >> + +Type::Params can export a C function that compiles multiple +alternative signatures into one, and uses the first one that works: + + state $check = multisig( + [ Int, ArrayRef ], + [ HashRef, Num ], + [ CodeRef ], + ); + + my ($int, $arrayref) = $check->( 1, [] ); # okay + my ($hashref, $num) = $check->( {}, 1.1 ); # okay + my ($code) = $check->( sub { 1 } ); # okay + + $check->( sub { 1 }, 1.1 ); # throws an exception + +Coercions, slurpy parameters, etc still work. + +The magic global C<< ${^TYPE_PARAMS_MULTISIG} >> is set to the index of +the first signature which succeeded. + +The present implementation involves compiling each signature independently, +and trying them each (in their given order!) in an C block. The only +slightly intelligent part is that it checks if C<< scalar(@_) >> fits into +the signature properly (taking into account optional and slurpy parameters), +and skips evals which couldn't possibly succeed. + +It's also possible to list coderefs as alternatives in C: + + state $check = multisig( + [ Int, ArrayRef ], + sub { ... }, + [ HashRef, Num ], + [ CodeRef ], + compile_named( needle => Value, haystack => Ref ), + ); + +The coderef is expected to die if that alternative should be abandoned (and +the next alternative tried), or return the list of accepted parameters. Here's +a full example: + + sub get_from { + state $check = multisig( + [ Int, ArrayRef ], + [ Str, HashRef ], + sub { + my ($meth, $obj); + die unless is_Object($obj); + die unless $obj->can($meth); + return ($meth, $obj); + }, + ); + + my ($needle, $haystack) = $check->(@_); + + for (${^TYPE_PARAMS_MULTISIG}) { + return $haystack->[$needle] if $_ == 0; + return $haystack->{$needle} if $_ == 1; + return $haystack->$needle if $_ == 2; + } + } + + get_from(0, \@array); # returns $array[0] + get_from('foo', \%hash); # returns $hash{foo} + get_from('foo', $obj); # returns $obj->foo + +The default error message is just C<"Parameter validation failed">. +You can pass an option hashref as the first argument with an informative +message string: + + sub foo { + state $OptionsDict = Dict[...]; + state $check = multisig( + { message => 'USAGE: $object->foo(\%options?, $string)' }, + [ Object, $OptionsDict, StringLike ], + [ Object, StringLike ], + ); + my ($self, @args) = $check->(@_); + my ($opts, $str) = ${^TYPE_PARAMS_MULTISIG} ? ({}, @args) : @_; + ...; + } + + $obj->foo(\%opts, "Hello"); + $obj->foo("World"); + +=head3 C<< wrap_subs( $subname1, $wrapper1, ... ) >> + +It's possible to turn the check inside-out and instead of the sub calling +the check, the check can call the original sub. + +Normal way: + + use Type::Param qw(compile); + use Types::Standard qw(Int Str); + + sub foobar { + state $check = compile(Int, Str); + my ($foo, $bar) = @_; + ...; + } + +Inside-out way: + + use Type::Param qw(wrap_subs); + use Types::Standard qw(Int Str); + + sub foobar { + my ($foo, $bar) = @_; + ...; + } + + wrap_subs foobar => [Int, Str]; + +C takes a hash of subs to wrap. The keys are the sub names and the +values are either arrayrefs of arguments to pass to C to make a check, +or coderefs that have already been built by C, C, or +C. + +=head3 C<< wrap_methods( $subname1, $wrapper1, ... ) >> + +C also exists, which shifts off the invocant from C<< @_ >> +before the check, but unshifts it before calling the original sub. + + use Type::Param qw(wrap_subs); + use Types::Standard qw(Int Str); + + sub foobar { + my ($self, $foo, $bar) = @_; + ...; + } + + wrap_subs foobar => [Int, Str]; + +=head3 B + +Type::Params exports a type B on request. This gives you a type +constraint which accepts classnames I blessed objects. + + use Type::Params qw( compile Invocant ); + + sub my_method { + state $check = compile(Invocant, ArrayRef, Int); + my ($self_or_class, $arr, $ix) = $check->(@_); + + return $arr->[ $ix ]; + } + +=head1 ENVIRONMENT + +=over + +=item C + +Affects the building of accessors for C. If set to true, +will use L. If set to false, will use pure Perl. If this +environment variable does not exist, will use L if it +is available. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L, L, L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Parser.pm @@ -0,0 +1,625 @@ +package Type::Parser; + +use strict; +use warnings; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +our $AUTHORITY = 'cpan:TOBYINK'; +our $VERSION = '1.010000'; + +$VERSION =~ tr/_//d; + +# Token types +# +sub TYPE () { "TYPE" }; +sub QUOTELIKE () { "QUOTELIKE" }; +sub STRING () { "STRING" }; +sub CLASS () { "CLASS" }; +sub L_BRACKET () { "L_BRACKET" }; +sub R_BRACKET () { "R_BRACKET" }; +sub COMMA () { "COMMA" }; +sub SLURPY () { "SLURPY" }; +sub UNION () { "UNION" }; +sub INTERSECT () { "INTERSECT" }; +sub NOT () { "NOT" }; +sub L_PAREN () { "L_PAREN" }; +sub R_PAREN () { "R_PAREN" }; +sub MYSTERY () { "MYSTERY" }; + +our @EXPORT_OK = qw( eval_type _std_eval parse extract_type ); + +require Exporter::Tiny; +our @ISA = 'Exporter::Tiny'; + +Evaluate: { + + sub parse + { + my $str = $_[0]; + my $parser = "Type::Parser::AstBuilder"->new(input => $str); + $parser->build; + wantarray ? ($parser->ast, $parser->remainder) : $parser->ast; + } + + sub extract_type + { + my ($str, $reg) = @_; + my ($parsed, $tail) = parse($str); + wantarray ? (_eval_type($parsed, $reg), $tail) : _eval_type($parsed, $reg); + } + + sub eval_type + { + my ($str, $reg) = @_; + my ($parsed, $tail) = parse($str); + _croak("Unexpected tail on type expression: $tail") if $tail =~ /\S/sm; + return _eval_type($parsed, $reg); + } + + my $std; + sub _std_eval + { + require Type::Registry; + unless ($std) + { + $std = "Type::Registry"->new; + $std->add_types(-Standard); + } + eval_type($_[0], $std); + } + + sub _eval_type + { + my ($node, $reg) = @_; + + $node = _simplify_expression($node); + + if ($node->{type} eq "list") + { + return map _eval_type($_, $reg), @{$node->{list}}; + } + + if ($node->{type} eq "union") + { + return $reg->make_union( + map _eval_type($_, $reg), @{$node->{union}} + ); + } + + if ($node->{type} eq "intersect") + { + return $reg->make_intersection( + map _eval_type($_, $reg), @{$node->{intersect}} + ); + } + + if ($node->{type} eq "slurpy") + { + return +{ slurpy => _eval_type($node->{of}, $reg) }; + } + + if ($node->{type} eq "complement") + { + return _eval_type($node->{of}, $reg)->complementary_type; + } + + if ($node->{type} eq "parameterized") + { + my $base = _eval_type($node->{base}, $reg); + + return $base unless $base->is_parameterizable || $node->{params}; + return $base->parameterize($node->{params} ? _eval_type($node->{params}, $reg) : ()); + } + + if ($node->{type} eq "primary" and $node->{token}->type eq CLASS) + { + my $class = substr( + $node->{token}->spelling, + 0, + length($node->{token}->spelling) - 2 + ); + return $reg->make_class_type($class); + } + + if ($node->{type} eq "primary" and $node->{token}->type eq QUOTELIKE) + { + return eval($node->{token}->spelling); #ARGH + } + + if ($node->{type} eq "primary" and $node->{token}->type eq STRING) + { + return $node->{token}->spelling; + } + + if ($node->{type} eq "primary" and $node->{token}->type eq TYPE) + { + my $t = $node->{token}->spelling; + my $r = ($t =~ /^(.+)::(\w+)$/) + ? $reg->foreign_lookup($t, 1) + : $reg->simple_lookup($t, 1); + $r or _croak("%s is not a known type constraint", $node->{token}->spelling); + return $r; + } + } + + sub _simplify_expression + { + my $expr = shift; + + if ($expr->{type} eq "expression" and $expr->{op}[0] eq COMMA) + { + return _simplify("list", COMMA, $expr); + } + + if ($expr->{type} eq "expression" and $expr->{op}[0] eq UNION) + { + return _simplify("union", UNION, $expr); + } + + if ($expr->{type} eq "expression" and $expr->{op}[0] eq INTERSECT) + { + return _simplify("intersect", INTERSECT, $expr); + } + + return $expr; + } + + sub _simplify + { + my $type = shift; + my $op = shift; + + my @list; + for my $expr ($_[0]{lhs}, $_[0]{rhs}) + { + if ($expr->{type} eq "expression" and $expr->{op}[0] eq $op) + { + my $simple = _simplify($type, $op, $expr); + push @list, @{ $simple->{$type} }; + } + else + { + push @list, $expr; + } + } + + return { type => $type, $type => \@list }; + } +} + +{ + package # hide from CPAN + Type::Parser::AstBuilder; + + sub new + { + my $class = shift; + bless { @_ }, $class; + } + + our %precedence = ( +# Type::Parser::COMMA() , 1 , + Type::Parser::UNION() , 2 , + Type::Parser::INTERSECT() , 3 , + Type::Parser::NOT() , 4 , + ); + + sub _parse_primary + { + my $self = shift; + my $tokens = $self->{tokens}; + + $tokens->assert_not_empty; + + if ($tokens->peek(0)->type eq Type::Parser::NOT) + { + $tokens->eat(Type::Parser::NOT); + $tokens->assert_not_empty; + return { + type => "complement", + of => $self->_parse_primary, + }; + } + + if ($tokens->peek(0)->type eq Type::Parser::SLURPY) + { + $tokens->eat(Type::Parser::SLURPY); + $tokens->assert_not_empty; + return { + type => "slurpy", + of => $self->_parse_primary, + }; + } + + if ($tokens->peek(0)->type eq Type::Parser::L_PAREN) + { + $tokens->eat(Type::Parser::L_PAREN); + my $r = $self->_parse_expression; + $tokens->eat(Type::Parser::R_PAREN); + return $r; + } + + if ($tokens->peek(1) + and $tokens->peek(0)->type eq Type::Parser::TYPE + and $tokens->peek(1)->type eq Type::Parser::L_BRACKET) + { + my $base = { type => "primary", token => $tokens->eat(Type::Parser::TYPE) }; + $tokens->eat(Type::Parser::L_BRACKET); + $tokens->assert_not_empty; + + local $precedence{ Type::Parser::COMMA() } = 1; + + my $params = undef; + if ($tokens->peek(0)->type eq Type::Parser::R_BRACKET) + { + $tokens->eat(Type::Parser::R_BRACKET); + } + else + { + $params = $self->_parse_expression; + $params = { type => "list", list => [$params] } unless $params->{type} eq "list"; + $tokens->eat(Type::Parser::R_BRACKET); + } + return { + type => "parameterized", + base => $base, + params => $params, + }; + } + + my $type = $tokens->peek(0)->type; + if ($type eq Type::Parser::TYPE + or $type eq Type::Parser::QUOTELIKE + or $type eq Type::Parser::STRING + or $type eq Type::Parser::CLASS) + { + return { type => "primary", token => $tokens->eat }; + } + + Type::Parser::_croak("Unexpected token in primary type expression; got '%s'", $tokens->peek(0)->spelling); + } + + sub _parse_expression_1 + { + my $self = shift; + my $tokens = $self->{tokens}; + + my ($lhs, $min_p) = @_; + while (!$tokens->empty and defined($precedence{$tokens->peek(0)->type}) and $precedence{$tokens->peek(0)->type} >= $min_p) + { + my $op = $tokens->eat; + my $rhs = $self->_parse_primary; + + while (!$tokens->empty and defined($precedence{$tokens->peek(0)->type}) and $precedence{$tokens->peek(0)->type} > $precedence{$op->type}) + { + my $lookahead = $tokens->peek(0); + $rhs = $self->_parse_expression_1($rhs, $precedence{$lookahead->type}); + } + + $lhs = { + type => "expression", + op => $op, + lhs => $lhs, + rhs => $rhs, + }; + } + return $lhs; + } + + sub _parse_expression + { + my $self = shift; + my $tokens = $self->{tokens}; + + return $self->_parse_expression_1($self->_parse_primary, 0); + } + + sub build + { + my $self = shift; + $self->{tokens} = "Type::Parser::TokenStream"->new(remaining => $self->{input}); + $self->{ast} = $self->_parse_expression; + } + + sub ast + { + $_[0]{ast}; + } + + sub remainder + { + $_[0]{tokens}->remainder; + } +} + +{ + package # hide from CPAN + Type::Parser::Token; + sub type { $_[0][0] } + sub spelling { $_[0][1] } +} + +{ + package # hide from CPAN + Type::Parser::TokenStream; + + use Scalar::Util qw(looks_like_number); + + sub new + { + my $class = shift; + bless { stack => [], done => [], @_ }, $class; + } + + sub peek + { + my $self = shift; + my $ahead = $_[0]; + + while ($self->_stack_size <= $ahead and length $self->{remaining}) + { + $self->_stack_extend; + } + + my @tokens = grep ref, @{ $self->{stack} }; + return $tokens[$ahead]; + } + + sub empty + { + my $self = shift; + not $self->peek(0); + } + + sub eat + { + my $self = shift; + $self->_stack_extend unless $self->_stack_size; + my $r; + while (defined(my $item = shift @{$self->{stack}})) + { + push @{ $self->{done} }, $item; + if (ref $item) + { + $r = $item; + last; + } + } + + if (@_ and $_[0] ne $r->type) + { + unshift @{$self->{stack}}, pop @{$self->{done}}; # uncoverable statement + Type::Parser::_croak("Expected $_[0]; got ".$r->type); # uncoverable statement + } + + return $r; + } + + sub assert_not_empty + { + my $self = shift; + Type::Parser::_croak("Expected token; got empty string") if $self->empty; + } + + sub _stack_size + { + my $self = shift; + scalar grep ref, @{ $self->{stack} }; + } + + sub _stack_extend + { + my $self = shift; + push @{ $self->{stack} }, $self->_read_token; + my ($space) = ($self->{remaining} =~ m/^([\s\n\r]*)/sm); + return unless length $space; + push @{ $self->{stack} }, $space; + substr($self->{remaining}, 0, length $space) = ""; + } + + sub remainder + { + my $self = shift; + return join "", + map { ref($_) ? $_->spelling : $_ } + (@{$self->{stack}}, $self->{remaining}) + } + + my %punctuation = ( + '[' => bless([ Type::Parser::L_BRACKET, "[" ], "Type::Parser::Token"), + ']' => bless([ Type::Parser::R_BRACKET, "]" ], "Type::Parser::Token"), + '(' => bless([ Type::Parser::L_PAREN, "[" ], "Type::Parser::Token"), + ')' => bless([ Type::Parser::R_PAREN, "]" ], "Type::Parser::Token"), + ',' => bless([ Type::Parser::COMMA, "," ], "Type::Parser::Token"), + '=>' => bless([ Type::Parser::COMMA, "=>" ], "Type::Parser::Token"), + 'slurpy' => bless([ Type::Parser::SLURPY, "slurpy" ], "Type::Parser::Token"), + '|' => bless([ Type::Parser::UNION, "|" ], "Type::Parser::Token"), + '&' => bless([ Type::Parser::INTERSECT, "&" ], "Type::Parser::Token"), + '~' => bless([ Type::Parser::NOT, "~" ], "Type::Parser::Token"), + ); + + sub _read_token + { + my $self = shift; + + return if $self->{remaining} eq ""; + + # Punctuation + # + + if ($self->{remaining} =~ /^( => | [()\]\[|&~,] )/xsm) + { + my $spelling = $1; + substr($self->{remaining}, 0, length $spelling) = ""; + return $punctuation{$spelling}; + } + + if ($self->{remaining} =~ /\A\s*[q'"]/sm) + { + require Text::Balanced; + if (my $quotelike = Text::Balanced::extract_quotelike($self->{remaining})) + { + return bless([ Type::Parser::QUOTELIKE, $quotelike ], "Type::Parser::Token"),; + } + } + + if ($self->{remaining} =~ /^([+-]?[\w:.+]+)/sm) + { + my $spelling = $1; + substr($self->{remaining}, 0, length $spelling) = ""; + + if ($spelling =~ /::$/sm) + { + return bless([ Type::Parser::CLASS, $spelling ], "Type::Parser::Token"),; + } + elsif (looks_like_number($spelling)) + { + return bless([ Type::Parser::STRING, $spelling ], "Type::Parser::Token"),; + } + elsif ($self->{remaining} =~ /^\s*=>/sm) # peek ahead + { + return bless([ Type::Parser::STRING, $spelling ], "Type::Parser::Token"),; + } + elsif ($spelling eq "slurpy") + { + return $punctuation{$spelling}; + } + + return bless([ Type::Parser::TYPE, $spelling ], "Type::Parser::Token"); + } + + my $rest = $self->{remaining}; + $self->{remaining} = ""; + return bless([ Type::Parser::MYSTERY, $rest ], "Type::Parser::Token"); + } +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords non-whitespace + +=head1 NAME + +Type::Parser - parse type constraint strings + +=head1 SYNOPSIS + + use v5.10; + use strict; + use warnings; + + use Type::Parser qw( eval_type ); + use Type::Registry; + + my $reg = Type::Registry->for_me; + $reg->add_types("Types::Standard"); + + my $type = eval_type("Int | ArrayRef[Int]", $reg); + + $type->check(10); # true + $type->check([1..4]); # true + $type->check({foo=>1}); # false + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Generally speaking, you probably don't want to be using this module directly. +Instead use the C<< lookup >> method from L which wraps it. + +=head2 Functions + +=over + +=item C<< parse($string) >> + +Parse the type constraint string into something like an AST. + +If called in list context, also returns any "tail" found on the original string. + +=item C<< extract_type($string, $registry) >> + +Compile a type constraint string into a L object. + +If called in list context, also returns any "tail" found on the original string. + +=item C<< eval_type($string, $registry) >> + +Compile a type constraint string into a L object. + +Throws an error if the "tail" contains any non-whitespace character. + +=back + +=head2 Constants + +The following constants correspond to values returned by C<< $token->type >>. + +=over + +=item C<< TYPE >> + +=item C<< QUOTELIKE >> + +=item C<< STRING >> + +=item C<< CLASS >> + +=item C<< L_BRACKET >> + +=item C<< R_BRACKET >> + +=item C<< COMMA >> + +=item C<< SLURPY >> + +=item C<< UNION >> + +=item C<< INTERSECT >> + +=item C<< NOT >> + +=item C<< L_PAREN >> + +=item C<< R_PAREN >> + +=item C<< MYSTERY >> + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Registry.pm @@ -0,0 +1,540 @@ +package Type::Registry; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Registry::AUTHORITY = 'cpan:TOBYINK'; + $Type::Registry::VERSION = '1.010000'; +} + +$Type::Registry::VERSION =~ tr/_//d; + +use Exporter::Tiny qw( mkopt ); +use Scalar::Util qw( refaddr ); +use Type::Parser qw( eval_type ); +use Types::TypeTiny qw( CodeLike ArrayLike to_TypeTiny ); + +our @ISA = 'Exporter::Tiny'; +our @EXPORT_OK = qw(t); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +sub _generate_t +{ + my $class = shift; + my ($name, $value, $globals) = @_; + + my $caller = $globals->{into}; + my $reg = $class->for_class( + ref($caller) ? sprintf('HASH(0x%08X)', refaddr($caller)) : $caller + ); + + sub (;$) { @_ ? $reg->lookup(@_) : $reg }; +} + +sub new +{ + my $class = shift; + ref($class) and _croak("Not an object method"); + bless {}, $class; +} + +{ + my %registries; + + sub for_class + { + my $class = shift; + my ($for) = @_; + $registries{$for} ||= $class->new; + } + + sub for_me + { + my $class = shift; + my $for = caller; + $registries{$for} ||= $class->new; + } +} + +sub add_types +{ + my $self = shift; + my $opts = mkopt(\@_); + for my $opt (@$opts) + { + my ($library, $types) = @$opt; + $library =~ s/^-/Types::/; + + { + local $SIG{__DIE__} = sub {}; + eval "require $library"; + }; + + my %hash; + + if ($library->isa("Type::Library") or $library eq 'Types::TypeTiny') + { + $types ||= [qw/-types/]; + ArrayLike->check($types) + or _croak("Expected arrayref following '%s'; got %s", $library, $types); + + $library->import({into => \%hash}, @$types); + $hash{$_} = &{$hash{$_}}() for keys %hash; + } + elsif ($library->isa("MooseX::Types::Base")) + { + $types ||= []; + ArrayLike->check($types) && (@$types == 0) + or _croak("Library '%s' is a MooseX::Types type constraint library. No import options currently supported", $library); + + require Moose::Util::TypeConstraints; + my $moosextypes = $library->type_storage; + for my $name (sort keys %$moosextypes) + { + my $tt = to_TypeTiny( + Moose::Util::TypeConstraints::find_type_constraint($moosextypes->{$name}) + ); + $hash{$name} = $tt; + } + } + elsif ($library->isa("MouseX::Types::Base")) + { + $types ||= []; + ArrayLike->check($types) && (@$types == 0) + or _croak("Library '%s' is a MouseX::Types type constraint library. No import options currently supported", $library); + + require Mouse::Util::TypeConstraints; + my $moosextypes = $library->type_storage; + for my $name (sort keys %$moosextypes) + { + my $tt = to_TypeTiny( + Mouse::Util::TypeConstraints::find_type_constraint($moosextypes->{$name}) + ); + $hash{$name} = $tt; + } + } + else + { + _croak("%s is not a type library", $library); + } + + for my $key (sort keys %hash) + { + exists($self->{$key}) + and $self->{$key}{uniq} != $hash{$key}{uniq} + and _croak("Duplicate type name: %s", $key); + $self->{$key} = $hash{$key}; + } + } + $self; +} + +sub add_type +{ + my $self = shift; + my ($type, $name) = @_; + $type = to_TypeTiny($type); + $name ||= do { + $type->is_anon + and _croak("Expected named type constraint; got anonymous type constraint"); + $type->name; + }; + + exists($self->{$name}) + and $self->{$name}{uniq} != $type->{uniq} + and _croak("Duplicate type name: %s", $name); + + $self->{$name} = $type; + $self; +} + +sub alias_type +{ + my $self = shift; + my ($old, @new) = @_; + my $lookup = eval { $self->lookup($old) } + or _croak("Expected existing type constraint name; got '$old'"); + $self->{$_} = $lookup for @new; + $self; +} + +sub simple_lookup +{ + my $self = shift; + + my ($tc) = @_; + $tc =~ s/(^\s+|\s+$)//g; + + if (exists $self->{$tc}) { + return $self->{$tc}; + } + elsif ($self->has_parent) { + return $self->get_parent->simple_lookup(@_); + } + + return; +} + +sub set_parent { + my $self = shift; + $self->{'~~parent'} = ref($_[0]) ? $_[0] : (ref($self)||$self)->for_class($_[0]); + $self; +} + +sub clear_parent { + my $self = shift; + delete $self->{'~~parent'}; + $self; +} + +sub has_parent { + !!ref(shift->{'~~parent'}); +} + +sub get_parent { + shift->{'~~parent'}; +} + +sub foreign_lookup +{ + my $self = shift; + + return $_[1] ? () : $self->simple_lookup($_[0], 1) + unless $_[0] =~ /^(.+)::(\w+)$/; + + my $library = $1; + my $typename = $2; + + { + local $SIG{__DIE__} = sub {}; + eval "require $library;"; + }; + + if ( $library->isa('MooseX::Types::Base') ) + { + require Moose::Util::TypeConstraints; + my $type = Moose::Util::TypeConstraints::find_type_constraint( + $library->get_type($typename) + ) or return; + return to_TypeTiny($type); + } + + if ( $library->isa('MouseX::Types::Base') ) + { + require Mouse::Util::TypeConstraints; + my $sub = $library->can($typename) or return; + my $type = Mouse::Util::TypeConstraints::find_type_constraint($sub->()) or return; + return to_TypeTiny($type); + } + + if ( $library->can("get_type") ) + { + my $type = $library->get_type($typename); + return to_TypeTiny($type); + } + + return; +} + +sub lookup +{ + my $self = shift; + + $self->simple_lookup(@_) or eval_type($_[0], $self); +} + +sub make_union +{ + my $self = shift; + my (@types) = @_; + + require Type::Tiny::Union; + return "Type::Tiny::Union"->new(type_constraints => \@types); +} + +sub make_intersection +{ + my $self = shift; + my (@types) = @_; + + require Type::Tiny::Intersection; + return "Type::Tiny::Intersection"->new(type_constraints => \@types); +} + +sub make_class_type +{ + my $self = shift; + my ($class) = @_; + + require Type::Tiny::Class; + return "Type::Tiny::Class"->new(class => $class); +} + +sub make_role_type +{ + my $self = shift; + my ($role) = @_; + + require Type::Tiny::Role; + return "Type::Tiny::Role"->new(role => $role); +} + +sub AUTOLOAD +{ + my $self = shift; + my ($method) = (our $AUTOLOAD =~ /(\w+)$/); + my $type = $self->simple_lookup($method); + return $type if $type; + _croak(q[Can't locate object method "%s" via package "%s"], $method, ref($self)); +} + +# Prevent AUTOLOAD being called for DESTROY! +sub DESTROY +{ + return; +} + +DELAYED: { + our %DELAYED; + for my $package (sort keys %DELAYED) + { + my $reg = __PACKAGE__->for_class($package); + my $types = $DELAYED{$package}; + + for my $name (sort keys %$types) + { + $reg->add_type($types->{$name}, $name); + } + } +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords optlist + +=head1 NAME + +Type::Registry - a glorified hashref for looking up type constraints + +=head1 SYNOPSIS + +=for test_synopsis no warnings qw(misc); + + package Foo::Bar; + + use Type::Registry; + + my $reg = "Type::Registry"->for_me; # a registry for Foo::Bar + + # Register all types from Types::Standard + $reg->add_types(-Standard); + + # Register just one type from Types::XSD + $reg->add_types(-XSD => ["NonNegativeInteger"]); + + # Register all types from MyApp::Types + $reg->add_types("MyApp::Types"); + + # Create a type alias + $reg->alias_type("NonNegativeInteger" => "Count"); + + # Look up a type constraint + my $type = $reg->lookup("ArrayRef[Count]"); + + $type->check([1, 2, 3.14159]); # croaks + +Alternatively: + + package Foo::Bar; + + use Type::Registry qw( t ); + + # Register all types from Types::Standard + t->add_types(-Standard); + + # Register just one type from Types::XSD + t->add_types(-XSD => ["NonNegativeInteger"]); + + # Register all types from MyApp::Types + t->add_types("MyApp::Types"); + + # Create a type alias + t->alias_type("NonNegativeInteger" => "Count"); + + # Look up a type constraint + my $type = t("ArrayRef[Count]"); + + $type->check([1, 2, 3.14159]); # croaks + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +A type registry is basically just a hashref mapping type names to type +constraint objects. + +=head2 Constructors + +=over + +=item C<< new >> + +Create a new glorified hashref. + +=item C<< for_class($class) >> + +Create or return the existing glorified hashref associated with the given +class. + +Note that any type constraint you have imported from Type::Library-based +type libraries will be automatically available in your class' registry. + +=item C<< for_me >> + +Create or return the existing glorified hashref associated with the caller. + +=back + +=head2 Methods + +=over + +=item C<< add_types(@libraries) >> + +The libraries list is treated as an "optlist" (a la L). + +Strings are the names of type libraries; if the first character is a +hyphen, it is expanded to the "Types::" prefix. If followed by an +arrayref, this is the list of types to import from that library. +Otherwise, imports all types from the library. + + use Type::Registry qw(t); + + t->add_types(-Standard); # OR: t->add_types("Types::Standard"); + + t->add_types( + -TypeTiny => ['HashLike'], + -Standard => ['HashRef' => { -as => 'RealHash' }], + ); + +L (and experimentally, L) libraries can +also be added this way, but I<< cannot be followed by an arrayref of +types to import >>. + +=item C<< add_type($type, $name) >> + +The long-awaited singular form of C. Given a type constraint +object, adds it to the registry with a given name. The name may be +omitted, in which case C<< $type->name >> is called, and Type::Registry +will throw an error if C<< $type >> is anonymous. If a name is explicitly +given, Type::Registry cares not one wit whether the type constraint is +anonymous. + +This method can even add L and L type +constraints; indeed anything that can be handled by L's +C function. (Bear in mind that to_TypeTiny I results +in an anonymous type constraint, so C<< $name >> will be required.) + +=item C<< alias_type($oldname, $newname) >> + +Create an alias for an existing type. + +=item C<< simple_lookup($name) >> + +Look up a type in the registry by name. + +Returns undef if not found. + +=item C<< foreign_lookup($name) >> + +Like C, but if the type name contains "::", will attempt +to load it from a type library. (And will attempt to load that module.) + +=item C<< lookup($name) >> + +Look up by name, with a DSL. + + t->lookup("Int|ArrayRef[Int]") + +The DSL can be summed up as: + + X type from this registry + My::Lib::X type from a type library + ~X complementary type + X | Y union + X & Y intersection + X[...] parameterized type + slurpy X slurpy type + Foo::Bar:: class type + +Croaks if not found. + +=item C<< make_union(@constraints) >>, +C<< make_intersection(@constraints) >>, +C<< make_class_type($class) >>, +C<< make_role_type($role) >> + +Convenience methods for creating certain common type constraints. + +=item C<< AUTOLOAD >> + +Overloaded to call C. + + $registry->Str; # like $registry->lookup("Str") + +=item C, C<< set_parent($reg) >>, C<< clear_parent >>, C<< has_parent >> + +Advanced stuff. Allows a registry to have a "parent" registry which it +inherits type constraints from. + +=back + +=head2 Functions + +=over + +=item C<< t >> + +This class can export a function C<< t >> which acts like +C<< "Type::Registry"->for_class($importing_class) >>. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Tiny.pm @@ -0,0 +1,2247 @@ +package Type::Tiny; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + if ($] < 5.008) { require Devel::TypeTiny::Perl56Compat }; + if ($] < 5.010) { require Devel::TypeTiny::Perl58Compat }; +} + +BEGIN { + $Type::Tiny::AUTHORITY = 'cpan:TOBYINK'; + $Type::Tiny::VERSION = '1.010000'; + $Type::Tiny::XS_VERSION = '0.016'; +} + +$Type::Tiny::VERSION =~ tr/_//d; +$Type::Tiny::XS_VERSION =~ tr/_//d; + +use Scalar::Util qw( blessed ); +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +sub _swap { $_[2] ? @_[1,0] : @_[0,1] } + +BEGIN { # uncoverable statement + ($] < 5.010001) # uncoverable statement + ? eval q{ sub SUPPORT_SMARTMATCH () { !!0 } } # uncoverable statement + : eval q{ sub SUPPORT_SMARTMATCH () { !!1 } }; # uncoverable statement + ($] >= 5.014) # uncoverable statement + ? eval q{ sub _FIXED_PRECEDENCE () { !!1 } } # uncoverable statement + : eval q{ sub _FIXED_PRECEDENCE () { !!0 } }; # uncoverable statement +}; # uncoverable statement + +BEGIN { + my $try_xs = # uncoverable statement + exists($ENV{PERL_TYPE_TINY_XS}) ? !!$ENV{PERL_TYPE_TINY_XS} : # uncoverable statement + exists($ENV{PERL_ONLY}) ? !$ENV{PERL_ONLY} : # uncoverable statement + 1; # uncoverable statement + + my $use_xs = 0; + $try_xs and eval { + require Type::Tiny::XS; + 'Type::Tiny::XS'->VERSION($Type::Tiny::XS_VERSION); + $use_xs++; + }; + + *_USE_XS = $use_xs + ? sub () { !!1 } + : sub () { !!0 }; + + *_USE_MOUSE = $try_xs + ? sub () { $INC{'Mouse/Util.pm'} and Mouse::Util::MOUSE_XS() } + : sub () { !!0 }; +}; + +{ + my $nil = sub {}; + sub _install_overloads + { + no strict 'refs'; + no warnings 'redefine', 'once'; + # Coverage is checked on Perl 5.26 + if ($] < 5.010) { # uncoverable statement + require overload; # uncoverable statement + push @_, fallback => 1; # uncoverable statement + goto \&overload::OVERLOAD; # uncoverable statement + }; # uncoverable statement + my $class = shift; + *{$class . '::(('} = sub {}; + *{$class . '::()'} = sub {}; + *{$class . '::()'} = do { my $x = 1; \$x }; + while (@_) { + my $f = shift; + *{$class . '::(' . $f} = ref $_[0] ? shift : do { my $m = shift; sub { shift->$m(@_) } }; + } + } +} + +__PACKAGE__->_install_overloads( + q("") => sub { caller =~ m{^(Moo::HandleMoose|Sub::Quote)} ? $_[0]->_stringify_no_magic : $_[0]->display_name }, + q(bool) => sub { 1 }, + q(&{}) => "_overload_coderef", + q(|) => sub { + my @tc = _swap @_; + if (!_FIXED_PRECEDENCE && $_[2]) { + if (blessed $tc[0]) { + if (blessed $tc[0] eq "Type::Tiny::_HalfOp") { + my $type = $tc[0]->{type}; + my $param = $tc[0]->{param}; + my $op = $tc[0]->{op}; + require Type::Tiny::Union; + return "Type::Tiny::_HalfOp"->new( + $op, + $param, + "Type::Tiny::Union"->new(type_constraints => [$type, $tc[1]]), + ); + } + } + elsif (ref $tc[0] eq 'ARRAY') { + require Type::Tiny::_HalfOp; + return "Type::Tiny::_HalfOp"->new('|', @tc); + } + } + require Type::Tiny::Union; + return "Type::Tiny::Union"->new(type_constraints => \@tc) + }, + q(&) => sub { + my @tc = _swap @_; + if (!_FIXED_PRECEDENCE && $_[2]) { + if (blessed $tc[0]) { + if (blessed $tc[0] eq "Type::Tiny::_HalfOp") { + my $type = $tc[0]->{type}; + my $param = $tc[0]->{param}; + my $op = $tc[0]->{op}; + require Type::Tiny::Intersection; + return "Type::Tiny::_HalfOp"->new( + $op, + $param, + "Type::Tiny::Intersection"->new(type_constraints => [$type, $tc[1]]), + ); + } + } + elsif (ref $tc[0] eq 'ARRAY') { + require Type::Tiny::_HalfOp; + return "Type::Tiny::_HalfOp"->new('&', @tc); + } + } + require Type::Tiny::Intersection; + "Type::Tiny::Intersection"->new(type_constraints => \@tc) + }, + q(~) => sub { shift->complementary_type }, + q(==) => sub { $_[0]->equals($_[1]) }, + q(!=) => sub { not $_[0]->equals($_[1]) }, + q(<) => sub { my $m = $_[0]->can('is_subtype_of'); $m->(_swap @_) }, + q(>) => sub { my $m = $_[0]->can('is_subtype_of'); $m->(reverse _swap @_) }, + q(<=) => sub { my $m = $_[0]->can('is_a_type_of'); $m->(_swap @_) }, + q(>=) => sub { my $m = $_[0]->can('is_a_type_of'); $m->(reverse _swap @_) }, + q(eq) => sub { "$_[0]" eq "$_[1]" }, + q(cmp) => sub { $_[2] ? ("$_[1]" cmp "$_[0]") : ("$_[0]" cmp "$_[1]") }, +); + +__PACKAGE__->_install_overloads( + q(~~) => sub { $_[0]->check($_[1]) }, +) if Type::Tiny::SUPPORT_SMARTMATCH; + +# Would be easy to just return sub { $self->assert_return(@_) } +# but try to build a more efficient coderef whenever possible. +# +sub _overload_coderef +{ + my $self = shift; + + # Bypass generating a coderef if we've already got the best possible one. + # + return $self->{_overload_coderef} if $self->{_overload_coderef_no_rebuild}; + + # Subclasses of Type::Tiny might override assert_return to do some kind + # of interesting thing. In that case, we can't rely on it having identical + # behaviour to Type::Tiny::inline_assert. + # + $self->{_overrides_assert_return} = ($self->can('assert_return') != \&assert_return) + unless exists $self->{_overrides_assert_return}; + + if ($self->{_overrides_assert_return}) { + $self->{_overload_coderef} ||= do { + Scalar::Util::weaken(my $weak = $self); + sub { $weak->assert_return(@_) }; + }; + ++ $self->{_overload_coderef_no_rebuild}; + } + elsif (exists(&Sub::Quote::quote_sub)) { + # Use `=` instead of `||=` because we want to overwrite non-Sub::Quote + # coderef if possible. + $self->{_overload_coderef} = $self->can_be_inlined + ? Sub::Quote::quote_sub( + $self->inline_assert('$_[0]'), + ) + : Sub::Quote::quote_sub( + $self->inline_assert('$_[0]', '$type'), + { '$type' => \$self }, + ); + ++ $self->{_overload_coderef_no_rebuild}; + } + else { + require Eval::TypeTiny; + $self->{_overload_coderef} ||= $self->can_be_inlined + ? Eval::TypeTiny::eval_closure( + source => sprintf('sub { %s }', $self->inline_assert('$_[0]', undef, no_wrapper => 1)), + description => sprintf("compiled assertion 'assert_%s'", $self), + ) + : Eval::TypeTiny::eval_closure( + source => sprintf('sub { %s }', $self->inline_assert('$_[0]', '$type', no_wrapper => 1)), + description => sprintf("compiled assertion 'assert_%s'", $self), + environment => { '$type' => \$self }, + ); + } + + $self->{_overload_coderef}; +} + +our %ALL_TYPES; + +my $QFS; +my $uniq = 1; +my $subname; +sub new +{ + my $class = shift; + my %params = (@_==1) ? %{$_[0]} : @_; + + for (qw/ name display_name library /) { + $params{$_} = $params{$_}.'' if defined $params{$_}; + } + + if (exists $params{parent}) { + $params{parent} = ref($params{parent}) =~ /^Type::Tiny\b/ + ? $params{parent} + : Types::TypeTiny::to_TypeTiny($params{parent}); + + _croak "Parent must be an instance of %s", __PACKAGE__ + unless blessed($params{parent}) && $params{parent}->isa(__PACKAGE__); + + if ($params{parent}->deprecated and not exists $params{deprecated}) { + $params{deprecated} = 1; + } + } + + if (exists $params{constraint} + and defined $params{constraint} + and not ref $params{constraint}) + { + require Eval::TypeTiny; + my $code = $params{constraint}; + $params{constraint} = Eval::TypeTiny::eval_closure( + source => sprintf('sub ($) { %s }', $code), + description => "anonymous check", + ); + $params{inlined} ||= sub { + my ($type) = @_; + my $inlined = $_ eq '$_' ? "do { $code }" : "do { local \$_ = $_; $code }"; + $type->has_parent ? (undef, $inlined) : $inlined; + } if (!exists $params{parent} or $params{parent}->can_be_inlined); + } + + # canonicalize to a boolean + $params{deprecated} = !!$params{deprecated}; + + $params{name} = "__ANON__" unless exists $params{name}; + $params{uniq} = $uniq++; + + if ($params{name} ne "__ANON__") { + # First try a fast ASCII-only expression, but fall back to Unicode + $params{name} =~ /^_{0,2}[A-Z][A-Za-z0-9_]+$/sm + or eval q( use 5.008; $params{name} =~ /^_{0,2}\p{Lu}[\p{L}0-9_]+$/sm ) + or _croak '"%s" is not a valid type name', $params{name}; + } + + if (exists $params{coercion} and !ref $params{coercion} and $params{coercion}) { + $params{parent}->has_coercion + or _croak "coercion => 1 requires type to have a direct parent with a coercion"; + + $params{coercion} = $params{parent}->coercion->type_coercion_map; + } + + if (!exists $params{inlined} + and exists $params{constraint} + and ( !exists $params{parent} or $params{parent}->can_be_inlined ) + and $QFS ||= "Sub::Quote"->can("quoted_from_sub")) { + my (undef, $perlstring, $captures) = @{ $QFS->($params{constraint}) || [] }; + + $params{inlined} = sub { + my ($self, $var) = @_; + my $code = Sub::Quote::inlinify( + $perlstring, + $var, + $var eq q($_) ? '' : "local \$_ = $var;", + 1, + ); + $code = sprintf('%s and %s', $self->parent->inline_check($var), $code) if $self->has_parent; + return $code; + } if $perlstring && !$captures; + } + + my $self = bless \%params, $class; + + unless ($params{tmp}) { + my $uniq = $self->{uniq}; + + $ALL_TYPES{$uniq} = $self; + Scalar::Util::weaken( $ALL_TYPES{$uniq} ); + + my $tmp = $self; + Scalar::Util::weaken($tmp); + $Moo::HandleMoose::TYPE_MAP{$self->_stringify_no_magic} = sub { $tmp }; + } + + if (ref($params{coercion}) eq q(CODE)) { + require Types::Standard; + my $code = delete($params{coercion}); + $self->{coercion} = $self->_build_coercion; + $self->coercion->add_type_coercions(Types::Standard::Any(), $code); + } + elsif (ref($params{coercion}) eq q(ARRAY)) { + my $arr = delete($params{coercion}); + $self->{coercion} = $self->_build_coercion; + $self->coercion->add_type_coercions(@$arr); + } + + # Documenting this here because it's too weird to be in the pod. + # There's a secret attribute called "_build_coercion" which takes a + # coderef. If present, then when $type->coercion is lazy built, + # the blank Type::Coercion object gets passed to the coderef, + # allowing the coderef to manipulate it a little. This is used by + # Types::TypeTiny to allow it to build a coercion for the TypeTiny + # type constraint without needing to load Type::Coercion yet. + + if ($params{my_methods}) { + $subname = + eval { require Sub::Util } ? \&Sub::Util::set_subname : + eval { require Sub::Name } ? \&Sub::Name::subname : + 0 + if not defined $subname; + if ($subname) { + (Scalar::Util::reftype($params{my_methods}{$_}) eq 'CODE') && $subname->( + sprintf("%s::my_%s", $self->qualified_name, $_), + $params{my_methods}{$_}, + ) for keys %{$params{my_methods}}; + } + } + + return $self; +} + +sub DESTROY { + my $self = shift; + delete( $ALL_TYPES{$self->{uniq}} ); + delete( $Moo::HandleMoose::TYPE_MAP{$self->_stringify_no_magic} ); + return; +} + +sub _clone { + my $self = shift; + my %opts; + $opts{$_} = $self->{$_} for qw< name display_name message >; + $self->create_child_type(%opts); +} + +sub _stringify_no_magic { + sprintf('%s=%s(0x%08x)', blessed($_[0]), Scalar::Util::reftype($_[0]), Scalar::Util::refaddr($_[0])); +} + +our $DD; +sub _dd +{ + @_ = $_ unless @_; + my ($value) = @_; + + goto $DD if ref($DD) eq q(CODE); + + require B; + + !defined $value ? 'Undef' : + !ref $value ? sprintf('Value %s', B::perlstring($value)) : + do { + my $N = 0 + (defined($DD) ? $DD : 72); + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Useqq = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Maxdepth = 2; + my $str = Data::Dumper::Dumper($value); + $str = substr($str, 0, $N - 12).'...'.substr($str, -1, 1) + if length($str) >= $N; + "Reference $str"; + } +} + +sub _loose_to_TypeTiny { + map +( + ref($_) + ? Types::TypeTiny::to_TypeTiny($_) + : do { require Type::Utils; Type::Utils::dwim_type($_) } + ), @_; +} + +sub name { $_[0]{name} } +sub display_name { $_[0]{display_name} ||= $_[0]->_build_display_name } +sub parent { $_[0]{parent} } +sub constraint { $_[0]{constraint} ||= $_[0]->_build_constraint } +sub compiled_check { $_[0]{compiled_type_constraint} ||= $_[0]->_build_compiled_check } +sub coercion { $_[0]{coercion} ||= $_[0]->_build_coercion } +sub message { $_[0]{message} } +sub library { $_[0]{library} } +sub inlined { $_[0]{inlined} } +sub deprecated { $_[0]{deprecated} } +sub constraint_generator { $_[0]{constraint_generator} } +sub inline_generator { $_[0]{inline_generator} } +sub name_generator { $_[0]{name_generator} ||= $_[0]->_build_name_generator } +sub coercion_generator { $_[0]{coercion_generator} } +sub parameters { $_[0]{parameters} } +sub moose_type { $_[0]{moose_type} ||= $_[0]->_build_moose_type } +sub mouse_type { $_[0]{mouse_type} ||= $_[0]->_build_mouse_type } +sub deep_explanation { $_[0]{deep_explanation} } +sub my_methods { $_[0]{my_methods} ||= $_[0]->_build_my_methods } + +sub has_parent { exists $_[0]{parent} } +sub has_library { exists $_[0]{library} } +sub has_inlined { exists $_[0]{inlined} } +sub has_constraint_generator { exists $_[0]{constraint_generator} } +sub has_inline_generator { exists $_[0]{inline_generator} } +sub has_coercion_generator { exists $_[0]{coercion_generator} } +sub has_parameters { exists $_[0]{parameters} } +sub has_message { defined $_[0]{message} } +sub has_deep_explanation { exists $_[0]{deep_explanation} } + +sub _default_message { $_[0]{_default_message} ||= $_[0]->_build_default_message } + +sub has_coercion +{ + $_[0]->coercion if $_[0]{_build_coercion}; # trigger auto build thing + $_[0]{coercion} and !!@{ $_[0]{coercion}->type_coercion_map } +} + +sub _assert_coercion +{ + my $self = shift; + return $self->coercion if $self->{_build_coercion}; # trigger auto build thing + _croak "No coercion for this type constraint" + unless $self->has_coercion && @{$self->coercion->type_coercion_map}; + $self->coercion; +} + +my $null_constraint = sub { !!1 }; + +sub _build_display_name +{ + shift->name; +} + +sub _build_constraint +{ + return $null_constraint; +} + +sub _is_null_constraint +{ + shift->constraint == $null_constraint; +} + +sub _build_coercion +{ + require Type::Coercion; + my $self = shift; + my %opts = (type_constraint => $self); + $opts{display_name} = "to_$self" unless $self->is_anon; + my $coercion = "Type::Coercion"->new(%opts); + $self->{_build_coercion}->($coercion) if ref $self->{_build_coercion}; + $coercion; +} + +sub _build_default_message +{ + my $self = shift; + $self->{is_using_default_message} = 1; + return sub { sprintf '%s did not pass type constraint', _dd($_[0]) } if "$self" eq "__ANON__"; + my $name = "$self"; + return sub { sprintf '%s did not pass type constraint "%s"', _dd($_[0]), $name }; +} + +sub _build_name_generator +{ + my $self = shift; + return sub { + my ($s, @a) = @_; + sprintf('%s[%s]', $s, join q[,], @a); + }; +} + +sub _build_compiled_check +{ + my $self = shift; + + local our $AvoidCallbacks = 0; + + if ($self->_is_null_constraint and $self->has_parent) + { + return $self->parent->compiled_check; + } + + require Eval::TypeTiny; + return Eval::TypeTiny::eval_closure( + source => sprintf('sub ($) { %s }', $self->inline_check('$_[0]')), + description => sprintf("compiled check '%s'", $self), + ) if $self->can_be_inlined; + + my @constraints; + push @constraints, $self->parent->compiled_check if $self->has_parent; + push @constraints, $self->constraint if !$self->_is_null_constraint; + return $null_constraint unless @constraints; + + return sub ($) + { + local $_ = $_[0]; + for my $c (@constraints) + { + return unless $c->(@_); + } + return !!1; + }; +} + +sub find_constraining_type +{ + my $self = shift; + if ($self->_is_null_constraint and $self->has_parent) { + return $self->parent->find_constraining_type; + } + $self; +} + +our @CMP; + +sub CMP_SUPERTYPE () { -1 } +sub CMP_EQUAL () { 0 } +sub CMP_EQUIVALENT () { '0E0' } +sub CMP_SUBTYPE () { 1 } +sub CMP_UNKNOWN () { ''; } + +# avoid getting mixed up with cmp operator at compile time +*cmp = sub { + my ($A, $B) = _loose_to_TypeTiny($_[0], $_[1]); + return unless blessed($A) && $A->isa("Type::Tiny"); + return unless blessed($B) && $B->isa("Type::Tiny"); + for my $comparator (@CMP) { + my $result = $comparator->($A, $B); + next if $result eq CMP_UNKNOWN; + if ($result eq CMP_EQUIVALENT) { + my $prefer = @_==3 ? $_[2] : CMP_EQUAL; + return $prefer; + } + return $result; + } + return CMP_UNKNOWN; +}; + +push @CMP, sub { + my ($A, $B) = @_; + return CMP_EQUAL + if Scalar::Util::refaddr($A) == Scalar::Util::refaddr($B); + + return CMP_EQUIVALENT + if Scalar::Util::refaddr($A->compiled_check) == Scalar::Util::refaddr($B->compiled_check); + + my $A_stem = $A->find_constraining_type; + my $B_stem = $B->find_constraining_type; + return CMP_EQUIVALENT + if Scalar::Util::refaddr($A_stem) == Scalar::Util::refaddr($B_stem); + return CMP_EQUIVALENT + if Scalar::Util::refaddr($A_stem->compiled_check) == Scalar::Util::refaddr($B_stem->compiled_check); + + if ($A_stem->can_be_inlined and $B_stem->can_be_inlined) { + return 0 if $A_stem->inline_check('$WOLFIE') eq $B_stem->inline_check('$WOLFIE'); + } + + A_IS_SUBTYPE: { + my $A_prime = $A_stem; + while ($A_prime->has_parent) { + $A_prime = $A_prime->parent; + return CMP_SUBTYPE + if Scalar::Util::refaddr($A_prime) == Scalar::Util::refaddr($B_stem); + return CMP_SUBTYPE + if Scalar::Util::refaddr($A_prime->compiled_check) == Scalar::Util::refaddr($B_stem->compiled_check); + if ($A_prime->can_be_inlined and $B_stem->can_be_inlined) { + return CMP_SUBTYPE + if $A_prime->inline_check('$WOLFIE') eq $B_stem->inline_check('$WOLFIE'); + } + } + } + + B_IS_SUBTYPE: { + my $B_prime = $B_stem; + while ($B_prime->has_parent) { + $B_prime = $B_prime->parent; + return CMP_SUPERTYPE + if Scalar::Util::refaddr($B_prime) == Scalar::Util::refaddr($A_stem); + return CMP_SUPERTYPE + if Scalar::Util::refaddr($B_prime->compiled_check) == Scalar::Util::refaddr($A_stem->compiled_check); + if ($A_stem->can_be_inlined and $B_prime->can_be_inlined) { + return CMP_SUPERTYPE + if $B_prime->inline_check('$WOLFIE') eq $A_stem->inline_check('$WOLFIE'); + } + } + } + + return CMP_UNKNOWN; +}; + +sub equals +{ + my $result = Type::Tiny::cmp($_[0], $_[1]); + return unless defined $result; + $result eq CMP_EQUAL; +} + +sub is_subtype_of +{ + my $result = Type::Tiny::cmp($_[0], $_[1], CMP_SUBTYPE); + return unless defined $result; + $result eq CMP_SUBTYPE; +} + +sub is_supertype_of +{ + my $result = Type::Tiny::cmp($_[0], $_[1], CMP_SUBTYPE); + return unless defined $result; + $result eq CMP_SUPERTYPE; +} + +sub is_a_type_of +{ + my $result = Type::Tiny::cmp($_[0], $_[1]); + return unless defined $result; + $result eq CMP_SUBTYPE or $result eq CMP_EQUAL or $result eq CMP_EQUIVALENT; +} + +sub strictly_equals +{ + my ($self, $other) = _loose_to_TypeTiny(@_); + return unless blessed($self) && $self->isa("Type::Tiny"); + return unless blessed($other) && $other->isa("Type::Tiny"); + $self->{uniq} == $other->{uniq}; +} + +sub is_strictly_subtype_of +{ + my ($self, $other) = _loose_to_TypeTiny(@_); + return unless blessed($self) && $self->isa("Type::Tiny"); + return unless blessed($other) && $other->isa("Type::Tiny"); + + return unless $self->has_parent; + $self->parent->strictly_equals($other) or $self->parent->is_strictly_subtype_of($other); +} + +sub is_strictly_supertype_of +{ + my ($self, $other) = _loose_to_TypeTiny(@_); + return unless blessed($self) && $self->isa("Type::Tiny"); + return unless blessed($other) && $other->isa("Type::Tiny"); + + $other->is_strictly_subtype_of($self); +} + +sub is_strictly_a_type_of +{ + my ($self, $other) = _loose_to_TypeTiny(@_); + return unless blessed($self) && $self->isa("Type::Tiny"); + return unless blessed($other) && $other->isa("Type::Tiny"); + + $self->strictly_equals($other) or $self->is_strictly_subtype_of($other); +} + +sub qualified_name +{ + my $self = shift; + (exists $self->{library} and $self->name ne "__ANON__") + ? "$self->{library}::$self->{name}" + : $self->{name}; +} + +sub is_anon +{ + my $self = shift; + $self->name eq "__ANON__"; +} + +sub parents +{ + my $self = shift; + return unless $self->has_parent; + return ($self->parent, $self->parent->parents); +} + +sub find_parent +{ + my $self = shift; + my ($test) = @_; + + local ($_, $.); + my $type = $self; + my $count = 0; + while ($type) + { + if ($test->($_=$type, $.=$count)) + { + return wantarray ? ($type, $count) : $type; + } + else + { + $type = $type->parent; + $count++; + } + } + + return; +} + +sub check +{ + my $self = shift; + ($self->{compiled_type_constraint} ||= $self->_build_compiled_check)->(@_); +} + +sub _strict_check +{ + my $self = shift; + local $_ = $_[0]; + + my @constraints = + reverse + map { $_->constraint } + grep { not $_->_is_null_constraint } + ($self, $self->parents); + + for my $c (@constraints) + { + return unless $c->(@_); + } + + return !!1; +} + +sub get_message +{ + my $self = shift; + local $_ = $_[0]; + $self->has_message + ? $self->message->(@_) + : $self->_default_message->(@_); +} + +sub validate +{ + my $self = shift; + + return undef if ($self->{compiled_type_constraint} ||= $self->_build_compiled_check)->(@_); + + local $_ = $_[0]; + return $self->get_message(@_); +} + +sub validate_explain +{ + my $self = shift; + my ($value, $varname) = @_; + $varname = '$_' unless defined $varname; + + return undef if $self->check($value); + + if ($self->has_parent) + { + my $parent = $self->parent->validate_explain($value, $varname); + return [ sprintf('"%s" is a subtype of "%s"', $self, $self->parent), @$parent ] if $parent; + } + + my $message = sprintf( + '%s%s', + $self->get_message($value), + $varname eq q{$_} ? '' : sprintf(' (in %s)', $varname), + ); + + if ($self->is_parameterized and $self->parent->has_deep_explanation) + { + my $deep = $self->parent->deep_explanation->($self, $value, $varname); + return [ $message, @$deep ] if $deep; + } + + return [ $message, sprintf('"%s" is defined as: %s', $self, $self->_perlcode) ]; +} + +my $b; +sub _perlcode +{ + my $self = shift; + + local our $AvoidCallbacks = 1; + return $self->inline_check('$_') + if $self->can_be_inlined; + + $b ||= do { + require B::Deparse; + my $tmp = "B::Deparse"->new; + $tmp->ambient_pragmas(strict => "all", warnings => "all") if $tmp->can('ambient_pragmas'); + $tmp; + }; + + my $code = $b->coderef2text($self->constraint); + $code =~ s/\s+/ /g; + return "sub $code"; +} + +sub assert_valid +{ + my $self = shift; + + return !!1 if ($self->{compiled_type_constraint} ||= $self->_build_compiled_check)->(@_); + + local $_ = $_[0]; + $self->_failed_check("$self", $_); +} + +sub assert_return +{ + my $self = shift; + + return $_[0] if ($self->{compiled_type_constraint} ||= $self->_build_compiled_check)->(@_); + + local $_ = $_[0]; + $self->_failed_check("$self", $_); +} + +sub can_be_inlined +{ + my $self = shift; + return $self->parent->can_be_inlined + if $self->has_parent && $self->_is_null_constraint; + return !!1 + if !$self->has_parent && $self->_is_null_constraint; + return $self->has_inlined; +} + +sub inline_check +{ + my $self = shift; + _croak 'Cannot inline type constraint check for "%s"', $self + unless $self->can_be_inlined; + + return $self->parent->inline_check(@_) + if $self->has_parent && $self->_is_null_constraint; + return '(!!1)' + if !$self->has_parent && $self->_is_null_constraint; + + local $_ = $_[0]; + my @r = $self->inlined->($self, @_); + if (@r and not defined $r[0]) + { + _croak 'Inlining type constraint check for "%s" returned undef!', $self + unless $self->has_parent; + $r[0] = $self->parent->inline_check(@_); + } + my $r = join " && " => map { /[;{}]/ && !/\Ado \{.+\}\z/ ? "do { package Type::Tiny; $_ }" : "($_)" } @r; + return @r==1 ? $r : "($r)"; +} + +sub inline_assert +{ + require B; + my $self = shift; + my ($varname, $typevarname, %extras) = @_; + + my $inline_check; + if ($self->can_be_inlined) { + $inline_check = sprintf('(%s)', $self->inline_check($varname)); + } + elsif ($typevarname) { + $inline_check = sprintf('%s->check(%s)', $typevarname, $varname); + } + else { + _croak 'Cannot inline type constraint check for "%s"', $self; + } + + my $do_wrapper = !delete $extras{no_wrapper}; + + my $inline_throw; + if ($typevarname) { + $inline_throw = sprintf( + 'Type::Tiny::_failed_check(%s, %s, %s, %s)', + $typevarname, + B::perlstring("$self"), + $varname, + join(',', map +(B::perlstring($_) => B::perlstring($extras{$_})), sort keys %extras), + ); + } + else { + $inline_throw = sprintf( + 'Type::Tiny::_failed_check(%s, %s, %s, %s)', + $self->{uniq}, + B::perlstring("$self"), + $varname, + join(',', map +(B::perlstring($_) => B::perlstring($extras{$_})), sort keys %extras), + ); + } + + $do_wrapper + ? qq[do { no warnings "void"; package Type::Tiny; $inline_check or $inline_throw; $varname };] + : qq[ no warnings "void"; package Type::Tiny; $inline_check or $inline_throw; $varname ] +} + +sub _failed_check { + require Error::TypeTiny::Assertion; + + my ($self, $name, $value, %attrs) = @_; + $self = $ALL_TYPES{$self} if defined $self && !ref $self; + + my $exception_class = delete($attrs{exception_class}) || "Error::TypeTiny::Assertion"; + + if ($self) { + $exception_class->throw( + message => $self->get_message($value), + type => $self, + value => $value, + %attrs, + ); + } + else { + $exception_class->throw( + message => sprintf('%s did not pass type constraint "%s"', _dd($value), $name), + value => $value, + %attrs, + ); + } +} + +sub coerce +{ + my $self = shift; + $self->_assert_coercion->coerce(@_); +} + +sub assert_coerce +{ + my $self = shift; + $self->_assert_coercion->assert_coerce(@_); +} + +sub is_parameterizable +{ + shift->has_constraint_generator; +} + +sub is_parameterized +{ + shift->has_parameters; +} + +{ + my %seen; + sub ____make_key { + join ',', map { + Types::TypeTiny::TypeTiny->check($_) ? sprintf('$Type::Tiny::ALL_TYPES{%d}', defined($_->{uniq}) ? $_->{uniq} : '____CANNOT_KEY____') : + ref() eq 'ARRAY' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf('[%s]', ____make_key(@$_)) } : + ref() eq 'HASH' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf('{%s}', ____make_key(%$_)) } : + ref() eq 'SCALAR' || ref() eq 'REF' ? do { $seen{$_}++ ? '____CANNOT_KEY____' : sprintf('\\(%s)', ____make_key($$_)) } : + !defined() ? 'undef' : + !ref() ? do { require B; B::perlstring($_) } : + '____CANNOT_KEY____'; + } @_; + } + my %param_cache; + sub parameterize + { + my $self = shift; + + $self->is_parameterizable + or @_ ? _croak("Type '%s' does not accept parameters", "$self") : return($self); + + @_ = map Types::TypeTiny::to_TypeTiny($_), @_; + + # Generate a key for caching parameterized type constraints, + # but only if all the parameters are strings or type constraints. + %seen = (); + my $key = $self->____make_key(@_); + undef($key) if $key =~ /____CANNOT_KEY____/; + return $param_cache{$key} if defined $key && defined $param_cache{$key}; + + local $Type::Tiny::parameterize_type = $self; + local $_ = $_[0]; + my $P; + + my ($constraint, $compiled) = $self->constraint_generator->(@_); + + if (Types::TypeTiny::TypeTiny->check($constraint)) + { + $P = $constraint; + } + else + { + my %options = ( + constraint => $constraint, + display_name => $self->name_generator->($self, @_), + parameters => [@_], + ); + $options{compiled_type_constraint} = $compiled + if $compiled; + $options{inlined} = $self->inline_generator->(@_) + if $self->has_inline_generator; + exists $options{$_} && !defined $options{$_} && delete $options{$_} + for keys %options; + + $P = $self->create_child_type(%options); + + my $coercion; + $coercion = $self->coercion_generator->($self, $P, @_) + if $self->has_coercion_generator; + $P->coercion->add_type_coercions( @{$coercion->type_coercion_map} ) + if $coercion; + } + + if (defined $key) + { + $param_cache{$key} = $P; + Scalar::Util::weaken($param_cache{$key}); + } + + $P->coercion->freeze; + + return $P; + } +} + +sub child_type_class +{ + __PACKAGE__; +} + +sub create_child_type +{ + my $self = shift; + my %moreopts; + $moreopts{is_object} = 1 if $self->{is_object}; + return $self->child_type_class->new(parent => $self, %moreopts, @_); +} + +sub complementary_type +{ + my $self = shift; + my $r = ($self->{complementary_type} ||= $self->_build_complementary_type); + Scalar::Util::weaken($self->{complementary_type}) unless Scalar::Util::isweak($self->{complementary_type}); + return $r; +} + +sub _build_complementary_type +{ + my $self = shift; + my %opts = ( + constraint => sub { not $self->check($_) }, + display_name => sprintf("~%s", $self), + ); + $opts{display_name} =~ s/^\~{2}//; + $opts{inlined} = sub { shift; "not(".$self->inline_check(@_).")" } + if $self->can_be_inlined; + $opts{display_name} = $opts{name} = $self->{complement_name} + if $self->{complement_name}; + return "Type::Tiny"->new(%opts); +} + +sub _instantiate_moose_type +{ + my $self = shift; + my %opts = @_; + require Moose::Meta::TypeConstraint; + return "Moose::Meta::TypeConstraint"->new(%opts); +} + +sub _build_moose_type +{ + my $self = shift; + + my $r; + if ($self->{_is_core}) + { + require Moose::Util::TypeConstraints; + $r = Moose::Util::TypeConstraints::find_type_constraint($self->name); + $r->{"Types::TypeTiny::to_TypeTiny"} = $self; + Scalar::Util::weaken($r->{"Types::TypeTiny::to_TypeTiny"}); + } + else + { + # Type::Tiny is more flexible than Moose, allowing + # inlined to return a list. So we need to wrap the + # inlined coderef to make sure Moose gets a single + # string. + # + my $wrapped_inlined = sub { + shift; + $self->inline_check(@_); + }; + + my %opts; + $opts{name} = $self->qualified_name if $self->has_library && !$self->is_anon; + $opts{parent} = $self->parent->moose_type if $self->has_parent; + $opts{constraint} = $self->constraint unless $self->_is_null_constraint; + $opts{message} = $self->message if $self->has_message; + $opts{inlined} = $wrapped_inlined if $self->has_inlined; + + $r = $self->_instantiate_moose_type(%opts); + $r->{"Types::TypeTiny::to_TypeTiny"} = $self; + $self->{moose_type} = $r; # prevent recursion + $r->coercion($self->coercion->moose_coercion) if $self->has_coercion; + } + + return $r; +} + +sub _build_mouse_type +{ + my $self = shift; + + my %options; + $options{name} = $self->qualified_name if $self->has_library && !$self->is_anon; + $options{parent} = $self->parent->mouse_type if $self->has_parent; + $options{constraint} = $self->constraint unless $self->_is_null_constraint; + $options{message} = $self->message if $self->has_message; + + require Mouse::Meta::TypeConstraint; + my $r = "Mouse::Meta::TypeConstraint"->new(%options); + + $self->{mouse_type} = $r; # prevent recursion + $r->_add_type_coercions( + $self->coercion->freeze->_codelike_type_coercion_map('mouse_type') + ) if $self->has_coercion; + + return $r; +} + +sub _process_coercion_list +{ + my $self = shift; + + my @pairs; + while (@_) + { + my $next = shift; + if (blessed($next) and $next->isa('Type::Coercion') and $next->is_parameterized) + { + push @pairs => ( + @{ $next->_reparameterize($self)->type_coercion_map } + ); + } + elsif (blessed($next) and $next->can('type_coercion_map')) + { + push @pairs => ( + @{ $next->type_coercion_map }, + ); + } + elsif (ref($next) eq q(ARRAY)) + { + unshift @_, @$next; + } + else + { + push @pairs => ( + Types::TypeTiny::to_TypeTiny($next), + shift, + ); + } + } + + return @pairs; +} + +sub plus_coercions +{ + my $self = shift; + my $new = $self->_clone; + $new->coercion->add_type_coercions( + $self->_process_coercion_list(@_), + @{$self->coercion->type_coercion_map}, + ); + $new->coercion->freeze; + return $new; +} + +sub plus_fallback_coercions +{ + my $self = shift; + + my $new = $self->_clone; + $new->coercion->add_type_coercions( + @{$self->coercion->type_coercion_map}, + $self->_process_coercion_list(@_), + ); + $new->coercion->freeze; + return $new; +} + +sub minus_coercions +{ + my $self = shift; + + my $new = $self->_clone; + my @not = grep Types::TypeTiny::TypeTiny->check($_), $self->_process_coercion_list($new, @_); + + my @keep; + my $c = $self->coercion->type_coercion_map; + for (my $i = 0; $i <= $#$c; $i += 2) + { + my $keep_this = 1; + NOT: for my $n (@not) + { + if ($c->[$i] == $n) + { + $keep_this = 0; + last NOT; + } + } + + push @keep, $c->[$i], $c->[$i+1] if $keep_this; + } + + $new->coercion->add_type_coercions(@keep); + $new->coercion->freeze; + return $new; +} + +sub no_coercions +{ + my $new = shift->_clone; + $new->coercion->freeze; + $new; +} + +sub coercibles +{ + my $self = shift; + $self->has_coercion ? $self->coercion->_source_type_union : $self; +} + +sub isa +{ + my $self = shift; + + if ($INC{"Moose.pm"} and ref($self) and $_[0] =~ /^(?:Class::MOP|MooseX?::Meta)::(.+)$/) + { + my $meta = $1; + + return !!1 if $meta eq 'TypeConstraint'; + return $self->is_parameterized if $meta eq 'TypeConstraint::Parameterized'; + return $self->is_parameterizable if $meta eq 'TypeConstraint::Parameterizable'; + return $self->isa('Type::Tiny::Union') if $meta eq 'TypeConstraint::Union'; + + my $inflate = $self->moose_type; + return $inflate->isa(@_); + } + + if ($INC{"Mouse.pm"} and ref($self) and $_[0] eq 'Mouse::Meta::TypeConstraint') + { + return !!1; + } + + $self->SUPER::isa(@_); +} + +sub _build_my_methods +{ + return {}; +} + +sub _lookup_my_method +{ + my $self = shift; + my ($name) = @_; + + if ($self->my_methods->{$name}) + { + return $self->my_methods->{$name}; + } + + if ($self->has_parent) + { + return $self->parent->_lookup_my_method(@_); + } + + return; +} + +my %object_methods = (with_attribute_values => 1, stringifies_to => 1, numifies_to => 1); + +sub can +{ + my $self = shift; + + return !!0 if $_[0] eq 'type_parameter' && blessed($_[0]) && $_[0]->has_parameters; + + my $can = $self->SUPER::can(@_); + return $can if $can; + + if (ref($self)) + { + if ($INC{"Moose.pm"}) + { + my $method = $self->moose_type->can(@_); + return sub { shift->moose_type->$method(@_) } if $method; + } + if ($_[0] =~ /\Amy_(.+)\z/) + { + my $method = $self->_lookup_my_method($1); + return $method if $method; + } + } + + if ($self->{is_object} && $object_methods{$_[0]}) { + require Type::Tiny::ConstrainedObject; + return Type::Tiny::ConstrainedObject->can($_[0]); + } + + return; +} + +sub AUTOLOAD +{ + my $self = shift; + my ($m) = (our $AUTOLOAD =~ /::(\w+)$/); + return if $m eq 'DESTROY'; + + if (ref($self)) + { + if ($INC{"Moose.pm"}) + { + my $method = $self->moose_type->can($m); + return $self->moose_type->$method(@_) if $method; + } + if ($m =~ /\Amy_(.+)\z/) + { + my $method = $self->_lookup_my_method($1); + return &$method($self, @_) if $method; + } + } + + if ($self->{is_object} && $object_methods{$m}) { + require Type::Tiny::ConstrainedObject; + unshift @_, $self; + no strict 'refs'; + goto \&{"Type::Tiny::ConstrainedObject::$m"}; + } + + _croak q[Can't locate object method "%s" via package "%s"], $m, ref($self)||$self; +} + +sub DOES +{ + my $self = shift; + + return !!1 if ref($self) && $_[0] =~ m{^ Type::API::Constraint (?: ::Coercible | ::Inlinable )? $}x; + return !!1 if !ref($self) && $_[0] eq 'Type::API::Constraint::Constructor'; + + "UNIVERSAL"->can("DOES") ? $self->SUPER::DOES(@_) : $self->isa(@_); +} + +sub _has_xsub +{ + require B; + !!B::svref_2object( shift->compiled_check )->XSUB; +} + +sub of { shift->parameterize(@_) } +sub where { shift->create_child_type(constraint => @_) } + +# fill out Moose-compatible API +sub inline_environment { +{} } +sub _inline_check { shift->inline_check(@_) } +sub _compiled_type_constraint { shift->compiled_check(@_) } +sub meta { _croak("Not really a Moose::Meta::TypeConstraint. Sorry!") } +sub compile_type_constraint { shift->compiled_check } +sub _actually_compile_type_constraint { shift->_build_compiled_check } +sub hand_optimized_type_constraint { shift->{hand_optimized_type_constraint} } +sub has_hand_optimized_type_constraint { exists(shift->{hand_optimized_type_constraint}) } +sub type_parameter { (shift->parameters || [])->[0] } +sub parameterized_from { $_[0]->is_parameterized ? shift->parent : _croak("Not a parameterized type") } +sub has_parameterized_from { $_[0]->is_parameterized } + +# some stuff for Mouse-compatible API +sub __is_parameterized { shift->is_parameterized(@_) } +sub _add_type_coercions { shift->coercion->add_type_coercions(@_) }; +sub _as_string { shift->qualified_name(@_) } +sub _compiled_type_coercion { shift->coercion->compiled_coercion(@_) }; +sub _identity { Scalar::Util::refaddr(shift) }; +sub _unite { require Type::Tiny::Union; "Type::Tiny::Union"->new(type_constraints => \@_) }; + +# Hooks for Type::Tie +sub TIESCALAR { require Type::Tie; unshift @_, 'Type::Tie::SCALAR'; goto \&Type::Tie::SCALAR::TIESCALAR }; +sub TIEARRAY { require Type::Tie; unshift @_, 'Type::Tie::ARRAY'; goto \&Type::Tie::ARRAY::TIEARRAY }; +sub TIEHASH { require Type::Tie; unshift @_, 'Type::Tie::HASH'; goto \&Type::Tie::HASH::TIEHASH }; + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords Moo(se)-compatible MooseX MouseX MooX Moose-compat invocant + +=head1 NAME + +Type::Tiny - tiny, yet Moo(se)-compatible type constraint + +=head1 SYNOPSIS + + use v5.12; + use strict; + use warnings; + + package Horse { + use Moo; + use Types::Standard qw( Str Int Enum ArrayRef Object ); + use Type::Params qw( compile ); + use namespace::autoclean; + + has name => ( + is => 'ro', + isa => Str, + required => 1, + ); + has gender => ( + is => 'ro', + isa => Enum[qw( f m )], + ); + has age => ( + is => 'rw', + isa => Int->where( '$_ >= 0' ), + ); + has children => ( + is => 'ro', + isa => ArrayRef[Object], + default => sub { return [] }, + ); + + sub add_child { + state $check = compile( Object, Object ); # method signature + + my ($self, $child) = $check->(@_); # unpack @_ + push @{ $self->children }, $child; + + return $self; + } + } + + package main; + + my $boldruler = Horse->new( + name => "Bold Ruler", + gender => 'm', + age => 16, + ); + + my $secretariat = Horse->new( + name => "Secretariat", + gender => 'm', + age => 0, + ); + + $boldruler->add_child( $secretariat ); + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +This documents the internals of the L class. L +is a better starting place if you're new. + +L is a small class for creating Moose-like type constraint +objects which are compatible with Moo, Moose and Mouse. + + use Scalar::Util qw(looks_like_number); + use Type::Tiny; + + my $NUM = "Type::Tiny"->new( + name => "Number", + constraint => sub { looks_like_number($_) }, + message => sub { "$_ ain't a number" }, + ); + + package Ermintrude { + use Moo; + has favourite_number => (is => "ro", isa => $NUM); + } + + package Bullwinkle { + use Moose; + has favourite_number => (is => "ro", isa => $NUM); + } + + package Maisy { + use Mouse; + has favourite_number => (is => "ro", isa => $NUM); + } + +Maybe now we won't need to have separate MooseX, MouseX and MooX versions +of everything? We can but hope... + +=head2 Constructor + +=over + +=item C<< new(%attributes) >> + +Moose-style constructor function. + +=back + +=head2 Attributes + +Attributes are named values that may be passed to the constructor. For +each attribute, there is a corresponding reader method. For example: + + my $type = Type::Tiny->new( name => "Foo" ); + print $type->name, "\n"; # says "Foo" + +=head3 Important attributes + +These are the attributes you are likely to be most interested in +providing when creating your own type constraints, and most interested +in reading when dealing with type constraint objects. + +=over + +=item C<< constraint >> + +Coderef to validate a value (C<< $_ >>) against the type constraint. +The coderef will not be called unless the value is known to pass any +parent type constraint (see C below). + +Alternatively, a string of Perl code checking C<< $_ >> can be passed +as a parameter to the constructor, and will be converted to a coderef. + +Defaults to C<< sub { 1 } >> - i.e. a coderef that passes all values. + +=item C<< parent >> + +Optional attribute; parent type constraint. For example, an "Integer" +type constraint might have a parent "Number". + +If provided, must be a Type::Tiny object. + +=item C<< inlined >> + +A coderef which returns a string of Perl code suitable for inlining this +type. Optional. + +(The coderef will be called in list context and can actually return +a list of strings which will be joined with C<< && >>. If the first item +on the list is undef, it will be substituted with the type's parent's +inline check.) + +If C (above) is a coderef generated via L, then +Type::Tiny I be able to automatically generate C for you. +If C (above) is a string, it will be able to. + +=item C<< name >> + +The name of the type constraint. These need to conform to certain naming +rules (they must begin with an uppercase letter and continue using only +letters, digits 0-9 and underscores). + +Optional; if not supplied will be an anonymous type constraint. + +=item C<< display_name >> + +A name to display for the type constraint when stringified. These don't +have to conform to any naming rules. Optional; a default name will be +calculated from the C. + +=item C<< library >> + +The package name of the type library this type is associated with. +Optional. Informational only: setting this attribute does not install +the type into the package. + +=item C<< deprecated >> + +Optional boolean indicating whether a type constraint is deprecated. +L will issue a warning if you attempt to import a deprecated +type constraint, but otherwise the type will continue to function as normal. +There will not be deprecation warnings every time you validate a value, for +instance. If omitted, defaults to the parent's deprecation status (or false +if there's no parent). + +=item C<< message >> + +Coderef that returns an error message when C<< $_ >> does not validate +against the type constraint. Optional (there's a vaguely sensible default.) + +=item C<< coercion >> + +A L object associated with this type. + +Generally speaking this attribute should not be passed to the constructor; +you should rely on the default lazily-built coercion object. + +You may pass C<< coercion => 1 >> to the constructor to inherit coercions +from the constraint's parent. (This requires the parent constraint to have +a coercion.) + +=item C<< my_methods >> + +Experimental hashref of additional methods that can be called on the type +constraint object. + +=back + +=head3 Attributes related to parameterizable and parameterized types + +The following additional attributes are used for parameterizable (e.g. +C) and parameterized (e.g. C<< ArrayRef[Int] >>) type +constraints. Unlike Moose, these aren't handled by separate subclasses. + +=over + +=item C<< constraint_generator >> + +Coderef that is called when a type constraint is parameterized. When called, +it is passed the list of parameters, though any parameter which looks like a +foreign type constraint (Moose type constraints, Mouse type constraints, etc, +I<< and coderefs(!!!) >>) is first coerced to a native Type::Tiny object. + +Note that for compatibility with the Moose API, the base type is I +passed to the constraint generator, but can be found in the package variable +C<< $Type::Tiny::parameterize_type >>. The first parameter is also available +as C<< $_ >>. + +Types I be parameterized with an empty parameter list. For example, +in L, C is just an alias for C but +C<< Tuple[] >> will only allow zero-length arrayrefs to pass the constraint. +If you wish C<< YourType >> and C<< YourType[] >> to mean the same thing, +then do: + + return $Type::Tiny::parameterize_type unless @_; + +The constraint generator should generate and return a new constraint coderef +based on the parameters. Alternatively, the constraint generator can return a +fully-formed Type::Tiny object, in which case the C, +C, and C attributes documented below +are ignored. + +Optional; providing a generator makes this type into a parameterizable +type constraint. If there is no generator, attempting to parameterize the +type constraint will throw an exception. + +=item C<< name_generator >> + +A coderef which generates a new display_name based on parameters. Called with +the same parameters and package variables as the C. +Expected to return a string. + +Optional; the default is reasonable. + +=item C<< inline_generator >> + +A coderef which generates a new inlining coderef based on parameters. Called +with the same parameters and package variables as the C. +Expected to return a coderef. + +Optional. + +=item C<< coercion_generator >> + +A coderef which generates a new L object based on parameters. +Called with the same parameters and package variables as the +C. Expected to return a blessed object. + +Optional. + +=item C<< deep_explanation >> + +This API is not finalized. Coderef used by L to +peek inside parameterized types and figure out why a value doesn't pass the +constraint. + +=item C<< parameters >> + +In parameterized types, returns an arrayref of the parameters. + +=back + +=head3 Lazy generated attributes + +The following attributes should not be usually passed to the constructor; +unless you're doing something especially unusual, you should rely on the +default lazily-built return values. + +=over + +=item C<< compiled_check >> + +Coderef to validate a value (C<< $_[0] >>) against the type constraint. +This coderef is expected to also handle all validation for the parent +type constraints. + +=item C<< complementary_type >> + +A complementary type for this type. For example, the complementary type +for an integer type would be all things that are not integers, including +floating point numbers, but also alphabetic strings, arrayrefs, filehandles, +etc. + +=item C<< moose_type >>, C<< mouse_type >> + +Objects equivalent to this type constraint, but as a +L or L. + +It should rarely be necessary to obtain a L +object from L because the L object itself should +be usable pretty much anywhere a L is expected. + +=back + +=head2 Methods + +=head3 Predicate methods + +These methods return booleans indicating information about the type +constraint. They are each tightly associated with a particular attribute. +(See L.) + +=over + +=item C, C, C, C, C, C, C, C, C + +Simple Moose-style predicate methods indicating the presence or +absence of an attribute. + +=item C + +Predicate method with a little extra DWIM. Returns false if the coercion is +a no-op. + +=item C<< is_anon >> + +Returns true iff the type constraint does not have a C. + +=item C<< is_parameterized >>, C<< is_parameterizable >> + +Indicates whether a type has been parameterized (e.g. C<< ArrayRef[Int] >>) +or could potentially be (e.g. C<< ArrayRef >>). + +=item C<< has_parameterized_from >> + +Useless alias for C. + +=back + +=head3 Validation and coercion + +The following methods are used for coercing and validating values +against a type constraint: + +=over + +=item C<< check($value) >> + +Returns true iff the value passes the type constraint. + +=item C<< validate($value) >> + +Returns the error message for the value; returns an explicit undef if the +value passes the type constraint. + +=item C<< assert_valid($value) >> + +Like C<< check($value) >> but dies if the value does not pass the type +constraint. + +Yes, that's three very similar methods. Blame L +whose API I'm attempting to emulate. :-) + +=item C<< assert_return($value) >> + +Like C<< assert_valid($value) >> but returns the value if it passes the type +constraint. + +This seems a more useful behaviour than C<< assert_valid($value) >>. I would +have just changed C<< assert_valid($value) >> to do this, except that there +are edge cases where it could break Moose compatibility. + +=item C<< get_message($value) >> + +Returns the error message for the value; even if the value passes the type +constraint. + +=item C<< validate_explain($value, $varname) >> + +Like C but instead of a string error message, returns an arrayref +of strings explaining the reasoning why the value does not meet the type +constraint, examining parent types, etc. + +The C<< $varname >> is an optional string like C<< '$foo' >> indicating the +name of the variable being checked. + +=item C<< coerce($value) >> + +Attempt to coerce C<< $value >> to this type. + +=item C<< assert_coerce($value) >> + +Attempt to coerce C<< $value >> to this type. Throws an exception if this is +not possible. + +=back + +=head3 Child type constraint creation and parameterization + +These methods generate new type constraint objects that inherit from the +constraint they are called upon: + +=over + +=item C<< create_child_type(%attributes) >> + +Construct a new Type::Tiny object with this object as its parent. + +=item C<< where($coderef) >> + +Shortcut for creating an anonymous child type constraint. Use it like +C<< HashRef->where(sub { exists($_->{name}) }) >>. That said, you can +get a similar result using overloaded C<< & >>: + + HashRef & sub { exists($_->{name}) } + +Like the C<< constraint >> attribute, this will accept a string of Perl +code: + + HashRef->where('exists($_->{name})') + +=item C<< child_type_class >> + +The class that create_child_type will construct by default. + +=item C<< parameterize(@parameters) >> + +Creates a new parameterized type; throws an exception if called on a +non-parameterizable type. + +=item C<< of(@parameters) >> + +A cute alias for C. Use it like C<< ArrayRef->of(Int) >>. + +=item C<< plus_coercions($type1, $code1, ...) >> + +Shorthand for creating a new child type constraint with the same coercions +as this one, but then adding some extra coercions (at a higher priority than +the existing ones). + +=item C<< plus_fallback_coercions($type1, $code1, ...) >> + +Like C, but added at a lower priority. + +=item C<< minus_coercions($type1, ...) >> + +Shorthand for creating a new child type constraint with fewer type coercions. + +=item C<< no_coercions >> + +Shorthand for creating a new child type constraint with no coercions at all. + +=back + +=head3 Type relationship introspection methods + +These methods allow you to determine a type constraint's relationship to +other type constraints in an organised hierarchy: + +=over + +=item C<< equals($other) >>, C<< is_subtype_of($other) >>, C<< is_supertype_of($other) >>, C<< is_a_type_of($other) >> + +Compare two types. See L for what these all mean. +(OK, Moose doesn't define C, but you get the idea, right?) + +Note that these have a slightly DWIM side to them. If you create two +L objects which test the same class, they're considered +equal. And: + + my $subtype_of_Num = Types::Standard::Num->create_child_type; + my $subtype_of_Int = Types::Standard::Int->create_child_type; + $subtype_of_Int->is_subtype_of( $subtype_of_Num ); # true + +=item C<< strictly_equals($other) >>, C<< is_strictly_subtype_of($other) >>, C<< is_strictly_supertype_of($other) >>, C<< is_strictly_a_type_of($other) >> + +Stricter versions of the type comparison functions. These only care about +explicit inheritance via C. + + my $subtype_of_Num = Types::Standard::Num->create_child_type; + my $subtype_of_Int = Types::Standard::Int->create_child_type; + $subtype_of_Int->is_strictly_subtype_of( $subtype_of_Num ); # false + +=item C<< parents >> + +Returns a list of all this type constraint's ancestor constraints. For +example, if called on the C type constraint would return the list +C<< (Value, Defined, Item, Any) >>. + +I<< Due to a historical misunderstanding, this differs from the Moose +implementation of the C method. In Moose, C only returns the +immediate parent type constraints, and because type constraints only have +one immediate parent, this is effectively an alias for C. The +extension module L is the only +place where multiple type constraints are returned; and they are returned +as an arrayref in violation of the base class' documentation. I'm keeping +my behaviour as it seems more useful. >> + +=item C<< find_parent($coderef) >> + +Loops through the parent type constraints I<< including the invocant +itself >> and returns the nearest ancestor type constraint where the +coderef evaluates to true. Within the coderef the ancestor currently +being checked is C<< $_ >>. Returns undef if there is no match. + +In list context also returns the number of type constraints which had +been looped through before the matching constraint was found. + +=item C<< find_constraining_type >> + +Finds the nearest ancestor type constraint (including the type itself) +which has a C coderef. + +Equivalent to: + + $type->find_parent(sub { not $_->_is_null_constraint }) + +=item C<< coercibles >> + +Return a type constraint which is the union of type constraints that can be +coerced to this one (including this one). If this type constraint has no +coercions, returns itself. + +=item C<< type_parameter >> + +In parameterized type constraints, returns the first item on the list of +parameters; otherwise returns undef. For example: + + ( ArrayRef[Int] )->type_parameter; # returns Int + ( ArrayRef[Int] )->parent; # returns ArrayRef + +Note that parameterizable type constraints can perfectly legitimately take +multiple parameters (several of the parameterizable type constraints in +L do). This method only returns the first such parameter. +L +documents the C attribute, which returns an arrayref of all +the parameters. + +=item C<< parameterized_from >> + +Harder to spell alias for C that only works for parameterized +types. + +=back + +I<< Hint for people subclassing Type::Tiny: >> +Since version 1.006000, the methods for determining subtype, supertype, and +type equality should I be overridden in subclasses of Type::Tiny. This +is because of the problem of diamond inheritance. If X and Y are both +subclasses of Type::Tiny, they I need to be consulted to figure out +how type constraints are related; not just one of them should be overriding +these methods. See the source code for L for an example of +how subclasses can give hints about type relationships to Type::Tiny. +Summary: push a coderef onto C<< @Type::Tiny::CMP >>. This coderef will be +passed two type constraints. It should then return one of the constants +Type::Tiny::CMP_SUBTYPE (first type is a subtype of second type), +Type::Tiny::CMP_SUPERTYPE (second type is a subtype of first type), +Type::Tiny::CMP_EQUAL (the two types are exactly the same), +Type::Tiny::CMP_EQUIVALENT (the two types are effectively the same), or +Type::Tiny::CMP_UNKNOWN (your coderef couldn't establish any relationship). + +=head3 Type relationship introspection function + +=over + +=item C<< Type::Tiny::cmp($type1, $type2) >> + +The subtype/supertype relationship between types results in a partial +ordering of type constraints. + +This function will return one of the constants: +Type::Tiny::CMP_SUBTYPE (first type is a subtype of second type), +Type::Tiny::CMP_SUPERTYPE (second type is a subtype of first type), +Type::Tiny::CMP_EQUAL (the two types are exactly the same), +Type::Tiny::CMP_EQUIVALENT (the two types are effectively the same), or +Type::Tiny::CMP_UNKNOWN (couldn't establish any relationship). +In numeric contexts, these evaluate to -1, 1, 0, 0, and 0, making it +potentially usable with C (though you may need to silence warnings +about treating the empty string as a numeric value). + +=back + +=head3 Inlining methods + +=for stopwords uated + +The following methods are used to generate strings of Perl code which +may be pasted into stringy Cuated subs to perform type checks: + +=over + +=item C<< can_be_inlined >> + +Returns boolean indicating if this type can be inlined. + +=item C<< inline_check($varname) >> + +Creates a type constraint check for a particular variable as a string of +Perl code. For example: + + print( Types::Standard::Num->inline_check('$foo') ); + +prints the following output: + + (!ref($foo) && Scalar::Util::looks_like_number($foo)) + +For Moose-compat, there is an alias C<< _inline_check >> for this method. + +=item C<< inline_assert($varname) >> + +Much like C but outputs a statement of the form: + + ... or die ...; + +Can also be called line C<< inline_assert($varname, $typevarname, %extras) >>. +In this case, it will generate a string of code that may include +C<< $typevarname >> which is supposed to be the name of a variable holding +the type itself. (This is kinda complicated, but it allows a useful string +to still be produced if the type is not inlineable.) The C<< %extras >> are +additional options to be passed to L's constructor +and must be key-value pairs of strings only, no references or undefs. + +=back + +=head3 Other methods + +=over + +=item C<< qualified_name >> + +For non-anonymous type constraints that have a library, returns a qualified +C<< "MyLib::MyType" >> sort of name. Otherwise, returns the same as C. + +=item C<< isa($class) >>, C<< can($method) >>, C<< AUTOLOAD(@args) >> + +If Moose is loaded, then the combination of these methods is used to mock +a Moose::Meta::TypeConstraint. + +If Mouse is loaded, then C mocks Mouse::Meta::TypeConstraint. + +=item C<< DOES($role) >> + +Overridden to advertise support for various roles. + +See also L, etc. + +=item C<< TIESCALAR >>, C<< TIEARRAY >>, C<< TIEHASH >> + +These are provided as hooks that wrap L. (Type::Tie is distributed +separately, and can be used with non-Type::Tiny type constraints too.) They +allow the following to work: + + use Types::Standard qw(Int); + tie my @list, Int; + push @list, 123, 456; # ok + push @list, "Hello"; # dies + +=back + +The following methods exist for Moose/Mouse compatibility, but do not do +anything useful. + +=over + +=item C<< compile_type_constraint >> + +=item C<< hand_optimized_type_constraint >> + +=item C<< has_hand_optimized_type_constraint >> + +=item C<< inline_environment >> + +=item C<< meta >> + +=back + +=head2 Overloading + +=over + +=item * + +Stringification is overloaded to return the qualified name. + +=item * + +Boolification is overloaded to always return true. + +=item * + +Coderefification is overloaded to call C. + +=item * + +On Perl 5.10.1 and above, smart match is overloaded to call C. + +=item * + +The C<< == >> operator is overloaded to call C. + +=item * + +The C<< < >> and C<< > >> operators are overloaded to call C +and C. + +=item * + +The C<< ~ >> operator is overloaded to call C. + +=item * + +The C<< | >> operator is overloaded to build a union of two type constraints. +See L. + +=item * + +The C<< & >> operator is overloaded to build the intersection of two type +constraints. See L. + +=back + +Previous versions of Type::Tiny would overload the C<< + >> operator to +call C or C as appropriate. +Support for this was dropped after 0.040. + +=head2 Constants + +=over + +=item C<< Type::Tiny::SUPPORT_SMARTMATCH >> + +Indicates whether the smart match overload is supported on your +version of Perl. + +=back + +=head2 Package Variables + +=over + +=item C<< $Type::Tiny::DD >> + +This undef by default but may be set to a coderef that Type::Tiny +and related modules will use to dump data structures in things like +error messages. + +Otherwise Type::Tiny uses it's own routine to dump data structures. +C<< $DD >> may then be set to a number to limit the lengths of the +dumps. (Default limit is 72.) + +This is a package variable (rather than get/set class methods) to allow +for easy localization. + +=item C<< $Type::Tiny::AvoidCallbacks >> + +If this variable is set to true (you should usually do it in a +C scope), it acts as a hint for type constraints, when +generating inlined code, to avoid making any callbacks to +variables and functions defined outside the inlined code itself. + +This should have the effect that C<< $type->inline_check('$foo') >> +will return a string of code capable of checking the type on +Perl installations that don't have Type::Tiny installed. This +is intended to allow Type::Tiny to be used with things like +L. + +The variable works on the honour system. Types need to explicitly +check it and decide to generate different code based on its +truth value. The bundled types in L, +L, and L all do. +(B is sometimes unable to, and will issue a warning +if it needs to rely on callbacks when asked not to.) + +Most normal users can ignore this. + +=back + +=head2 Environment + +=over + +=item C + +Currently this has more effect on L than Type::Tiny. In +future it may be used to trigger or suppress the loading XS implementations +of parts of Type::Tiny. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L, L. + +L, L, L, L. + +L, L, L, +L, L, L. + +L, +L. + +L. + +L, +L, +L, +L, +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 THANKS + +Thanks to Matt S Trout for advice on L integration. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Tiny/Class.pm @@ -0,0 +1,370 @@ +package Type::Tiny::Class; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + if ($] < 5.008) { require Devel::TypeTiny::Perl56Compat }; +} + +BEGIN { + $Type::Tiny::Class::AUTHORITY = 'cpan:TOBYINK'; + $Type::Tiny::Class::VERSION = '1.010000'; +} + +$Type::Tiny::Class::VERSION =~ tr/_//d; + +use Scalar::Util qw< blessed >; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +use Type::Tiny::ConstrainedObject (); +our @ISA = 'Type::Tiny::ConstrainedObject'; +sub _short_name { 'Class' } + +sub new { + my $proto = shift; + return $proto->class->new(@_) if blessed $proto; # DWIM + + my %opts = (@_==1) ? %{$_[0]} : @_; + _croak "Need to supply class name" unless exists $opts{class}; + + if (Type::Tiny::_USE_XS) + { + my $xsub = Type::Tiny::XS::get_coderef_for("InstanceOf[".$opts{class}."]"); + $opts{compiled_type_constraint} = $xsub if $xsub; + } + elsif (Type::Tiny::_USE_MOUSE) + { + require Mouse::Util::TypeConstraints; + my $maker = "Mouse::Util::TypeConstraints"->can("generate_isa_predicate_for"); + $opts{compiled_type_constraint} = $maker->($opts{class}) if $maker; + } + + return $proto->SUPER::new(%opts); +} + +sub class { $_[0]{class} } +sub inlined { $_[0]{inlined} ||= $_[0]->_build_inlined } + +sub has_inlined { !!1 } + +sub _is_null_constraint { 0 } + +sub _build_constraint +{ + my $self = shift; + my $class = $self->class; + return sub { blessed($_) and $_->isa($class) }; +} + +sub _build_inlined +{ + my $self = shift; + my $class = $self->class; + + if (Type::Tiny::_USE_XS) + { + my $xsub = Type::Tiny::XS::get_subname_for("InstanceOf[$class]"); + return sub { my $var = $_[1]; "$xsub\($var\)" } if $xsub; + } + + sub { + my $var = $_[1]; + qq{Scalar::Util::blessed($var) and $var->isa(q[$class])}; + }; +} + +sub _build_default_message +{ + no warnings 'uninitialized'; + my $self = shift; + my $c = $self->class; + return sub { sprintf '%s did not pass type constraint (not isa %s)', Type::Tiny::_dd($_[0]), $c } if $self->is_anon; + my $name = "$self"; + return sub { sprintf '%s did not pass type constraint "%s" (not isa %s)', Type::Tiny::_dd($_[0]), $name, $c }; +} + +sub _instantiate_moose_type +{ + my $self = shift; + my %opts = @_; + delete $opts{parent}; + delete $opts{constraint}; + delete $opts{inlined}; + require Moose::Meta::TypeConstraint::Class; + return "Moose::Meta::TypeConstraint::Class"->new(%opts, class => $self->class); +} + +sub plus_constructors +{ + my $self = shift; + + unless (@_) + { + require Types::Standard; + push @_, Types::Standard::HashRef(), "new"; + } + + require B; + require Types::TypeTiny; + + my $class = B::perlstring($self->class); + + my @r; + while (@_) + { + my $source = shift; + Types::TypeTiny::TypeTiny->check($source) + or _croak "Expected type constraint; got $source"; + + my $constructor = shift; + Types::TypeTiny::StringLike->check($constructor) + or _croak "Expected string; got $constructor"; + + push @r, $source, sprintf('%s->%s($_)', $class, $constructor); + } + + return $self->plus_coercions(\@r); +} + +sub parent +{ + $_[0]{parent} ||= $_[0]->_build_parent; +} + +sub _build_parent +{ + my $self = shift; + my $class = $self->class; + + # Some classes (I'm looking at you, Math::BigFloat) include a class in + # their @ISA to inherit methods, but then override isa() to return false, + # so that they don't appear to be a subclass. + # + # In these cases, we don't want to list the parent class as a parent + # type constraint. + # + my @isa = grep $class->isa($_), do { no strict "refs"; no warnings; @{"$class\::ISA"} }; + + if (@isa == 0) + { + require Types::Standard; + return Types::Standard::Object(); + } + + if (@isa == 1) + { + return ref($self)->new(class => $isa[0]) + } + + require Type::Tiny::Intersection; + "Type::Tiny::Intersection"->new( + type_constraints => [ map ref($self)->new(class => $_), @isa ], + ); +} + +*__get_linear_isa_dfs = eval { require mro } + ? \&mro::get_linear_isa + : sub { + no strict 'refs'; + + my $classname = shift; + my @lin = ($classname); + my %stored; + + foreach my $parent (@{"$classname\::ISA"}) + { + my $plin = __get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + + return \@lin; + }; + +sub validate_explain +{ + my $self = shift; + my ($value, $varname) = @_; + $varname = '$_' unless defined $varname; + + return undef if $self->check($value); + return ["Not a blessed reference"] unless blessed($value); + + my @isa = @{ __get_linear_isa_dfs(ref $value) }; + + my $display_var = $varname eq q{$_} ? '' : sprintf(' (in %s)', $varname); + + require Type::Utils; + return [ + sprintf('"%s" requires that the reference isa %s', $self, $self->class), + sprintf('The reference%s isa %s', $display_var, Type::Utils::english_list(@isa)), + ]; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Tiny::Class - type constraints based on the "isa" method + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Type constraints of the general form C<< { $_->isa("Some::Class") } >>. + +This package inherits from L; see that for most documentation. +Major differences are listed below: + +=head2 Constructor + +=over + +=item C + +When the constructor is called on an I of Type::Tiny::Class, it +passes the call through to the constructor of the class for the constraint. +So for example: + + my $type = Type::Tiny::Class->new(class => "Foo::Bar"); + my $obj = $type->new(hello => "World"); + say ref($obj); # prints "Foo::Bar" + +This little bit of DWIM was borrowed from L, +but Type::Tiny doesn't take the idea quite as far. + +=back + +=head2 Attributes + +=over + +=item C + +The class for the constraint. + +=item C + +Unlike Type::Tiny, you I pass a constraint coderef to the constructor. +Instead rely on the default. + +=item C + +Unlike Type::Tiny, you I pass an inlining coderef to the constructor. +Instead rely on the default. + +=item C + +Parent is automatically calculated, and cannot be passed to the constructor. + +=back + +=head2 Methods + +=over + +=item C<< plus_constructors($source, $method_name) >> + +Much like C but adds coercions that go via a constructor. +(In fact, this is implemented as a wrapper for C.) + +Example: + + package MyApp::Minion; + + use Moose; extends "MyApp::Person"; + + use Types::Standard qw( HashRef Str ); + use Type::Utils qw( class_type ); + + my $Person = class_type({ class => "MyApp::Person" }); + + has boss => ( + is => "ro", + isa => $Person->plus_constructors( + HashRef, "new", + Str, "_new_from_name", + ), + coerce => 1, + ); + + package main; + + MyApp::Minion->new( + ..., + boss => "Bob", ## via MyApp::Person->_new_from_name + ); + + MyApp::Minion->new( + ..., + boss => { name => "Bob" }, ## via MyApp::Person->new + ); + +Because coercing C via constructor is a common desire, if +you call C with no arguments at all, this is the +default. + + $classtype->plus_constructors(HashRef, "new") + $classtype->plus_constructors() ## identical to above + +This is handy for Moose/Mouse/Moo-based classes. + +=item C<< stringifies_to($constraint) >> + +See L. + +=item C<< numifies_to($constraint) >> + +See L. + +=item C<< with_attribute_values($attr1 => $constraint1, ...) >> + +See L. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Tiny/ConstrainedObject.pm @@ -0,0 +1,243 @@ +package Type::Tiny::ConstrainedObject; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Tiny::ConstrainedObject::AUTHORITY = 'cpan:TOBYINK'; + $Type::Tiny::ConstrainedObject::VERSION = '1.010000'; +} + +$Type::Tiny::ConstrainedObject::VERSION =~ tr/_//d; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +use Type::Tiny (); +our @ISA = 'Type::Tiny'; + +my %errlabel = ( + parent => 'a parent', + constraint => 'a constraint coderef', + inlined => 'an inlining coderef', +); +sub new +{ + my $proto = shift; + my %opts = (@_==1) ? %{$_[0]} : @_; + for my $key (qw/ parent constraint inlined /) { + next unless exists $opts{$key}; + _croak( + '%s type constraints cannot have %s passed to the constructor', + $proto->_short_name, + $errlabel{$key}, + ); + } + $proto->SUPER::new(%opts); +} + +sub has_parent +{ + !!1; +} + +sub parent +{ + require Types::Standard; + Types::Standard::Object(); +} + +sub _short_name +{ + die "implement this"; +} + +my $i = 0; +my $_where_expressions = sub { + my $self = shift; + my $name = shift; + $name ||= "where expression check"; + my (%env, @codes); + while (@_) { + my $expr = shift; + my $constraint = shift; + if (!ref $constraint) { + push @codes, sprintf('do { local $_ = %s; %s }', $expr, $constraint); + } + else { + require Types::Standard; + my $type = Types::Standard::is_RegexpRef($constraint) + ? Types::Standard::StrMatch()->of($constraint) + : Types::TypeTiny::to_TypeTiny($constraint); + if ($type->can_be_inlined) { + push @codes, sprintf('do { my $tmp = %s; %s }', $expr, $type->inline_check('$tmp')); + } + else { + ++$i; + $env{'$chk'.$i} = do { my $chk = $type->compiled_check; \$chk }; + push @codes, sprintf('$chk%d->(%s)', $i, $expr); + } + } + } + + if (keys %env) { + # cannot inline + my $sub = Eval::TypeTiny::eval_closure( + source => sprintf('sub ($) { local $_ = shift; %s }', join(q( and ), @codes)), + description => sprintf('%s for %s', $name, $self->name), + environment => \%env, + ); + return $self->where($sub); + } + else { + return $self->where(join(q( and ), @codes)); + } +}; + +sub stringifies_to { + my $self = shift; + my ($constraint) = @_; + $self->$_where_expressions("stringification check", q{"$_"}, $constraint); +} + +sub numifies_to { + my $self = shift; + my ($constraint) = @_; + $self->$_where_expressions("numification check", q{0+$_}, $constraint); +} + +sub with_attribute_values { + my $self = shift; + my %constraint = @_; + $self->$_where_expressions( + "attributes check", + map { my $attr = $_; qq{\$_->$attr} => $constraint{$attr} } sort keys %constraint, + ); +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Tiny::ConstrainedObject - shared behavour for Type::Tiny::Class, etc + +=head1 STATUS + +This module is considered experiemental. + +=head1 DESCRIPTION + +=head2 Methods + +The following methods exist for L, L, +L, and any type constraints that inherit from +C or C in L. + +These methods will also work for L if at least +one of the types in the intersection provides these methods. + +These methods will also work for L if all of the types +in the union provide these methods. + +=over + +=item C<< stringifies_to($constraint) >> + +Generates a new child type constraint which checks the object's +stringification against a constraint. For example: + + my $type = Type::Tiny::Class->new(class => 'URI'); + my $child = $type->stringifies_to( StrMatch[qr/^http:/] ); + + $child->assert_valid( URI->new("http://example.com/") ); + +In the above example, C<< $child >> is a type constraint that +checks objects are blessed into (or inherit from) the URI class, +and when stringified (e.g. though overloading) the result +matches the regular expression C<< qr/^http:/ >>. + +C<< $constraint >> may be a type constraint, something that +can be coerced to a type constraint (such as a coderef returning +a boolean), a string of Perl code operating on C<< $_ >>, or +a reference to a regular expression. + +So the following would work: + + my $child = $type->stringifies_to( sub { qr/^http:/ } ); + my $child = $type->stringifies_to( qr/^http:/ ); + my $child = $type->stringifies_to( 'm/^http:/' ); + + my $child = $type->where('"$_" =~ /^http:/'); + +=item C<< numifies_to($constraint) >> + +The same as C but checks numification. + +The following might be useful: + + use Types::Standard qw(Int Overload); + my $IntLike = Int | Overload->numifies_to(Int) + +=item C<< with_attribute_values($attr1 => $constraint1, ...) >> + +This is best explained with an example: + + use Types::Standard qw(InstanceOf StrMatch); + use Types::Common::Numeric qw(IntRange); + + my $person = InstanceOf['Local::Human']; + my $woman = $person->with_attribute_values( + gender => StrMatch[ qr/^F/i ], + age => IntRange[ 18 => () ], + ); + + $woman->assert_valid($alice); + +This assertion will firstly check that C<< $alice >> is a +Local::Human, then check that C<< $alice->gender >> starts +with an "F", and lastly check that C<< $alice->age >> is +an integer at least 18. + +Again, constraints can be type constraints, coderefs, +strings of Perl code, or regular expressions. + +Technically the "attributes" don't need to be Moo/Moose/Mouse +attributes, but any methods which can be called with no +parameters and return a scalar. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2019-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Tiny/Duck.pm @@ -0,0 +1,241 @@ +package Type::Tiny::Duck; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Tiny::Duck::AUTHORITY = 'cpan:TOBYINK'; + $Type::Tiny::Duck::VERSION = '1.010000'; +} + +$Type::Tiny::Duck::VERSION =~ tr/_//d; + +use Scalar::Util qw< blessed >; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +use Type::Tiny::ConstrainedObject (); +our @ISA = 'Type::Tiny::ConstrainedObject'; +sub _short_name { 'Duck' } + +sub new { + my $proto = shift; + + my %opts = (@_==1) ? %{$_[0]} : @_; + _croak "Need to supply list of methods" unless exists $opts{methods}; + + $opts{methods} = [$opts{methods}] unless ref $opts{methods}; + + if (Type::Tiny::_USE_XS) + { + my $methods = join ",", sort(@{$opts{methods}}); + my $xsub = Type::Tiny::XS::get_coderef_for("HasMethods[$methods]"); + $opts{compiled_type_constraint} = $xsub if $xsub; + } + elsif (Type::Tiny::_USE_MOUSE) + { + require Mouse::Util::TypeConstraints; + my $maker = "Mouse::Util::TypeConstraints"->can("generate_can_predicate_for"); + $opts{compiled_type_constraint} = $maker->($opts{methods}) if $maker; + } + + return $proto->SUPER::new(%opts); +} + +sub methods { $_[0]{methods} } +sub inlined { $_[0]{inlined} ||= $_[0]->_build_inlined } + +sub has_inlined { !!1 } + +sub _is_null_constraint { 0 } + +sub _build_constraint +{ + my $self = shift; + my @methods = @{$self->methods}; + return sub { blessed($_[0]) and not grep(!$_[0]->can($_), @methods) }; +} + +sub _build_inlined +{ + my $self = shift; + my @methods = @{$self->methods}; + + if (Type::Tiny::_USE_XS) + { + my $methods = join ",", sort(@{$self->methods}); + my $xsub = Type::Tiny::XS::get_subname_for("HasMethods[$methods]"); + return sub { my $var = $_[1]; "$xsub\($var\)" } if $xsub; + } + + sub { + my $var = $_[1]; + local $" = q{ }; + # If $var is $_ or $_->{foo} or $foo{$_} or somesuch, then we + # can't use it within the grep expression, so we need to save + # it into a temporary variable ($tmp). + ($var =~ /\$_/) + ? qq{ Scalar::Util::blessed($var) and not do { my \$tmp = $var; grep(!\$tmp->can(\$_), qw/@methods/) } } + : qq{ Scalar::Util::blessed($var) and not grep(!$var->can(\$_), qw/@methods/) }; + }; +} + +sub _instantiate_moose_type +{ + my $self = shift; + my %opts = @_; + delete $opts{parent}; + delete $opts{constraint}; + delete $opts{inlined}; + + require Moose::Meta::TypeConstraint::DuckType; + return "Moose::Meta::TypeConstraint::DuckType"->new(%opts, methods => $self->methods); +} + +sub validate_explain +{ + my $self = shift; + my ($value, $varname) = @_; + $varname = '$_' unless defined $varname; + + return undef if $self->check($value); + return ["Not a blessed reference"] unless blessed($value); + + require Type::Utils; + return [ + sprintf( + '"%s" requires that the reference can %s', + $self, + Type::Utils::english_list(map qq["$_"], @{$self->methods}), + ), + map sprintf('The reference cannot "%s"', $_), + grep !$value->can($_), + @{$self->methods} + ]; +} + +push @Type::Tiny::CMP, sub { + my $A = shift->find_constraining_type; + my $B = shift->find_constraining_type; + return Type::Tiny::CMP_UNKNOWN unless $A->isa(__PACKAGE__) && $B->isa(__PACKAGE__); + + my %seen; + for my $word (@{$A->methods}) { + $seen{$word} += 1; + } + for my $word (@{$B->methods}) { + $seen{$word} += 2; + } + + my $values = join('', CORE::values %seen); + if ($values =~ /^3*$/) { + return Type::Tiny::CMP_EQUIVALENT; + } + elsif ($values !~ /2/) { + return Type::Tiny::CMP_SUBTYPE; + } + elsif ($values !~ /1/) { + return Type::Tiny::CMP_SUPERTYPE; + } + + return Type::Tiny::CMP_UNKNOWN; +}; + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Tiny::Duck - type constraints based on the "can" method + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Type constraints of the general form C<< { $_->can("method") } >>. + +This package inherits from L; see that for most documentation. +Major differences are listed below: + +=head2 Attributes + +=over + +=item C + +An arrayref of method names. + +=item C + +Unlike Type::Tiny, you I pass a constraint coderef to the constructor. +Instead rely on the default. + +=item C + +Unlike Type::Tiny, you I pass an inlining coderef to the constructor. +Instead rely on the default. + +=item C + +Parent is always B, and cannot be passed to the +constructor. + +=back + +=head2 Methods + +=over + +=item C<< stringifies_to($constraint) >> + +See L. + +=item C<< numifies_to($constraint) >> + +See L. + +=item C<< with_attribute_values($attr1 => $constraint1, ...) >> + +See L. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Tiny/Enum.pm @@ -0,0 +1,331 @@ +package Type::Tiny::Enum; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Tiny::Enum::AUTHORITY = 'cpan:TOBYINK'; + $Type::Tiny::Enum::VERSION = '1.010000'; +} + +$Type::Tiny::Enum::VERSION =~ tr/_//d; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +use Type::Tiny (); +our @ISA = 'Type::Tiny'; + +__PACKAGE__->_install_overloads( + q[@{}] => sub { shift->values }, +); + +sub new +{ + my $proto = shift; + + my %opts = (@_==1) ? %{$_[0]} : @_; + _croak "Enum type constraints cannot have a parent constraint passed to the constructor" if exists $opts{parent}; + _croak "Enum type constraints cannot have a constraint coderef passed to the constructor" if exists $opts{constraint}; + _croak "Enum type constraints cannot have a inlining coderef passed to the constructor" if exists $opts{inlined}; + _croak "Need to supply list of values" unless exists $opts{values}; + + no warnings 'uninitialized'; + $opts{values} = [ + map "$_", + @{ ref $opts{values} eq 'ARRAY' ? $opts{values} : [$opts{values}] } + ]; + + my %tmp; + undef $tmp{$_} for @{$opts{values}}; + $opts{unique_values} = [sort keys %tmp]; + + if (Type::Tiny::_USE_XS and not grep /-/, @{$opts{unique_values}}) + { + my $enum = join ",", @{$opts{unique_values}}; + my $xsub = Type::Tiny::XS::get_coderef_for("Enum[$enum]"); + $opts{compiled_type_constraint} = $xsub if $xsub; + } + + return $proto->SUPER::new(%opts); +} + +sub values { $_[0]{values} } +sub unique_values { $_[0]{unique_values} } +sub constraint { $_[0]{constraint} ||= $_[0]->_build_constraint } + +sub _is_null_constraint { 0 } + +sub _build_display_name +{ + my $self = shift; + sprintf("Enum[%s]", join q[,], @{$self->unique_values}); +} + +{ + my %cached; + sub _build_constraint + { + my $self = shift; + + my $regexp = join "|", map quotemeta, sort {length $b <=> length $a || $a cmp $b } @{$self->unique_values}; + $regexp = '(?!)' unless @{$self->unique_values}; + return $cached{$regexp} if $cached{$regexp}; + my $coderef = ($cached{$regexp} = sub { defined and m{\A(?:$regexp)\z} }); + Scalar::Util::weaken($cached{$regexp}); + return $coderef; + } +} + +{ + my %cached; + sub _build_compiled_check + { + my $self = shift; + my $regexp = join "|", map quotemeta, sort {length $b <=> length $a || $a cmp $b } @{$self->unique_values}; + $regexp = '(?!)' unless @{$self->unique_values}; + return $cached{$regexp} if $cached{$regexp}; + my $coderef = ($cached{$regexp} = $self->SUPER::_build_compiled_check(@_)); + Scalar::Util::weaken($cached{$regexp}); + return $coderef; + } +} + +sub as_regexp +{ + my $self = shift; + + my $flags = @_ ? $_[0] : ''; + unless (defined $flags and $flags =~ /^[i]*$/) { + _croak("Unknown regexp flags: '$flags'; only 'i' currently accepted; stopped"); + } + + my $regexp = join "|", map quotemeta, sort {length $b <=> length $a || $a cmp $b } @{$self->unique_values}; + $regexp = '(?!)' unless @{$self->unique_values}; + + $flags ? qr/\A(?:$regexp)\z/i : qr/\A(?:$regexp)\z/; +} + +sub can_be_inlined +{ + !!1; +} + +sub inline_check +{ + my $self = shift; + + if (Type::Tiny::_USE_XS and not grep /-/, @{$self->unique_values}) + { + my $enum = join ",", @{$self->unique_values}; + my $xsub = Type::Tiny::XS::get_subname_for("Enum[$enum]"); + return "$xsub\($_[0]\)" if $xsub; + } + + my $regexp = join "|", map quotemeta, @{$self->unique_values}; + $_[0] eq '$_' + ? "(defined and !ref and m{\\A(?:$regexp)\\z})" + : "(defined($_[0]) and !ref($_[0]) and $_[0] =~ m{\\A(?:$regexp)\\z})"; +} + +sub _instantiate_moose_type +{ + my $self = shift; + my %opts = @_; + delete $opts{parent}; + delete $opts{constraint}; + delete $opts{inlined}; + require Moose::Meta::TypeConstraint::Enum; + return "Moose::Meta::TypeConstraint::Enum"->new(%opts, values => $self->values); +} + +sub has_parent +{ + !!1; +} + +sub parent +{ + require Types::Standard; + Types::Standard::Str(); +} + +sub validate_explain +{ + my $self = shift; + my ($value, $varname) = @_; + $varname = '$_' unless defined $varname; + + return undef if $self->check($value); + + require Type::Utils; + !defined($value) ? [ + sprintf( + '"%s" requires that the value is defined', + $self, + ), + ] : + @$self < 13 ? [ + sprintf( + '"%s" requires that the value is equal to %s', + $self, + Type::Utils::english_list(\"or", map B::perlstring($_), @$self), + ), + ] : + [ + sprintf( + '"%s" requires that the value is one of an enumerated list of strings', + $self, + ), + ]; +} + +push @Type::Tiny::CMP, sub { + my $A = shift->find_constraining_type; + my $B = shift->find_constraining_type; + return Type::Tiny::CMP_UNKNOWN unless $A->isa(__PACKAGE__) && $B->isa(__PACKAGE__); + + my %seen; + for my $word (@{$A->unique_values}) { + $seen{$word} += 1; + } + for my $word (@{$B->unique_values}) { + $seen{$word} += 2; + } + + my $values = join('', CORE::values %seen); + if ($values =~ /^3*$/) { + return Type::Tiny::CMP_EQUIVALENT; + } + elsif ($values !~ /2/) { + return Type::Tiny::CMP_SUPERTYPE; + } + elsif ($values !~ /1/) { + return Type::Tiny::CMP_SUBTYPE; + } + + return Type::Tiny::CMP_UNKNOWN; +}; + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Tiny::Enum - string enum type constraints + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Enum type constraints. + +This package inherits from L; see that for most documentation. +Major differences are listed below: + +=head2 Attributes + +=over + +=item C + +Arrayref of allowable value strings. Non-string values (e.g. objects with +overloading) will be stringified in the constructor. + +=item C + +Unlike Type::Tiny, you I pass a constraint coderef to the constructor. +Instead rely on the default. + +=item C + +Unlike Type::Tiny, you I pass an inlining coderef to the constructor. +Instead rely on the default. + +=item C + +Parent is always B, and cannot be passed to the +constructor. + +=item C + +The list of C but sorted and with duplicates removed. This cannot +be passed to the constructor. + +=back + +=head2 Methods + +=over + +=item C + +Returns the enum as a regexp which strings can be checked against. If you're +checking I<< a lot >> of strings, then using this regexp might be faster than +checking each string against + + my $enum = Type::Tiny::Enum->new(...); + my $check = $enum->compiled_check; + my $re = $enum->as_regexp; + + # fast + my @valid_tokens = grep $enum->check($_), @all_tokens; + + # faster + my @valid_tokens = grep $check->($_), @all_tokens; + + # fastest + my @valid_tokens = grep /$re/, @all_tokens; + +You can get a case-insensitive regexp using C<< $enum->as_regexp('i') >>. + +=back + +=head2 Overloading + +=over + +=item * + +Arrayrefification calls C. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Tiny/Intersection.pm @@ -0,0 +1,327 @@ +package Type::Tiny::Intersection; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Tiny::Intersection::AUTHORITY = 'cpan:TOBYINK'; + $Type::Tiny::Intersection::VERSION = '1.010000'; +} + +$Type::Tiny::Intersection::VERSION =~ tr/_//d; + +use Scalar::Util qw< blessed >; +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +use Type::Tiny (); +our @ISA = 'Type::Tiny'; + +__PACKAGE__->_install_overloads( + q[@{}] => sub { $_[0]{type_constraints} ||= [] }, +); + +sub new { + my $proto = shift; + + my %opts = (@_==1) ? %{$_[0]} : @_; + _croak "Intersection type constraints cannot have a parent constraint" if exists $opts{parent}; + _croak "Intersection type constraints cannot have a constraint coderef passed to the constructor" if exists $opts{constraint}; + _croak "Intersection type constraints cannot have a inlining coderef passed to the constructor" if exists $opts{inlined}; + _croak "Need to supply list of type constraints" unless exists $opts{type_constraints}; + + $opts{type_constraints} = [ + map { $_->isa(__PACKAGE__) ? @$_ : $_ } + map Types::TypeTiny::to_TypeTiny($_), + @{ ref $opts{type_constraints} eq "ARRAY" ? $opts{type_constraints} : [$opts{type_constraints}] } + ]; + + if (Type::Tiny::_USE_XS) + { + my @constraints = @{$opts{type_constraints}}; + my @known = map { + my $known = Type::Tiny::XS::is_known($_->compiled_check); + defined($known) ? $known : (); + } @constraints; + + if (@known == @constraints) + { + my $xsub = Type::Tiny::XS::get_coderef_for( + sprintf "AllOf[%s]", join(',', @known) + ); + $opts{compiled_type_constraint} = $xsub if $xsub; + } + } + + return $proto->SUPER::new(%opts); +} + +sub type_constraints { $_[0]{type_constraints} } +sub constraint { $_[0]{constraint} ||= $_[0]->_build_constraint } + +sub _is_null_constraint { 0 } + +sub _build_display_name +{ + my $self = shift; + join q[&], @$self; +} + +sub _build_constraint +{ + my @checks = map $_->compiled_check, @{+shift}; + return sub + { + my $val = $_; + $_->($val) || return for @checks; + return !!1; + } +} + +sub can_be_inlined +{ + my $self = shift; + not grep !$_->can_be_inlined, @$self; +} + +sub inline_check +{ + my $self = shift; + + if (Type::Tiny::_USE_XS and !exists $self->{xs_sub}) + { + $self->{xs_sub} = undef; + + my @constraints = @{$self->type_constraints}; + my @known = map { + my $known = Type::Tiny::XS::is_known($_->compiled_check); + defined($known) ? $known : (); + } @constraints; + + if (@known == @constraints) + { + $self->{xs_sub} = Type::Tiny::XS::get_subname_for( + sprintf "AllOf[%s]", join(',', @known) + ); + } + } + + if (Type::Tiny::_USE_XS and $self->{xs_sub}) { + return "$self->{xs_sub}\($_[0]\)"; + } + + sprintf '(%s)', join " and ", map $_->inline_check($_[0]), @$self; +} + +sub has_parent +{ + !!@{ $_[0]{type_constraints} }; +} + +sub parent +{ + $_[0]{type_constraints}[0]; +} + +sub validate_explain +{ + my $self = shift; + my ($value, $varname) = @_; + $varname = '$_' unless defined $varname; + + return undef if $self->check($value); + + require Type::Utils; + for my $type (@$self) + { + my $deep = $type->validate_explain($value, $varname); + return [ + sprintf( + '"%s" requires that the value pass %s', + $self, + Type::Utils::english_list(map qq["$_"], @$self), + ), + @$deep, + ] if $deep; + } + + # This should never happen... + return; # uncoverable statement +} + +my $_delegate = sub { + my ($self, $method) = (shift, shift); + my @types = @{ $self->type_constraints }; + my $found = 0; + for my $i (0 .. $#types) { + my $type = $types[$i]; + if ($type->can($method)) { + $types[$i] = $type->$method(@_); + ++$found; + last; + } + } + _croak('Could not apply method %s to any type within the intersection', $method) unless $found; + ref($self)->new(type_constraints => \@types); +}; + +sub stringifies_to { + my $self = shift; + $self->$_delegate(stringifies_to => @_); +} + +sub numifies_to { + my $self = shift; + $self->$_delegate(numifies_to => @_); +} + +sub with_attribute_values { + my $self = shift; + $self->$_delegate(with_attribute_values => @_); +} + +my $comparator; +$comparator = sub { + my $A = shift->find_constraining_type; + my $B = shift->find_constraining_type; + + if ($A->isa(__PACKAGE__)) { + my @A_constraints = map $_->find_constraining_type, @{ $A->type_constraints }; + + my @A_equal_to_B = grep $_->equals($B), @A_constraints; + if (@A_equal_to_B == @A_constraints) { + return Type::Tiny::CMP_EQUIVALENT(); + } + + my @A_subs_of_B = grep $_->is_a_type_of($B), @A_constraints; + if (@A_subs_of_B) { + return Type::Tiny::CMP_SUBTYPE(); + } + } + + elsif ($B->isa(__PACKAGE__)) { + my $r = $comparator->($B, $A); + return $r if $r eq Type::Tiny::CMP_EQUIVALENT(); + return -$r if $r eq Type::Tiny::CMP_SUBTYPE(); + } + + return Type::Tiny::CMP_UNKNOWN(); +}; +push @Type::Tiny::CMP, $comparator; + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Tiny::Intersection - intersection type constraints + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Intersection type constraints. + +This package inherits from L; see that for most documentation. +Major differences are listed below: + +=head2 Attributes + +=over + +=item C + +Arrayref of type constraints. + +When passed to the constructor, if any of the type constraints in the +intersection is itself an intersection type constraint, this is "exploded" +into the new intersection. + +=item C + +Unlike Type::Tiny, you I pass a constraint coderef to the constructor. +Instead rely on the default. + +=item C + +Unlike Type::Tiny, you I pass an inlining coderef to the constructor. +Instead rely on the default. + +=item C + +Unlike Type::Tiny, you I pass an inlining coderef to the constructor. +A parent will instead be automatically calculated. + +(Technically any of the types in the intersection could be treated as a +parent type; we choose the first arbitrarily.) + +=back + +=head2 Methods + +=over + +=item C<< stringifies_to($constraint) >> + +See L. + +=item C<< numifies_to($constraint) >> + +See L. + +=item C<< with_attribute_values($attr1 => $constraint1, ...) >> + +See L. + +=back + +=head2 Overloading + +=over + +=item * + +Arrayrefification calls C. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Tiny/Role.pm @@ -0,0 +1,182 @@ +package Type::Tiny::Role; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Tiny::Role::AUTHORITY = 'cpan:TOBYINK'; + $Type::Tiny::Role::VERSION = '1.010000'; +} + +$Type::Tiny::Role::VERSION =~ tr/_//d; + +use Scalar::Util qw< blessed weaken >; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +use Type::Tiny::ConstrainedObject (); +our @ISA = 'Type::Tiny::ConstrainedObject'; +sub _short_name { 'Role' } + +my %cache; + +sub new { + my $proto = shift; + my %opts = (@_==1) ? %{$_[0]} : @_; + _croak "Need to supply role name" unless exists $opts{role}; + return $proto->SUPER::new(%opts); +} + +sub role { $_[0]{role} } +sub inlined { $_[0]{inlined} ||= $_[0]->_build_inlined } + +sub has_inlined { !!1 } + +sub _is_null_constraint { 0 } + +sub _build_constraint +{ + my $self = shift; + my $role = $self->role; + return sub { blessed($_) and do { my $method = $_->can('DOES')||$_->can('isa'); $_->$method($role) } }; +} + +sub _build_inlined +{ + my $self = shift; + my $role = $self->role; + sub { + my $var = $_[1]; + qq{Scalar::Util::blessed($var) and do { my \$method = $var->can('DOES')||$var->can('isa'); $var->\$method(q[$role]) }}; + }; +} + +sub _build_default_message +{ + my $self = shift; + my $c = $self->role; + return sub { sprintf '%s did not pass type constraint (not DOES %s)', Type::Tiny::_dd($_[0]), $c } if $self->is_anon; + my $name = "$self"; + return sub { sprintf '%s did not pass type constraint "%s" (not DOES %s)', Type::Tiny::_dd($_[0]), $name, $c }; +} + +sub validate_explain +{ + my $self = shift; + my ($value, $varname) = @_; + $varname = '$_' unless defined $varname; + + return undef if $self->check($value); + return ["Not a blessed reference"] unless blessed($value); + return ["Reference provides no DOES method to check roles"] unless $value->can('DOES'); + + my $display_var = $varname eq q{$_} ? '' : sprintf(' (in %s)', $varname); + + return [ + sprintf('"%s" requires that the reference does %s', $self, $self->role), + sprintf("The reference%s doesn't %s", $display_var, $self->role), + ]; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Tiny::Role - type constraints based on the "DOES" method + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Type constraints of the general form C<< { $_->DOES("Some::Role") } >>. + +This package inherits from L; see that for most documentation. +Major differences are listed below: + +=head2 Attributes + +=over + +=item C + +The role for the constraint. + +Note that this package doesn't subscribe to any particular flavour of roles +(L, L, L, L, etc). It simply +trusts the object's C method (see L). + +=item C + +Unlike Type::Tiny, you I pass a constraint coderef to the constructor. +Instead rely on the default. + +=item C + +Unlike Type::Tiny, you I pass an inlining coderef to the constructor. +Instead rely on the default. + +=item C + +Parent is always B, and cannot be passed to the +constructor. + +=back + +=head2 Methods + +=over + +=item C<< stringifies_to($constraint) >> + +See L. + +=item C<< numifies_to($constraint) >> + +See L. + +=item C<< with_attribute_values($attr1 => $constraint1, ...) >> + +See L. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Tiny/Union.pm @@ -0,0 +1,458 @@ +package Type::Tiny::Union; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Tiny::Union::AUTHORITY = 'cpan:TOBYINK'; + $Type::Tiny::Union::VERSION = '1.010000'; +} + +$Type::Tiny::Union::VERSION =~ tr/_//d; + +use Scalar::Util qw< blessed >; +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +use Type::Tiny (); +our @ISA = 'Type::Tiny'; + +__PACKAGE__->_install_overloads( + q[@{}] => sub { $_[0]{type_constraints} ||= [] } +); + +sub new { + my $proto = shift; + + my %opts = (@_==1) ? %{$_[0]} : @_; + _croak "Union type constraints cannot have a parent constraint passed to the constructor" if exists $opts{parent}; + _croak "Union type constraints cannot have a constraint coderef passed to the constructor" if exists $opts{constraint}; + _croak "Union type constraints cannot have a inlining coderef passed to the constructor" if exists $opts{inlined}; + _croak "Need to supply list of type constraints" unless exists $opts{type_constraints}; + + $opts{type_constraints} = [ + map { $_->isa(__PACKAGE__) ? @$_ : $_ } + map Types::TypeTiny::to_TypeTiny($_), + @{ ref $opts{type_constraints} eq "ARRAY" ? $opts{type_constraints} : [$opts{type_constraints}] } + ]; + + if (Type::Tiny::_USE_XS) + { + my @constraints = @{$opts{type_constraints}}; + my @known = map { + my $known = Type::Tiny::XS::is_known($_->compiled_check); + defined($known) ? $known : (); + } @constraints; + + if (@known == @constraints) + { + my $xsub = Type::Tiny::XS::get_coderef_for( + sprintf "AnyOf[%s]", join(',', @known) + ); + $opts{compiled_type_constraint} = $xsub if $xsub; + } + } + + my $self = $proto->SUPER::new(%opts); + $self->coercion if grep $_->has_coercion, @$self; + return $self; +} + +sub type_constraints { $_[0]{type_constraints} } +sub constraint { $_[0]{constraint} ||= $_[0]->_build_constraint } + +sub _is_null_constraint { 0 } + +sub _build_display_name +{ + my $self = shift; + join q[|], @$self; +} + +sub _build_coercion +{ + require Type::Coercion::Union; + my $self = shift; + return "Type::Coercion::Union"->new(type_constraint => $self); +} + +sub _build_constraint +{ + my @checks = map $_->compiled_check, @{+shift}; + return sub + { + my $val = $_; + $_->($val) && return !!1 for @checks; + return; + } +} + +sub can_be_inlined +{ + my $self = shift; + not grep !$_->can_be_inlined, @$self; +} + +sub inline_check +{ + my $self = shift; + + if (Type::Tiny::_USE_XS and !exists $self->{xs_sub}) + { + $self->{xs_sub} = undef; + + my @constraints = @{$self->type_constraints}; + my @known = map { + my $known = Type::Tiny::XS::is_known($_->compiled_check); + defined($known) ? $known : (); + } @constraints; + + if (@known == @constraints) + { + $self->{xs_sub} = Type::Tiny::XS::get_subname_for( + sprintf "AnyOf[%s]", join(',', @known) + ); + } + } + + if (Type::Tiny::_USE_XS and $self->{xs_sub}) { + return "$self->{xs_sub}\($_[0]\)"; + } + + sprintf '(%s)', join " or ", map $_->inline_check($_[0]), @$self; +} + +sub _instantiate_moose_type +{ + my $self = shift; + my %opts = @_; + delete $opts{parent}; + delete $opts{constraint}; + delete $opts{inlined}; + + my @tc = map $_->moose_type, @{$self->type_constraints}; + + require Moose::Meta::TypeConstraint::Union; + return "Moose::Meta::TypeConstraint::Union"->new(%opts, type_constraints => \@tc); +} + +sub has_parent +{ + defined(shift->parent); +} + +sub parent +{ + $_[0]{parent} ||= $_[0]->_build_parent; +} + +sub _build_parent +{ + my $self = shift; + my ($first, @rest) = @$self; + + for my $parent ($first, $first->parents) + { + return $parent unless grep !$_->is_a_type_of($parent), @rest; + } + + return; +} + +sub find_type_for +{ + my @types = @{+shift}; + for my $type (@types) + { + return $type if $type->check(@_); + } + return; +} + +sub validate_explain +{ + my $self = shift; + my ($value, $varname) = @_; + $varname = '$_' unless defined $varname; + + return undef if $self->check($value); + + require Type::Utils; + return [ + sprintf( + '"%s" requires that the value pass %s', + $self, + Type::Utils::english_list(\"or", map qq["$_"], @$self), + ), + map { + $_->get_message($value), + map(" $_", @{ $_->validate_explain($value) || []}), + } @$self + ]; +} + +my $_delegate = sub { + my ($self, $method) = (shift, shift); + my @types = @{ $self->type_constraints }; + + my @unsupported = grep !$_->can($method), @types; + _croak('Could not apply method %s to all types within the union', $method) if @unsupported; + + ref($self)->new(type_constraints => [ map $_->$method(@_), @types ]); +}; + +sub stringifies_to { + my $self = shift; + $self->$_delegate(stringifies_to => @_); +} + +sub numifies_to { + my $self = shift; + $self->$_delegate(numifies_to => @_); +} + +sub with_attribute_values { + my $self = shift; + $self->$_delegate(with_attribute_values => @_); +} + +push @Type::Tiny::CMP, sub { + my $A = shift->find_constraining_type; + my $B = shift->find_constraining_type; + + if ($A->isa(__PACKAGE__) and $B->isa(__PACKAGE__)) { + my @A_constraints = @{ $A->type_constraints }; + my @B_constraints = @{ $B->type_constraints }; + + # If everything in @A_constraints is equal to something in @B_constraints and vice versa, then $A equiv to $B + EQUALITY: { + my $everything_in_a_is_equal = 1; + OUTER: for my $A_child (@A_constraints) { + INNER: for my $B_child (@B_constraints) { + if ($A_child->equals($B_child)) { + next OUTER; + } + } + $everything_in_a_is_equal = 0; + last OUTER; + } + + my $everything_in_b_is_equal = 1; + OUTER: for my $B_child (@B_constraints) { + INNER: for my $A_child (@A_constraints) { + if ($B_child->equals($A_child)) { + next OUTER; + } + } + $everything_in_b_is_equal = 0; + last OUTER; + } + + return Type::Tiny::CMP_EQUIVALENT + if $everything_in_a_is_equal && $everything_in_b_is_equal; + } + + # If everything in @A_constraints is a subtype of something in @B_constraints, then $A is subtype of $B + SUBTYPE: { + OUTER: for my $A_child (@A_constraints) { + my $a_child_is_subtype_of_something = 0; + INNER: for my $B_child (@B_constraints) { + if ($A_child->is_a_type_of($B_child)) { + ++$a_child_is_subtype_of_something; + last INNER; + } + } + if (not $a_child_is_subtype_of_something) { + last SUBTYPE; + } + } + return Type::Tiny::CMP_SUBTYPE; + } + + # If everything in @B_constraints is a subtype of something in @A_constraints, then $A is supertype of $B + SUPERTYPE: { + OUTER: for my $B_child (@B_constraints) { + my $b_child_is_subtype_of_something = 0; + INNER: for my $A_child (@A_constraints) { + if ($B_child->is_a_type_of($A_child)) { + ++$b_child_is_subtype_of_something; + last INNER; + } + } + if (not $b_child_is_subtype_of_something) { + last SUPERTYPE; + } + } + return Type::Tiny::CMP_SUPERTYPE; + } + } + + # I think it might be possible to merge this into the first bit by treating $B as union[$B]. + # Test cases first though. + if ($A->isa(__PACKAGE__)) { + my @A_constraints = @{ $A->type_constraints }; + if (@A_constraints == 1) { + my $result = Type::Tiny::cmp($A_constraints[0], $B); + return $result unless $result eq Type::Tiny::CMP_UNKNOWN; + } + my $subtype = 1; + for my $child (@A_constraints) { + if ($B->is_a_type_of($child)) { + return Type::Tiny::CMP_SUPERTYPE; + } + if ($subtype and not $B->is_supertype_of($child)) { + $subtype = 0; + } + } + if ($subtype) { + return Type::Tiny::CMP_SUBTYPE; + } + } + + # I think it might be possible to merge this into the first bit by treating $A as union[$A]. + # Test cases first though. + if ($B->isa(__PACKAGE__)) { + my @B_constraints = @{ $B->type_constraints }; + if (@B_constraints == 1) { + my $result = Type::Tiny::cmp($A, $B_constraints[0]); + return $result unless $result eq Type::Tiny::CMP_UNKNOWN; + } + my $supertype = 1; + for my $child (@B_constraints) { + if ($A->is_a_type_of($child)) { + return Type::Tiny::CMP_SUBTYPE; + } + if ($supertype and not $A->is_supertype_of($child)) { + $supertype = 0; + } + } + if ($supertype) { + return Type::Tiny::CMP_SUPERTYPE; + } + } + + return Type::Tiny::CMP_UNKNOWN; +}; + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Type::Tiny::Union - union type constraints + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Union type constraints. + +This package inherits from L; see that for most documentation. +Major differences are listed below: + +=head2 Attributes + +=over + +=item C + +Arrayref of type constraints. + +When passed to the constructor, if any of the type constraints in the union +is itself a union type constraint, this is "exploded" into the new union. + +=item C + +Unlike Type::Tiny, you I pass a constraint coderef to the constructor. +Instead rely on the default. + +=item C + +Unlike Type::Tiny, you I pass an inlining coderef to the constructor. +Instead rely on the default. + +=item C + +Unlike Type::Tiny, you I pass an inlining coderef to the constructor. +A parent will instead be automatically calculated. + +=item C + +You probably do not pass this to the constructor. (It's not currently +disallowed, as there may be a use for it that I haven't thought of.) + +The auto-generated default will be a L object. + +=back + +=head2 Methods + +=over + +=item C<< find_type_for($value) >> + +Returns the first individual type constraint in the union which +C<< $value >> passes. + +=item C<< stringifies_to($constraint) >> + +See L. + +=item C<< numifies_to($constraint) >> + +See L. + +=item C<< with_attribute_values($attr1 => $constraint1, ...) >> + +See L. + +=back + +=head2 Overloading + +=over + +=item * + +Arrayrefification calls C. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Tiny/_HalfOp.pm @@ -0,0 +1,94 @@ +package Type::Tiny::_HalfOp; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Tiny::_HalfOp::AUTHORITY = 'cpan:TOBYINK'; + $Type::Tiny::_HalfOp::VERSION = '1.010000'; +} + +$Type::Tiny::_HalfOp::VERSION =~ tr/_//d; + +sub new { + my ($class, $op, $param, $type) = @_; + bless { + op => $op, + param => $param, + type => $type, + }, $class; +} + +sub complete { + require overload; + my ($self, $type) = @_; + my $complete_type = $type->parameterize(@{$self->{param}}); + my $method = overload::Method($complete_type, $self->{op}); + $complete_type->$method($self->{type}); +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords pragmas + +=head1 NAME + +Type::Tiny::_HalfOp - half-completed overloaded operation + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This is not considered part of Type::Tiny's public API. + +It is a class representing a half-completed overloaded operation. + +=head2 Constructor + +=over + +=item C<< new($operation, $param, $type) >> + +=back + +=head2 Method + +=over + +=item C<< complete($type) >> + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 AUTHOR + +Graham Knop Ehaarg@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2014, 2017-2020 by Graham Knop. + +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. + --- /dev/null +++ b/Kernel/cpan-lib/Type/Utils.pm @@ -0,0 +1,1131 @@ +package Type::Utils; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Type::Utils::AUTHORITY = 'cpan:TOBYINK'; + $Type::Utils::VERSION = '1.010000'; +} + +$Type::Utils::VERSION =~ tr/_//d; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +use Scalar::Util qw< blessed >; +use Type::Library; +use Type::Tiny; +use Types::TypeTiny qw< TypeTiny to_TypeTiny HashLike StringLike CodeLike >; + +our @EXPORT = qw< + declare as where message inline_as + class_type role_type duck_type union intersection enum + coerce from via + declare_coercion to_type +>; +our @EXPORT_OK = ( + @EXPORT, + qw< + extends type subtype + match_on_type compile_match_on_type + dwim_type english_list + classifier + >, +); + +require Exporter::Tiny; +our @ISA = 'Exporter::Tiny'; + +sub extends +{ + _croak "Not a type library" unless caller->isa("Type::Library"); + my $caller = caller->meta; + + foreach my $lib (@_) + { + eval "use $lib; 1" or _croak "Could not load library '$lib': $@"; + + if ($lib->isa("Type::Library") or $lib eq 'Types::TypeTiny') + { + $caller->add_type( $lib->get_type($_) ) + for sort $lib->meta->type_names; + $caller->add_coercion( $lib->get_coercion($_) ) + for sort $lib->meta->coercion_names; + } + elsif ($lib->isa('MooseX::Types::Base')) + { + require Moose::Util::TypeConstraints; + my $types = $lib->type_storage; + for my $name (sort keys %$types) + { + my $moose = Moose::Util::TypeConstraints::find_type_constraint($types->{$name}); + my $tt = Types::TypeTiny::to_TypeTiny($moose); + my $c = $moose->has_coercion && @{ $moose->coercion->type_coercion_map || [] }; + $caller->add_type( + $tt->create_child_type(library => $caller, name => $name, coercion => $c ? 1 : 0) + ); + } + } + elsif ($lib->isa('MouseX::Types::Base')) + { + require Mouse::Util::TypeConstraints; + my $types = $lib->type_storage; + for my $name (sort keys %$types) + { + my $mouse = Mouse::Util::TypeConstraints::find_type_constraint($types->{$name}); + my $tt = Types::TypeTiny::to_TypeTiny($mouse); + $caller->add_type( + $tt->create_child_type(library => $caller, name => $name, coercion => $mouse->has_coercion ? 1 : 0) + ); + } + } + elsif ($lib->isa('Specio::Exporter')) + { + my $types = $lib->Specio::Registry::exportable_types_for_package; + for my $name (sort keys %$types) + { + my $specio = $types->{$name}; + my $tt = Types::TypeTiny::to_TypeTiny($specio); + $caller->add_type( + $tt->create_child_type(library => $caller, name => $name) + ); + } + } + else + { + _croak("'$lib' is not a type constraint library"); + } + } +} + +sub declare +{ + my %opts; + if (@_ % 2 == 0) + { + %opts = @_; + if (@_==2 and $_[0]=~ /^_*[A-Z]/ and $_[1] =~ /^[0-9]+$/) + { + require Carp; + Carp::carp("Possible missing comma after 'declare $_[0]'"); + } + } + else + { + (my($name), %opts) = @_; + _croak "Cannot provide two names for type" if exists $opts{name}; + $opts{name} = $name; + } + + my $caller = caller($opts{_caller_level} || 0); + $opts{library} = $caller; + + if (defined $opts{parent}) + { + $opts{parent} = to_TypeTiny($opts{parent}); + + unless (TypeTiny->check($opts{parent})) + { + $caller->isa("Type::Library") + or _croak("Parent type cannot be a %s", ref($opts{parent})||'non-reference scalar'); + $opts{parent} = $caller->meta->get_type($opts{parent}) + or _croak("Could not find parent type"); + } + } + + my $type; + if (defined $opts{parent}) + { + $type = delete($opts{parent})->create_child_type(%opts); + } + else + { + my $bless = delete($opts{bless}) || "Type::Tiny"; + eval "require $bless"; + $type = $bless->new(%opts); + } + + if ($caller->isa("Type::Library")) + { + $caller->meta->add_type($type) unless $type->is_anon; + } + + return $type; +} + +*subtype = \&declare; +*type = \&declare; + +sub as (@) +{ + parent => @_; +} + +sub where (&;@) +{ + constraint => @_; +} + +sub message (&;@) +{ + message => @_; +} + +sub inline_as (&;@) +{ + inlined => @_; +} + +sub class_type +{ + my $name = ref($_[0]) eq 'HASH' ? undef : shift; + my %opts = %{ shift or {} }; + + if (defined $name) + { + $opts{name} = $name unless exists $opts{name}; + $opts{class} = $name unless exists $opts{class}; + + $opts{name} =~ s/:://g; + } + + $opts{bless} = "Type::Tiny::Class"; + + { no warnings "numeric"; $opts{_caller_level}++ } + declare(%opts); +} + +sub role_type +{ + my $name = ref($_[0]) eq 'HASH' ? undef : shift; + my %opts = %{ shift or {} }; + + if (defined $name) + { + $opts{name} = $name unless exists $opts{name}; + $opts{role} = $name unless exists $opts{role}; + + $opts{name} =~ s/:://g; + } + + $opts{bless} = "Type::Tiny::Role"; + + { no warnings "numeric"; $opts{_caller_level}++ } + declare(%opts); +} + +sub duck_type +{ + my $name = ref($_[0]) eq 'ARRAY' ? undef : shift; + my @methods = @{ shift or [] }; + + my %opts; + $opts{name} = $name if defined $name; + $opts{methods} = \@methods; + + $opts{bless} = "Type::Tiny::Duck"; + + { no warnings "numeric"; $opts{_caller_level}++ } + declare(%opts); +} + +sub enum +{ + my $name = ref($_[0]) eq 'ARRAY' ? undef : shift; + my @values = @{ shift or [] }; + + my %opts; + $opts{name} = $name if defined $name; + $opts{values} = \@values; + + $opts{bless} = "Type::Tiny::Enum"; + + { no warnings "numeric"; $opts{_caller_level}++ } + declare(%opts); +} + +sub union +{ + my $name = ref($_[0]) eq 'ARRAY' ? undef : shift; + my @tcs = @{ shift or [] }; + + my %opts; + $opts{name} = $name if defined $name; + $opts{type_constraints} = \@tcs; + + $opts{bless} = "Type::Tiny::Union"; + + { no warnings "numeric"; $opts{_caller_level}++ } + declare(%opts); +} + +sub intersection +{ + my $name = ref($_[0]) eq 'ARRAY' ? undef : shift; + my @tcs = @{ shift or [] }; + + my %opts; + $opts{name} = $name if defined $name; + $opts{type_constraints} = \@tcs; + + $opts{bless} = "Type::Tiny::Intersection"; + + { no warnings "numeric"; $opts{_caller_level}++ } + declare(%opts); +} + +sub declare_coercion +{ + my %opts; + $opts{name} = shift if !ref($_[0]); + + # I don't like this; it is a hack + if (ref($_[0]) eq 'Type::Tiny::_DeclaredType') { + $opts{name} = '' . shift; + } + + while (HashLike->check($_[0]) and not TypeTiny->check($_[0])) + { + %opts = (%opts, %{+shift}); + } + + my $caller = caller($opts{_caller_level} || 0); + $opts{library} = $caller; + + my $bless = delete($opts{bless}) || "Type::Coercion"; + eval "require $bless"; + my $c = $bless->new(%opts); + + my @C; + + if ($caller->isa("Type::Library")) + { + my $meta = $caller->meta; + $meta->add_coercion($c) unless $c->is_anon; + while (@_) + { + push @C, map { ref($_) ? to_TypeTiny($_) : $meta->get_type($_)||$_ } shift; + push @C, shift; + } + } + else + { + @C = @_; + } + + $c->add_type_coercions(@C); + + return $c->freeze; +} + +sub coerce +{ + if ((scalar caller)->isa("Type::Library")) + { + my $meta = (scalar caller)->meta; + my ($type) = map { ref($_) ? to_TypeTiny($_) : $meta->get_type($_)||$_ } shift; + my @opts; + while (@_) + { + push @opts, map { ref($_) ? to_TypeTiny($_) : $meta->get_type($_)||$_ } shift; + push @opts, shift; + } + return $type->coercion->add_type_coercions(@opts); + } + + my ($type, @opts) = @_; + $type = to_TypeTiny($type); + return $type->coercion->add_type_coercions(@opts); +} + +sub from (@) +{ + return @_; +} + +sub to_type (@) +{ + my $type = shift; + unless (TypeTiny->check($type)) + { + caller->isa("Type::Library") + or _croak "Target type cannot be a string"; + $type = caller->meta->get_type($type) + or _croak "Could not find target type"; + } + return +{ type_constraint => $type }, @_; +} + +sub via (&;@) +{ + return @_; +} + +sub match_on_type +{ + my $value = shift; + + while (@_) + { + my $code; + if (@_ == 1) + { + $code = shift; + } + else + { + (my($type), $code) = splice(@_, 0, 2); + TypeTiny->($type)->check($value) or next; + } + + if (StringLike->check($code)) + { + local $_ = $value; + if (wantarray) { + my @r = eval "$code"; + die $@ if $@; + return @r; + } + if (defined wantarray) { + my $r = eval "$code"; + die $@ if $@; + return $r; + } + eval "$code"; + die $@ if $@; + return; + } + else + { + CodeLike->($code); + local $_ = $value; + return $code->($value); + } + } + + _croak("No cases matched for %s", Type::Tiny::_dd($value)); +} + +sub compile_match_on_type +{ + my @code = 'sub { local $_ = $_[0]; '; + my @checks; + my @actions; + + my $els = ''; + + while (@_) + { + my ($type, $code); + if (@_ == 1) + { + require Types::Standard; + ($type, $code) = (Types::Standard::Any(), shift); + } + else + { + ($type, $code) = splice(@_, 0, 2); + TypeTiny->($type); + } + + if ($type->can_be_inlined) + { + push @code, sprintf('%sif (%s)', $els, $type->inline_check('$_')); + } + else + { + push @checks, $type; + push @code, sprintf('%sif ($checks[%d]->check($_))', $els, $#checks); + } + + $els = 'els'; + + if (StringLike->check($code)) + { + push @code, sprintf(' { %s }', $code); + } + else + { + CodeLike->($code); + push @actions, $code; + push @code, sprintf(' { $actions[%d]->(@_) }', $#actions); + } + } + + push @code, 'else', ' { Type::Utils::_croak("No cases matched for %s", Type::Tiny::_dd($_[0])) }'; + + push @code, '}'; # /sub + + require Eval::TypeTiny; + return Eval::TypeTiny::eval_closure( + source => \@code, + environment => { + '@actions' => \@actions, + '@checks' => \@checks, + }, + ); +} + +sub classifier +{ + my $i; + compile_match_on_type( + +( + map { + my $type = $_->[0]; + $type => sub { $type }; + } + sort { $b->[1] <=> $a->[1] or $a->[2] <=> $b->[2] } + map [$_, scalar(my @parents = $_->parents), ++$i], + @_ + ), + q[ undef ], + ); +} + +{ + package #hide + Type::Registry::DWIM; + + our @ISA = qw(Type::Registry); + + sub foreign_lookup + { + my $self = shift; + my $r = $self->SUPER::foreign_lookup(@_); + return $r if $r; + + if (my $assume = $self->{"~~assume"} + and $_[0] =~ /[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/) + { + my @methods = ref($assume) ? @$assume : $assume; + + for my $method (@methods) + { + $r = $self->$method(@_); + return $r if $r; + } + } + + return; + } + + sub lookup_via_moose + { + my $self = shift; + + if ($INC{'Moose.pm'}) + { + require Moose::Util::TypeConstraints; + require Types::TypeTiny; + my $r = Moose::Util::TypeConstraints::find_type_constraint($_[0]); + return Types::TypeTiny::to_TypeTiny($r) if defined $r; + } + + return; + } + + sub lookup_via_mouse + { + my $self = shift; + + if ($INC{'Mouse.pm'}) + { + require Mouse::Util::TypeConstraints; + require Types::TypeTiny; + my $r = Mouse::Util::TypeConstraints::find_type_constraint($_[0]); + return Types::TypeTiny::to_TypeTiny($r) if defined $r; + } + + return; + } + + sub simple_lookup + { + my $self = shift; + my $r; + + # If the lookup is chained to a class, then the class' own + # type registry gets first refusal. + # + if (defined $self->{"~~chained"}) + { + my $chained = "Type::Registry"->for_class($self->{"~~chained"}); + $r = eval { $chained->simple_lookup(@_) } unless $self == $chained; + return $r if defined $r; + } + + # Fall back to types in Types::Standard. + require Types::Standard; + return 'Types::Standard'->get_type($_[0]) if 'Types::Standard'->has_type($_[0]); + + # Only continue any further if we've been called from Type::Parser. + return unless $_[1]; + + my $meta; + if (defined $self->{"~~chained"}) + { + $meta ||= Moose::Util::find_meta($self->{"~~chained"}) if $INC{'Moose.pm'}; + $meta ||= Mouse::Util::find_meta($self->{"~~chained"}) if $INC{'Mouse.pm'}; + } + + if ($meta and $meta->isa('Class::MOP::Module')) + { + $r = $self->lookup_via_moose(@_); + return $r if $r; + } + + elsif ($meta and $meta->isa('Mouse::Meta::Module')) + { + $r = $self->lookup_via_mouse(@_); + return $r if $r; + } + + return $self->foreign_lookup(@_); + } +} + +our $dwimmer; +sub dwim_type +{ + my ($string, %opts) = @_; + $opts{for} = caller unless defined $opts{for}; + + $dwimmer ||= do { + require Type::Registry; + 'Type::Registry::DWIM'->new; + }; + + local $dwimmer->{'~~chained'} = $opts{for}; + local $dwimmer->{'~~assume'} = $opts{fallback} || [ + qw/ lookup_via_moose lookup_via_mouse /, + $opts{does} ? 'make_role_type' : 'make_class_type', + ]; + + local $@ = undef; + my $type; + unless (eval { $type = $dwimmer->lookup($string); 1 }) + { + my $e = $@; + die($e) unless $e =~ /not a known type constraint/; + } + + $type; +} + +sub english_list +{ + my $conjunction = ref($_[0]) eq 'SCALAR' ? ${+shift} : 'and'; + my @items = sort @_; + + return $items[0] if @items == 1; + return "$items[0] $conjunction $items[1]" if @items == 2; + + my $tail = pop @items; + join(', ', @items, "$conjunction $tail"); +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords smush smushed + +=head1 NAME + +Type::Utils - utility functions to make defining and using type constraints a little easier + +=head1 SYNOPSIS + + package Types::Mine; + + use Type::Library -base; + use Type::Utils -all; + + BEGIN { extends "Types::Standard" }; + + declare "AllCaps", + as "Str", + where { uc($_) eq $_ }, + inline_as { my $varname = $_[1]; "uc($varname) eq $varname" }; + + coerce "AllCaps", + from "Str", via { uc($_) }; + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +This module provides utility functions to make defining and using type +constraints a little easier. + +=head2 Type declaration functions + +Many of the following are similar to the similarly named functions described +in L. + +=over + +=item C<< declare $name, %options >> + +=item C<< declare %options >> + +Declare a named or anonymous type constraint. Use C and C to +specify the parent type (if any) and (possibly) refine its definition. + + declare EvenInt, as Int, where { $_ % 2 == 0 }; + + my $EvenInt = declare as Int, where { $_ % 2 == 0 }; + +I<< NOTE: >> +If the caller package inherits from L then any non-anonymous +types declared in the package will be automatically installed into the +library. + +Hidden gem: if you're inheriting from a type constraint that includes some +coercions, you can include C<< coercion => 1 >> in the C<< %options >> hash +to inherit the coercions. + +=item C<< subtype $name, %options >> + +=item C<< subtype %options >> + +Declare a named or anonymous type constraint which is descended from an +existing type constraint. Use C and C to specify the parent +type and refine its definition. + +Actually, you should use C instead; this is just an alias. + +This function is not exported by default. + +=item C<< type $name, %options >> + +=item C<< type %options >> + +Declare a named or anonymous type constraint which is not descended from +an existing type constraint. Use C to provide a coderef that +constrains values. + +Actually, you should use C instead; this is just an alias. + +This function is not exported by default. + +=item C<< as $parent >> + +Used with C to specify a parent type constraint: + + declare EvenInt, as Int, where { $_ % 2 == 0 }; + +=item C<< where { BLOCK } >> + +Used with C to provide the constraint coderef: + + declare EvenInt, as Int, where { $_ % 2 == 0 }; + +The coderef operates on C<< $_ >>, which is the value being tested. + +=item C<< message { BLOCK } >> + +Generate a custom error message when a value fails validation. + + declare EvenInt, + as Int, + where { $_ % 2 == 0 }, + message { + Int->validate($_) or "$_ is not divisible by two"; + }; + +Without a custom message, the messages generated by Type::Tiny are along +the lines of I<< Value "33" did not pass type constraint "EvenInt" >>, +which is usually reasonable. + +=item C<< inline_as { BLOCK } >> + +Generate a string of Perl code that can be used to inline the type check into +other functions. If your type check is being used within a L or L +constructor or accessor methods, or used by L, this can lead to +significant performance improvements. + + declare EvenInt, + as Int, + where { $_ % 2 == 0 }, + inline_as { + my ($constraint, $varname) = @_; + my $perlcode = + $constraint->parent->inline_check($varname) + . "&& ($varname % 2 == 0)"; + return $perlcode; + }; + + warn EvenInt->inline_check('$xxx'); # demonstration + +Your C block can return a list, in which case +these will be smushed together with "&&". The first item on the list may +be undef, in which case the undef will be replaced by the inlined parent +type constraint. (And will throw an exception if there is no parent.) + + declare EvenInt, + as Int, + where { $_ % 2 == 0 }, + inline_as { + return (undef, "($_ % 2 == 0)"); + }; + +=item C<< class_type $name, { class => $package, %options } >> + +=item C<< class_type { class => $package, %options } >> + +=item C<< class_type $name >> + +Shortcut for declaring a L type constraint. + +If C<< $package >> is omitted, is assumed to be the same as C<< $name >>. +If C<< $name >> contains "::" (which would be an invalid name as far as +L is concerned), this will be removed. + +So for example, C<< class_type("Foo::Bar") >> declares a L +type constraint named "FooBar" which constrains values to objects blessed +into the "Foo::Bar" package. + +=item C<< role_type $name, { role => $package, %options } >> + +=item C<< role_type { role => $package, %options } >> + +=item C<< role_type $name >> + +Shortcut for declaring a L type constraint. + +If C<< $package >> is omitted, is assumed to be the same as C<< $name >>. +If C<< $name >> contains "::" (which would be an invalid name as far as +L is concerned), this will be removed. + +=item C<< duck_type $name, \@methods >> + +=item C<< duck_type \@methods >> + +Shortcut for declaring a L type constraint. + +=item C<< union $name, \@constraints >> + +=item C<< union \@constraints >> + +Shortcut for declaring a L type constraint. + +=item C<< enum $name, \@values >> + +=item C<< enum \@values >> + +Shortcut for declaring a L type constraint. + +=item C<< intersection $name, \@constraints >> + +=item C<< intersection \@constraints >> + +Shortcut for declaring a L type constraint. + +=back + +=head2 Coercion declaration functions + +Many of the following are similar to the similarly named functions described +in L. + +=over + +=item C<< coerce $target, @coercions >> + +Add coercions to the target type constraint. The list of coercions is a +list of type constraint, conversion code pairs. Conversion code can be +either a string of Perl code or a coderef; in either case the value to +be converted is C<< $_ >>. + +=item C<< from $source >> + +Sugar to specify a type constraint in a list of coercions: + + coerce EvenInt, from Int, via { $_ * 2 }; # As a coderef... + coerce EvenInt, from Int, q { $_ * 2 }; # or as a string! + +=item C<< via { BLOCK } >> + +Sugar to specify a coderef in a list of coercions. + +=item C<< declare_coercion $name, \%opts, $type1, $code1, ... >> + +=item C<< declare_coercion \%opts, $type1, $code1, ... >> + +Declares a coercion that is not explicitly attached to any type in the +library. For example: + + declare_coercion "ArrayRefFromAny", from "Any", via { [$_] }; + +This coercion will be exportable from the library as a L +object, but the ArrayRef type exported by the library won't automatically +use it. + +Coercions declared this way are immutable (frozen). + +=item C<< to_type $type >> + +Used with C to declare the target type constraint for +a coercion, but still without explicitly attaching the coercion to the +type constraint: + + declare_coercion "ArrayRefFromAny", + to_type "ArrayRef", + from "Any", via { [$_] }; + +You should pretty much always use this when declaring an unattached +coercion because it's exceedingly useful for a type coercion to know what +it will coerce to - this allows it to skip coercion when no coercion is +needed (e.g. avoiding coercing C<< [] >> to C<< [ [] ] >>) and allows +C to work properly. + +=back + +=head2 Type library management + +=over + +=item C<< extends @libraries >> + +Indicates that this type library extends other type libraries, importing +their type constraints. + +Should usually be executed in a C<< BEGIN >> block. + +This is not exported by default because it's not fun to export it to Moo, +Moose or Mouse classes! C<< use Type::Utils -all >> can be used to import +it into your type library. + +=back + +=head2 Other + +=over + +=item C<< match_on_type $value => ($type => \&action, ..., \&default?) >> + +Something like a C/C or C/C construct. Dispatches +along different code paths depending on the type of the incoming value. +Example blatantly stolen from the Moose documentation: + + sub to_json + { + my $value = shift; + + return match_on_type $value => ( + HashRef() => sub { + my $hash = shift; + '{ ' + . ( + join ", " => + map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) } + sort keys %$hash + ) . ' }'; + }, + ArrayRef() => sub { + my $array = shift; + '[ '.( join ", " => map { to_json($_) } @$array ).' ]'; + }, + Num() => q {$_}, + Str() => q { '"' . $_ . '"' }, + Undef() => q {'null'}, + => sub { die "$_ is not acceptable json type" }, + ); + } + +Note that unlike Moose, code can be specified as a string instead of a +coderef. (e.g. for C, C and C above.) + +For improved performance, try C. + +This function is not exported by default. + +=item C<< my $coderef = compile_match_on_type($type => \&action, ..., \&default?) >> + +Compile a C block into a coderef. The following JSON +converter is about two orders of magnitude faster than the previous +example: + + sub to_json; + *to_json = compile_match_on_type( + HashRef() => sub { + my $hash = shift; + '{ ' + . ( + join ", " => + map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) } + sort keys %$hash + ) . ' }'; + }, + ArrayRef() => sub { + my $array = shift; + '[ '.( join ", " => map { to_json($_) } @$array ).' ]'; + }, + Num() => q {$_}, + Str() => q { '"' . $_ . '"' }, + Undef() => q {'null'}, + => sub { die "$_ is not acceptable json type" }, + ); + +Remember to store the coderef somewhere fairly permanent so that you +don't compile it over and over. C variables (in Perl >= 5.10) +are good for this. (Same sort of idea as L.) + +This function is not exported by default. + +=item C<< my $coderef = classifier(@types) >> + +Returns a coderef that can be used to classify values according to their +type constraint. The coderef, when passed a value, returns a type +constraint which the value satisfies. + + use feature qw( say ); + use Type::Utils qw( classifier ); + use Types::Standard qw( Int Num Str Any ); + + my $classifier = classifier(Str, Int, Num, Any); + + say $classifier->( "42" )->name; # Int + say $classifier->( "4.2" )->name; # Num + say $classifier->( [] )->name; # Any + +Note that, for example, "42" satisfies Int, but it would satisfy the +type constraints Num, Str, and Any as well. In this case, the +classifier has picked the most specific type constraint that "42" +satisfies. + +If no type constraint is satisfied by the value, then the classifier +will return undef. + +=item C<< dwim_type($string, %options) >> + +Given a string like "ArrayRef[Int|CodeRef]", turns it into a type constraint +object, hopefully doing what you mean. + +It uses the syntax of L. Firstly the L +for the caller package is consulted; if that doesn't have a match, +L is consulted for standard type constraint names. + +If none of the above yields a type constraint, and the caller class +is a Moose-based class, then C attempts to look the type +constraint up in the Moose type registry. If it's a Mouse-based class, +then the Mouse type registry is used instead. + +If no type constraint can be found via these normal methods, several +fallbacks are available: + +=over + +=item C + +Lookup in Moose registry even if caller is non-Moose class. + +=item C + +Lookup in Mouse registry even if caller is non-Mouse class. + +=item C + +Create a new Type::Tiny::Class constraint. + +=item C + +Create a new Type::Tiny::Role constraint. + +=back + +You can alter which should be attempted, and in which order, by passing +an option to C: + + my $type = Type::Utils::dwim_type( + "ArrayRef[Int]", + fallback => [ "lookup_via_mouse" , "make_role_type" ], + ); + +For historical reasons, by default the fallbacks attempted are: + + lookup_via_moose, lookup_via_mouse, make_class_type + +You may set C to an empty arrayref to avoid using any of +these fallbacks. + +You can specify an alternative for the caller using the C option. + + my $type = dwim_type("ArrayRef", for => "Moose::Object"); + +While it's probably better overall to use the proper L +interface for resolving type constraint strings, this function often does +what you want. + +It should never die if it fails to find a type constraint (but may die +if the type constraint string is syntactically malformed), preferring to +return undef. + +This function is not exported by default. + +=item C<< english_list(\$conjunction, @items) >> + +Joins the items with commas, placing a conjunction before the final item. +The conjunction is optional, defaulting to "and". + + english_list(qw/foo bar baz/); # "foo, bar, and baz" + english_list(\"or", qw/quux quuux/); # "quux or quuux" + +This function is not exported by default. + +=back + +=head1 EXPORT + +By default, all of the functions documented above are exported, except +C and C (prefer C instead), C, C, +C/C, C, and +C. + +This module uses L; see the documentation of that module +for tips and tricks importing from Type::Utils. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L, L, L, L. + +L, L, L, +L, L. + +L, +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Common/Numeric.pm @@ -0,0 +1,341 @@ +package Types::Common::Numeric; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + if ($] < 5.008) { require Devel::TypeTiny::Perl56Compat }; +} + +BEGIN { + $Types::Common::Numeric::AUTHORITY = 'cpan:TOBYINK'; + $Types::Common::Numeric::VERSION = '1.010000'; +} + +$Types::Common::Numeric::VERSION =~ tr/_//d; + +use Type::Library -base, -declare => qw( + PositiveNum PositiveOrZeroNum + PositiveInt PositiveOrZeroInt + NegativeNum NegativeOrZeroNum + NegativeInt NegativeOrZeroInt + SingleDigit + NumRange IntRange +); + +use Type::Tiny (); +use Types::Standard qw( Num Int Bool ); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +my $meta = __PACKAGE__->meta; + +$meta->add_type( + name => 'PositiveNum', + parent => Num, + constraint => sub { $_ > 0 }, + inlined => sub { undef, qq($_ > 0) }, + message => sub { "Must be a positive number" }, +); + +$meta->add_type( + name => 'PositiveOrZeroNum', + parent => Num, + constraint => sub { $_ >= 0 }, + inlined => sub { undef, qq($_ >= 0) }, + message => sub { "Must be a number greater than or equal to zero" }, +); + +my ($pos_int, $posz_int); +if (Type::Tiny::_USE_XS) { + $pos_int = Type::Tiny::XS::get_coderef_for('PositiveInt') + if Type::Tiny::XS->VERSION >= 0.013; # fixed bug with "00" + $posz_int = Type::Tiny::XS::get_coderef_for('PositiveOrZeroInt'); +} + +$meta->add_type( + name => 'PositiveInt', + parent => Int, + constraint => sub { $_ > 0 }, + inlined => sub { + if ($pos_int) { + my $xsub = Type::Tiny::XS::get_subname_for($_[0]->name); + return "$xsub($_[1])" if $xsub && !$Type::Tiny::AvoidCallbacks; + } + undef, qq($_ > 0); + }, + message => sub { "Must be a positive integer" }, + $pos_int ? ( compiled_type_constraint => $pos_int ) : (), +); + +$meta->add_type( + name => 'PositiveOrZeroInt', + parent => Int, + constraint => sub { $_ >= 0 }, + inlined => sub { + if ($posz_int) { + my $xsub = Type::Tiny::XS::get_subname_for($_[0]->name); + return "$xsub($_[1])" if $xsub && !$Type::Tiny::AvoidCallbacks; + } + undef, qq($_ >= 0); + }, + message => sub { "Must be an integer greater than or equal to zero" }, + $posz_int ? ( compiled_type_constraint => $posz_int ) : (), +); + +$meta->add_type( + name => 'NegativeNum', + parent => Num, + constraint => sub { $_ < 0 }, + inlined => sub { undef, qq($_ < 0) }, + message => sub { "Must be a negative number" }, +); + +$meta->add_type( + name => 'NegativeOrZeroNum', + parent => Num, + constraint => sub { $_ <= 0 }, + inlined => sub { undef, qq($_ <= 0) }, + message => sub { "Must be a number less than or equal to zero" }, +); + +$meta->add_type( + name => 'NegativeInt', + parent => Int, + constraint => sub { $_ < 0 }, + inlined => sub { undef, qq($_ < 0) }, + message => sub { "Must be a negative integer" }, +); + +$meta->add_type( + name => 'NegativeOrZeroInt', + parent => Int, + constraint => sub { $_ <= 0 }, + inlined => sub { undef, qq($_ <= 0) }, + message => sub { "Must be an integer less than or equal to zero" }, +); + +$meta->add_type( + name => 'SingleDigit', + parent => Int, + constraint => sub { $_ >= -9 and $_ <= 9 }, + inlined => sub { undef, qq($_ >= -9), qq($_ <= 9) }, + message => sub { "Must be a single digit" }, +); + +for my $base (qw/Num Int/) { + $meta->add_type( + name => "${base}Range", + parent => Types::Standard->get_type($base), + constraint_generator => sub { + return $meta->get_type("${base}Range") unless @_; + + my $base_obj = Types::Standard->get_type($base); + + my ($min, $max, $min_excl, $max_excl) = @_; + !defined($min) or $base_obj->check($min) or _croak("${base}Range min must be a %s; got %s", lc($base), $min); + !defined($max) or $base_obj->check($max) or _croak("${base}Range max must be a %s; got %s", lc($base), $max); + !defined($min_excl) or Bool->check($min_excl) or _croak("${base}Range minexcl must be a boolean; got $min_excl"); + !defined($max_excl) or Bool->check($max_excl) or _croak("${base}Range maxexcl must be a boolean; got $max_excl"); + + # this is complicated so defer to the inline generator + eval sprintf( + 'sub { %s }', + join ' and ', + grep defined, + $meta->get_type("${base}Range")->inline_generator->(@_)->(undef, '$_[0]'), + ); + }, + inline_generator => sub { + my ($min, $max, $min_excl, $max_excl) = @_; + + my $gt = $min_excl ? '>' : '>='; + my $lt = $max_excl ? '<' : '<='; + + return sub { + my $v = $_[1]; + my @code = (undef); # parent constraint + push @code, "$v $gt $min"; + push @code, "$v $lt $max" if defined $max; + return @code; + }; + }, + deep_explanation => sub { + my ($type, $value, $varname) = @_; + my ($min, $max, $min_excl, $max_excl) = @{ $type->parameters || [] }; + my @whines; + if (defined $max) { + push @whines, sprintf( + '"%s" expects %s to be %s %d and %s %d', + $type, + $varname, + $min_excl ? 'greater than' : 'at least', + $min, + $max_excl ? 'less than' : 'at most', + $max, + ); + } + else { + push @whines, sprintf( + '"%s" expects %s to be %s %d', + $type, + $varname, + $min_excl ? 'greater than' : 'at least', + $min, + ); + } + push @whines, sprintf( + "length(%s) is %d", + $varname, + length($value), + ); + return \@whines; + }, + ); +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Common::Numeric - drop-in replacement for MooseX::Types::Common::Numeric + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +A drop-in replacement for L. + +=head2 Types + +The following types are similar to those described in +L. + +=over + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +C interestingly accepts the numbers -9 to -1; not +just 0 to 9. + +=back + +This module also defines an extra pair of type constraints not found in +L. + +=over + +=item * + +B<< IntRange[`min, `max] >> + +Type constraint for an integer between min and max. For example: + + IntRange[1, 10] + +The maximum can be omitted. + + IntRange[10] # at least 10 + +The minimum and maximum are inclusive. + +=item * + +B<< NumRange[`min, `max] >> + +Type constraint for a number between min and max. For example: + + NumRange[0.1, 10.0] + +As with IntRange, the maximum can be omitted, and the minimum and maximum +are inclusive. + +Exclusive ranges can be useful for non-integer values, so additional parameters +can be given to make the minimum and maximum exclusive. + + NumRange[0.1, 10.0, 0, 0] # both inclusive + NumRange[0.1, 10.0, 0, 1] # exclusive maximum, so 10.0 is invalid + NumRange[0.1, 10.0, 1, 0] # exclusive minimum, so 0.1 is invalid + NumRange[0.1, 10.0, 1, 1] # both exclusive + +Making one of the limits exclusive means that a C<< < >> or C<< > >> operator +will be used instead of the usual C<< <= >> or C<< >= >> operators. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L, L. + +L, +L, +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Common/String.pm @@ -0,0 +1,340 @@ +package Types::Common::String; + +use 5.006001; +use strict; +use warnings; +use utf8; + +BEGIN { + if ($] < 5.008) { require Devel::TypeTiny::Perl56Compat }; +} + +BEGIN { + $Types::Common::String::AUTHORITY = 'cpan:TOBYINK'; + $Types::Common::String::VERSION = '1.010000'; +} + +$Types::Common::String::VERSION =~ tr/_//d; + +use Type::Library -base, -declare => qw( + SimpleStr + NonEmptySimpleStr + NumericCode + LowerCaseSimpleStr + UpperCaseSimpleStr + Password + StrongPassword + NonEmptyStr + LowerCaseStr + UpperCaseStr + StrLength +); + +use Type::Tiny (); +use Types::Standard qw( Str ); + +my $meta = __PACKAGE__->meta; + +$meta->add_type( + name => SimpleStr, + parent => Str, + constraint => sub { length($_) <= 255 and not /\n/ }, + inlined => sub { undef, qq(length($_) <= 255), qq($_ !~ /\\n/) }, + message => sub { "Must be a single line of no more than 255 chars" }, +); + +$meta->add_type( + name => NonEmptySimpleStr, + parent => SimpleStr, + constraint => sub { length($_) > 0 }, + inlined => sub { undef, qq(length($_) > 0) }, + message => sub { "Must be a non-empty single line of no more than 255 chars" }, +); + +$meta->add_type( + name => NumericCode, + parent => NonEmptySimpleStr, + constraint => sub { /^[0-9]+$/ }, + inlined => sub { SimpleStr->inline_check($_), qq($_ =~ m/^[0-9]+\$/) }, + message => sub { + 'Must be a non-empty single line of no more than 255 chars that consists ' + . 'of numeric characters only' + }, +); + +NumericCode->coercion->add_type_coercions( + NonEmptySimpleStr, q[ do { (my $code = $_) =~ s/[[:punct:][:space:]]//g; $code } ], +); + +$meta->add_type( + name => Password, + parent => NonEmptySimpleStr, + constraint => sub { length($_) > 3 }, + inlined => sub { SimpleStr->inline_check($_), qq(length($_) > 3) }, + message => sub { "Must be between 4 and 255 chars" }, +); + +$meta->add_type( + name => StrongPassword, + parent => Password, + constraint => sub { length($_) > 7 and /[^a-zA-Z]/ }, + inlined => sub { SimpleStr()->inline_check($_), qq(length($_) > 7), qq($_ =~ /[^a-zA-Z]/) }, + message => sub { "Must be between 8 and 255 chars, and contain a non-alpha char" }, +); + +my ($nestr); +if (Type::Tiny::_USE_XS) { + $nestr = Type::Tiny::XS::get_coderef_for('NonEmptyStr'); +} + +$meta->add_type( + name => NonEmptyStr, + parent => Str, + constraint => sub { length($_) > 0 }, + inlined => sub { + if ($nestr) { + my $xsub = Type::Tiny::XS::get_subname_for($_[0]->name); + return "$xsub($_[1])" if $xsub && !$Type::Tiny::AvoidCallbacks; + } + undef, qq(length($_) > 0); + }, + message => sub { "Must not be empty" }, + $nestr ? ( compiled_type_constraint => $nestr ) : (), +); + +$meta->add_type( + name => LowerCaseStr, + parent => NonEmptyStr, + constraint => sub { !/\p{Upper}/ms }, + inlined => sub { undef, qq($_ !~ /\\p{Upper}/ms) }, + message => sub { "Must not contain upper case letters" }, +); + +LowerCaseStr->coercion->add_type_coercions( + NonEmptyStr, q[ lc($_) ], +); + +$meta->add_type( + name => UpperCaseStr, + parent => NonEmptyStr, + constraint => sub { !/\p{Lower}/ms }, + inlined => sub { undef, qq($_ !~ /\\p{Lower}/ms) }, + message => sub { "Must not contain lower case letters" }, +); + +UpperCaseStr->coercion->add_type_coercions( + NonEmptyStr, q[ uc($_) ], +); + +$meta->add_type( + name => LowerCaseSimpleStr, + parent => NonEmptySimpleStr, + constraint => sub { !/\p{Upper}/ms }, + inlined => sub { undef, qq($_ !~ /\\p{Upper}/ms) }, + message => sub { "Must not contain upper case letters" }, +); + +LowerCaseSimpleStr->coercion->add_type_coercions( + NonEmptySimpleStr, q[ lc($_) ], +); + +$meta->add_type( + name => UpperCaseSimpleStr, + parent => NonEmptySimpleStr, + constraint => sub { !/\p{Lower}/ms }, + inlined => sub { undef, qq($_ !~ /\\p{Lower}/ms) }, + message => sub { "Must not contain lower case letters" }, +); + +UpperCaseSimpleStr->coercion->add_type_coercions( + NonEmptySimpleStr, q[ uc($_) ], +); + +$meta->add_type( + name => StrLength, + parent => Str, + constraint_generator => sub { + return $meta->get_type('StrLength') unless @_; + + my ($min, $max) = @_; + Types::Standard::Int->check($_) + || Types::Standard::_croak("Parameters for StrLength[`min, `max] expected to be integers; got $_") + for @_; + + if (defined $max) { + return sub { length($_[0]) >= $min and length($_[0]) <= $max }; + } + else { + return sub { length($_[0]) >= $min }; + } + }, + inline_generator => sub { + my ($min, $max) = @_; + + return sub { + my $v = $_[1]; + my @code = (undef); # parent constraint + push @code, "length($v) >= $min"; + push @code, "length($v) <= $max" if defined $max; + return @code; + }; + }, + deep_explanation => sub { + my ($type, $value, $varname) = @_; + my ($min, $max) = @{ $type->parameters || [] }; + my @whines; + if (defined $max) { + push @whines, sprintf( + '"%s" expects length(%s) to be between %d and %d', + $type, + $varname, + $min, + $max, + ); + } + else { + push @whines, sprintf( + '"%s" expects length(%s) to be at least %d', + $type, + $varname, + $min, + ); + } + push @whines, sprintf( + "length(%s) is %d", + $varname, + length($value), + ); + return \@whines; + }, +); + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Common::String - drop-in replacement for MooseX::Types::Common::String + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +A drop-in replacement for L. + +=head2 Types + +The following types are similar to those described in +L. + +=over + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=item * + +B + +=back + +This module also defines an extra type constraint not found in +L. + +=over + +=item * + +B<< StrLength[`min, `max] >> + +Type constraint for a string between min and max characters long. For +example: + + StrLength[4, 20] + +It is sometimes useful to combine this with another type constraint in an +intersection. + + (LowerCaseStr) & (StrLength[4, 20]) + +The max length can be omitted. + + StrLength[10] # at least 10 characters + +Lengths are inclusive. + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L, L. + +L, +L, +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard.pm @@ -0,0 +1,1546 @@ +package Types::Standard; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + eval { require re }; + if ($] < 5.008) { require Devel::TypeTiny::Perl56Compat }; + if ($] < 5.010) { require Devel::TypeTiny::Perl58Compat }; +} + +BEGIN { + $Types::Standard::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::VERSION = '1.010000'; +} + +$Types::Standard::VERSION =~ tr/_//d; + +use Type::Library -base; + +our @EXPORT_OK = qw( slurpy ); + +use Scalar::Util qw( blessed looks_like_number ); +use Type::Tiny (); +use Types::TypeTiny (); + +my $is_class_loaded; + +BEGIN { + $is_class_loaded = q{sub { + return !!0 if ref $_[0]; + return !!0 if not $_[0]; + return !!0 if ref(do { my $tmpstr = $_[0]; \$tmpstr }) ne 'SCALAR'; + my $stash = do { no strict 'refs'; \%{"$_[0]\::"} }; + return !!1 if exists $stash->{'ISA'}; + return !!1 if exists $stash->{'VERSION'}; + foreach my $globref (values %$stash) { + return !!1 + if ref \$globref eq 'GLOB' + ? *{$globref}{CODE} + : ref $globref; # const or sub ref + } + return !!0; + }}; + + *_is_class_loaded = Type::Tiny::_USE_XS + ? \&Type::Tiny::XS::Util::is_class_loaded + : eval $is_class_loaded; + + *_HAS_REFUTILXS = eval { require Ref::Util::XS; Ref::Util::XS::->VERSION(0.100); 1; } + ? sub () { !!1 } + : sub () { !!0 }; +}; + + +my $add_core_type = sub { + my $meta = shift; + my ($typedef) = @_; + + my $name = $typedef->{name}; + my ($xsub, $xsubname); + + # We want Map and Tuple to be XSified, even if they're not + # really core. + $typedef->{_is_core} = 1 + unless $name eq 'Map' || $name eq 'Tuple'; + + if ( Type::Tiny::_USE_XS + and not ($name eq 'RegexpRef') ) { + $xsub = Type::Tiny::XS::get_coderef_for($name); + $xsubname = Type::Tiny::XS::get_subname_for($name); + } + + elsif ( Type::Tiny::_USE_MOUSE + and not ($name eq 'RegexpRef' or $name eq 'Int' or $name eq 'Object') ) { + require Mouse::Util::TypeConstraints; + $xsub = "Mouse::Util::TypeConstraints"->can($name); + $xsubname = "Mouse::Util::TypeConstraints::$name" if $xsub; + } + + if (Type::Tiny::_USE_XS + and Type::Tiny::XS->VERSION < 0.014 + and $name eq 'Bool') { + # Broken implementation of Bool + $xsub = $xsubname = undef; + } + + if (Type::Tiny::_USE_XS + and ( Type::Tiny::XS->VERSION < 0.016 or $] < 5.018 ) + and $name eq 'Int') { + # Broken implementation of Int + $xsub = $xsubname = undef; + } + + $typedef->{compiled_type_constraint} = $xsub if $xsub; + + #### TODO + my $orig_inlined = $typedef->{inlined}; + if (defined($xsubname) and ( + # These should be faster than their normal inlined + # equivalents + $name eq 'Str' or + $name eq 'Bool' or + $name eq 'ClassName' or + $name eq 'RegexpRef' or + $name eq 'FileHandle' + )) { + $typedef->{inlined} = sub { + $Type::Tiny::AvoidCallbacks ? goto($orig_inlined) : "$xsubname\($_[1])" + }; + } + + $meta->add_type($typedef); +}; + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +my $meta = __PACKAGE__->meta; + +# Stringable and LazyLoad are optimizations that complicate +# this module somewhat, but they have led to performance +# improvements. If Types::Standard wasn't such a key type +# library, I wouldn't use them. I strongly discourage anybody +# from using them in their own code. If you're looking for +# examples of how to write a type library sanely, you're +# better off looking at the code for Types::Common::Numeric +# and Types::Common::String. + +{ + sub Stringable (&) { + bless +{ code => $_[0] }, 'Types::Standard::_Stringable'; + } + Types::Standard::_Stringable->Type::Tiny::_install_overloads( + q[""] => sub { $_[0]{text} ||= $_[0]{code}->() } + ); + + my $subname; + sub LazyLoad ($$) { + bless \@_, 'Types::Standard::LazyLoad'; + } + 'Types::Standard::LazyLoad'->Type::Tiny::_install_overloads( + q[&{}] => sub { + my ($typename, $function) = @{$_[0]}; + my $type = $meta->get_type($typename); + my $class = "Types::Standard::$typename"; + eval "require $class; 1" or die($@); + # Majorly break encapsulation for Type::Tiny :-O + for my $key (keys %$type) + { + next unless ref($type->{$key}) eq 'Types::Standard::LazyLoad'; + my $f = $type->{$key}[1]; + $type->{$key} = $class->can("__$f"); + } + my $mm = $type->{my_methods} || {}; + for my $key (keys %$mm) + { + $subname = + eval { require Sub::Util } ? \&Sub::Util::set_subname : + eval { require Sub::Name } ? \&Sub::Name::subname : + 0 + if not defined $subname; + next unless ref($mm->{$key}) eq 'Types::Standard::LazyLoad'; + my $f = $mm->{$key}[1]; + $mm->{$key} = $class->can("__$f"); + $subname and $subname->( + sprintf("%s::my_%s", $type->qualified_name, $key), + $mm->{$key}, + ); + } + return $class->can("__$function"); + }, + ); +} + +no warnings; + +BEGIN { *STRICTNUM = $ENV{PERL_TYPES_STANDARD_STRICTNUM} ? sub(){!!1} : sub(){!!0} }; + +my $_any = $meta->$add_core_type({ + name => "Any", + inlined => sub { "!!1" }, + complement_name => 'None', +}); + +my $_item = $meta->$add_core_type({ + name => "Item", + inlined => sub { "!!1" }, + parent => $_any, +}); + +my $_bool = $meta->$add_core_type({ + name => "Bool", + parent => $_item, + constraint => sub { !ref $_ and (!defined $_ or $_ eq q() or $_ eq '0' or $_ eq '1') }, + inlined => sub { "!ref $_[1] and (!defined $_[1] or $_[1] eq q() or $_[1] eq '0' or $_[1] eq '1')" }, +}); + +$_bool->coercion->add_type_coercions($_any, q{!!$_}); + +my $_undef = $meta->$add_core_type({ + name => "Undef", + parent => $_item, + constraint => sub { !defined $_ }, + inlined => sub { "!defined($_[1])" }, +}); + +my $_def = $meta->$add_core_type({ + name => "Defined", + parent => $_item, + constraint => sub { defined $_ }, + inlined => sub { "defined($_[1])" }, + complementary_type => $_undef, +}); + +# hackish, but eh +Scalar::Util::weaken($_undef->{complementary_type} ||= $_def); + +my $_val = $meta->$add_core_type({ + name => "Value", + parent => $_def, + constraint => sub { not ref $_ }, + inlined => sub { "defined($_[1]) and not ref($_[1])" }, +}); + +my $_str = $meta->$add_core_type({ + name => "Str", + parent => $_val, + constraint => sub { ref(\$_) eq 'SCALAR' or ref(\(my $val = $_)) eq 'SCALAR' }, + inlined => sub { + "defined($_[1]) and do { ref(\\$_[1]) eq 'SCALAR' or ref(\\(my \$val = $_[1])) eq 'SCALAR' }" + }, +}); + +my $_laxnum = $meta->add_type({ + name => "LaxNum", + parent => $_str, + constraint => sub { looks_like_number $_ }, + inlined => sub { "defined($_[1]) && !ref($_[1]) && Scalar::Util::looks_like_number($_[1])" }, +}); + +my $_strictnum = $meta->add_type({ + name => "StrictNum", + parent => $_str, + constraint => sub { + my $val = $_; + ($val =~ /\A[+-]?[0-9]+\z/) || + ( $val =~ /\A(?:[+-]?) #matches optional +- in the beginning + (?=[0-9]|\.[0-9]) #matches previous +- only if there is something like 3 or .3 + [0-9]* #matches 0-9 zero or more times + (?:\.[0-9]+)? #matches optional .89 or nothing + (?:[Ee](?:[+-]?[0-9]+))? #matches E1 or e1 or e-1 or e+1 etc + \z/x ); + }, + inlined => sub { + 'my $val = '.$_[1].';'. + Value()->inline_check('$val') + .' && ( $val =~ /\A[+-]?[0-9]+\z/ || ' + . '$val =~ /\A(?:[+-]?) # matches optional +- in the beginning + (?=[0-9]|\.[0-9]) # matches previous +- only if there is something like 3 or .3 + [0-9]* # matches 0-9 zero or more times + (?:\.[0-9]+)? # matches optional .89 or nothing + (?:[Ee](?:[+-]?[0-9]+))? # matches E1 or e1 or e-1 or e+1 etc + \z/x ); ' + }, +}); + +my $_num = $meta->add_type({ + name => "Num", + parent => (STRICTNUM ? $_strictnum : $_laxnum), +}); + +$meta->$add_core_type({ + name => "Int", + parent => $_num, + constraint => sub { /\A-?[0-9]+\z/ }, + inlined => sub { "do { my \$tmp = $_[1]; defined(\$tmp) and !ref(\$tmp) and \$tmp =~ /\\A-?[0-9]+\\z/ }" }, +}); + +my $_classn = $meta->add_type({ + name => "ClassName", + parent => $_str, + constraint => \&_is_class_loaded, + inlined => sub { + $Type::Tiny::AvoidCallbacks + ? "($is_class_loaded)->(do { my \$tmp = $_[1] })" + : "Types::Standard::_is_class_loaded(do { my \$tmp = $_[1] })" + }, +}); + +$meta->add_type({ + name => "RoleName", + parent => $_classn, + constraint => sub { not $_->can("new") }, + inlined => sub { + $Type::Tiny::AvoidCallbacks + ? "($is_class_loaded)->(do { my \$tmp = $_[1] }) and not $_[1]\->can('new')" + : "Types::Standard::_is_class_loaded(do { my \$tmp = $_[1] }) and not $_[1]\->can('new')" + }, +}); + +my $_ref = $meta->$add_core_type({ + name => "Ref", + parent => $_def, + constraint => sub { ref $_ }, + inlined => sub { "!!ref($_[1])" }, + constraint_generator => sub + { + return $meta->get_type('Ref') unless @_; + + my $reftype = shift; + $reftype =~ /^(SCALAR|ARRAY|HASH|CODE|REF|GLOB|LVALUE|FORMAT|IO|VSTRING|REGEXP|Regexp)$/i + or _croak("Parameter to Ref[`a] expected to be a Perl ref type; got $reftype"); + + $reftype = "$reftype"; + return sub { + ref($_[0]) and Scalar::Util::reftype($_[0]) eq $reftype; + } + }, + inline_generator => sub + { + my $reftype = shift; + return sub { + my $v = $_[1]; + "ref($v) and Scalar::Util::reftype($v) eq q($reftype)"; + }; + }, + deep_explanation => sub { + require B; + my ($type, $value, $varname) = @_; + my $param = $type->parameters->[0]; + return if $type->check($value); + my $reftype = Scalar::Util::reftype($value); + return [ + sprintf('"%s" constrains reftype(%s) to be equal to %s', $type, $varname, B::perlstring($param)), + sprintf('reftype(%s) is %s', $varname, defined($reftype) ? B::perlstring($reftype) : "undef"), + ]; + }, +}); + +$meta->$add_core_type({ + name => "CodeRef", + parent => $_ref, + constraint => sub { ref $_ eq "CODE" }, + inlined => sub { + _HAS_REFUTILXS && !$Type::Tiny::AvoidCallbacks + ? "Ref::Util::XS::is_plain_coderef($_[1])" + : "ref($_[1]) eq 'CODE'" + }, +}); + +my $_regexp = $meta->$add_core_type({ + name => "RegexpRef", + parent => $_ref, + constraint => sub { ref($_) && !!re::is_regexp($_) or blessed($_) && $_->isa('Regexp') }, + inlined => sub { my $v = $_[1]; "ref($v) && !!re::is_regexp($v) or Scalar::Util::blessed($v) && $v\->isa('Regexp')" }, +}); + +$meta->$add_core_type({ + name => "GlobRef", + parent => $_ref, + constraint => sub { ref $_ eq "GLOB" }, + inlined => sub { + _HAS_REFUTILXS && !$Type::Tiny::AvoidCallbacks + ? "Ref::Util::XS::is_plain_globref($_[1])" + : "ref($_[1]) eq 'GLOB'" + }, +}); + +$meta->$add_core_type({ + name => "FileHandle", + parent => $_ref, + constraint => sub { + (ref($_) && Scalar::Util::openhandle($_)) + or (blessed($_) && $_->isa("IO::Handle")) + }, + inlined => sub { + "(ref($_[1]) && Scalar::Util::openhandle($_[1])) ". + "or (Scalar::Util::blessed($_[1]) && $_[1]\->isa(\"IO::Handle\"))" + }, +}); + +my $_arr = $meta->$add_core_type({ + name => "ArrayRef", + parent => $_ref, + constraint => sub { ref $_ eq "ARRAY" }, + inlined => sub { + _HAS_REFUTILXS && !$Type::Tiny::AvoidCallbacks + ? "Ref::Util::XS::is_plain_arrayref($_[1])" + : "ref($_[1]) eq 'ARRAY'" + }, + constraint_generator => LazyLoad(ArrayRef => 'constraint_generator'), + inline_generator => LazyLoad(ArrayRef => 'inline_generator'), + deep_explanation => LazyLoad(ArrayRef => 'deep_explanation'), + coercion_generator => LazyLoad(ArrayRef => 'coercion_generator'), +}); + +my $_hash = $meta->$add_core_type({ + name => "HashRef", + parent => $_ref, + constraint => sub { ref $_ eq "HASH" }, + inlined => sub { + _HAS_REFUTILXS && !$Type::Tiny::AvoidCallbacks + ? "Ref::Util::XS::is_plain_hashref($_[1])" + : "ref($_[1]) eq 'HASH'" + }, + constraint_generator => LazyLoad(HashRef => 'constraint_generator'), + inline_generator => LazyLoad(HashRef => 'inline_generator'), + deep_explanation => LazyLoad(HashRef => 'deep_explanation'), + coercion_generator => LazyLoad(HashRef => 'coercion_generator'), + my_methods => { + hashref_allows_key => LazyLoad(HashRef => 'hashref_allows_key'), + hashref_allows_value => LazyLoad(HashRef => 'hashref_allows_value'), + }, +}); + +$meta->$add_core_type({ + name => "ScalarRef", + parent => $_ref, + constraint => sub { ref $_ eq "SCALAR" or ref $_ eq "REF" }, + inlined => sub { "ref($_[1]) eq 'SCALAR' or ref($_[1]) eq 'REF'" }, + constraint_generator => LazyLoad(ScalarRef => 'constraint_generator'), + inline_generator => LazyLoad(ScalarRef => 'inline_generator'), + deep_explanation => LazyLoad(ScalarRef => 'deep_explanation'), + coercion_generator => LazyLoad(ScalarRef => 'coercion_generator'), +}); + +my $_obj = $meta->$add_core_type({ + name => "Object", + parent => $_ref, + constraint => sub { blessed $_ }, + inlined => sub { + _HAS_REFUTILXS && !$Type::Tiny::AvoidCallbacks + ? "Ref::Util::XS::is_blessed_ref($_[1])" + : "Scalar::Util::blessed($_[1])" + }, + is_object => 1, +}); + +$meta->$add_core_type({ + name => "Maybe", + parent => $_item, + constraint_generator => sub + { + return $meta->get_type('Maybe') unless @_; + + my $param = Types::TypeTiny::to_TypeTiny(shift); + Types::TypeTiny::TypeTiny->check($param) + or _croak("Parameter to Maybe[`a] expected to be a type constraint; got $param"); + + my $param_compiled_check = $param->compiled_check; + my @xsub; + if (Type::Tiny::_USE_XS) + { + my $paramname = Type::Tiny::XS::is_known($param_compiled_check); + push @xsub, Type::Tiny::XS::get_coderef_for("Maybe[$paramname]") + if $paramname; + } + elsif (Type::Tiny::_USE_MOUSE and $param->_has_xsub) + { + require Mouse::Util::TypeConstraints; + my $maker = "Mouse::Util::TypeConstraints"->can("_parameterize_Maybe_for"); + push @xsub, $maker->($param) if $maker; + } + + return ( + sub + { + my $value = shift; + return !!1 unless defined $value; + return $param->check($value); + }, + @xsub, + ); + }, + inline_generator => sub { + my $param = shift; + + my $param_compiled_check = $param->compiled_check; + my $xsubname; + if (Type::Tiny::_USE_XS) + { + my $paramname = Type::Tiny::XS::is_known($param_compiled_check); + $xsubname = Type::Tiny::XS::get_subname_for("Maybe[$paramname]"); + } + + return unless $param->can_be_inlined; + return sub { + my $v = $_[1]; + return "$xsubname\($v\)" if $xsubname && !$Type::Tiny::AvoidCallbacks; + my $param_check = $param->inline_check($v); + "!defined($v) or $param_check"; + }; + }, + deep_explanation => sub { + my ($type, $value, $varname) = @_; + my $param = $type->parameters->[0]; + + return [ + sprintf('%s is defined', Type::Tiny::_dd($value)), + sprintf('"%s" constrains the value with "%s" if it is defined', $type, $param), + @{ $param->validate_explain($value, $varname) }, + ]; + }, + coercion_generator => sub + { + my ($parent, $child, $param) = @_; + return unless $param->has_coercion; + return $param->coercion; + }, +}); + +my $_map = $meta->$add_core_type({ + name => "Map", + parent => $_hash, + constraint_generator => LazyLoad(Map => 'constraint_generator'), + inline_generator => LazyLoad(Map => 'inline_generator'), + deep_explanation => LazyLoad(Map => 'deep_explanation'), + coercion_generator => LazyLoad(Map => 'coercion_generator'), + my_methods => { + hashref_allows_key => LazyLoad(Map => 'hashref_allows_key'), + hashref_allows_value => LazyLoad(Map => 'hashref_allows_value'), + }, +}); + +my $_Optional = $meta->add_type({ + name => "Optional", + parent => $_item, + constraint_generator => sub + { + return $meta->get_type('Optional') unless @_; + + my $param = Types::TypeTiny::to_TypeTiny(shift); + Types::TypeTiny::TypeTiny->check($param) + or _croak("Parameter to Optional[`a] expected to be a type constraint; got $param"); + + sub { $param->check($_[0]) } + }, + inline_generator => sub { + my $param = shift; + return unless $param->can_be_inlined; + return sub { + my $v = $_[1]; + $param->inline_check($v); + }; + }, + deep_explanation => sub { + my ($type, $value, $varname) = @_; + my $param = $type->parameters->[0]; + + return [ + sprintf('%s exists', $varname), + sprintf('"%s" constrains %s with "%s" if it exists', $type, $varname, $param), + @{ $param->validate_explain($value, $varname) }, + ]; + }, + coercion_generator => sub + { + my ($parent, $child, $param) = @_; + return unless $param->has_coercion; + return $param->coercion; + }, +}); + +sub slurpy { + my $t = shift; + wantarray ? (+{ slurpy => $t }, @_) : +{ slurpy => $t }; +} + +$meta->$add_core_type({ + name => "Tuple", + parent => $_arr, + name_generator => sub + { + my ($s, @a) = @_; + sprintf('%s[%s]', $s, join q[,], map { ref($_) eq "HASH" ? sprintf("slurpy %s", $_->{slurpy}) : $_ } @a); + }, + constraint_generator => LazyLoad(Tuple => 'constraint_generator'), + inline_generator => LazyLoad(Tuple => 'inline_generator'), + deep_explanation => LazyLoad(Tuple => 'deep_explanation'), + coercion_generator => LazyLoad(Tuple => 'coercion_generator'), +}); + +$meta->add_type({ + name => "CycleTuple", + parent => $_arr, + name_generator => sub + { + my ($s, @a) = @_; + sprintf('%s[%s]', $s, join q[,], @a); + }, + constraint_generator => LazyLoad(CycleTuple => 'constraint_generator'), + inline_generator => LazyLoad(CycleTuple => 'inline_generator'), + deep_explanation => LazyLoad(CycleTuple => 'deep_explanation'), + coercion_generator => LazyLoad(CycleTuple => 'coercion_generator'), +}); + +$meta->add_type({ + name => "Dict", + parent => $_hash, + name_generator => sub + { + my ($s, @p) = @_; + my $l = ref($p[-1]) eq q(HASH) ? pop(@p)->{slurpy} : undef; + my %a = @p; + sprintf('%s[%s%s]', $s, join(q[,], map sprintf("%s=>%s", $_, $a{$_}), sort keys %a), $l ? ",slurpy $l" : ''); + }, + constraint_generator => LazyLoad(Dict => 'constraint_generator'), + inline_generator => LazyLoad(Dict => 'inline_generator'), + deep_explanation => LazyLoad(Dict => 'deep_explanation'), + coercion_generator => LazyLoad(Dict => 'coercion_generator'), + my_methods => { + dict_is_slurpy => LazyLoad(Dict => 'dict_is_slurpy'), + hashref_allows_key => LazyLoad(Dict => 'hashref_allows_key'), + hashref_allows_value => LazyLoad(Dict => 'hashref_allows_value'), + }, +}); + +$meta->add_type({ + name => "Overload", + parent => $_obj, + constraint => sub { require overload; overload::Overloaded($_) }, + inlined => sub { + $INC{'overload.pm'} + ? "Scalar::Util::blessed($_[1]) and overload::Overloaded($_[1])" + : "Scalar::Util::blessed($_[1]) and do { use overload (); overload::Overloaded($_[1]) }" + }, + constraint_generator => sub + { + return $meta->get_type('Overload') unless @_; + + my @operations = map { + Types::TypeTiny::StringLike->check($_) + ? "$_" + : _croak("Parameters to Overload[`a] expected to be a strings; got $_"); + } @_; + + require overload; + return sub { + my $value = shift; + for my $op (@operations) { + return unless overload::Method($value, $op); + } + return !!1; + } + }, + inline_generator => sub { + my @operations = @_; + return sub { + require overload; + my $v = $_[1]; + join " and ", + "Scalar::Util::blessed($v)", + map "overload::Method($v, q[$_])", @operations; + }; + }, + is_object => 1, +}); + +$meta->add_type({ + name => "StrMatch", + parent => $_str, + constraint_generator => LazyLoad(StrMatch => 'constraint_generator'), + inline_generator => LazyLoad(StrMatch => 'inline_generator'), +}); + +$meta->add_type({ + name => "OptList", + parent => $_arr, + constraint => sub { + for my $inner (@$_) { + return unless ref($inner) eq q(ARRAY); + return unless @$inner == 2; + return unless is_Str($inner->[0]); + } + return !!1; + }, + inlined => sub { + my ($self, $var) = @_; + my $Str_check = Str()->inline_check('$inner->[0]'); + my @code = 'do { my $ok = 1; '; + push @code, sprintf('for my $inner (@{%s}) { no warnings; ', $var); + push @code, sprintf('($ok=0) && last unless ref($inner) eq q(ARRAY) && @$inner == 2 && (%s); ', $Str_check); + push @code, '} '; + push @code, '$ok }'; + return (undef, join(q( ), @code)); + }, +}); + +$meta->add_type({ + name => "Tied", + parent => $_ref, + constraint => sub { + !!tied(Scalar::Util::reftype($_) eq 'HASH' ? %{$_} : Scalar::Util::reftype($_) eq 'ARRAY' ? @{$_} : Scalar::Util::reftype($_) =~ /^(SCALAR|REF)$/ ? ${$_} : undef) + }, + inlined => sub { + my ($self, $var) = @_; + $self->parent->inline_check($var) + . " and !!tied(Scalar::Util::reftype($var) eq 'HASH' ? \%{$var} : Scalar::Util::reftype($var) eq 'ARRAY' ? \@{$var} : Scalar::Util::reftype($var) =~ /^(SCALAR|REF)\$/ ? \${$var} : undef)" + }, + name_generator => sub + { + my $self = shift; + my $param = Types::TypeTiny::to_TypeTiny(shift); + unless (Types::TypeTiny::TypeTiny->check($param)) + { + Types::TypeTiny::StringLike->check($param) + or _croak("Parameter to Tied[`a] expected to be a class name; got $param"); + require B; + return sprintf("%s[%s]", $self, B::perlstring($param)); + } + return sprintf("%s[%s]", $self, $param); + }, + constraint_generator => LazyLoad(Tied => 'constraint_generator'), + inline_generator => LazyLoad(Tied => 'inline_generator'), +}); + +$meta->add_type({ + name => "InstanceOf", + parent => $_obj, + constraint_generator => sub { + return $meta->get_type('InstanceOf') unless @_; + require Type::Tiny::Class; + my @classes = map { + Types::TypeTiny::TypeTiny->check($_) + ? $_ + : "Type::Tiny::Class"->new(class => $_, display_name => sprintf('InstanceOf[%s]', B::perlstring($_))) + } @_; + return $classes[0] if @classes == 1; + + require B; + require Type::Tiny::Union; + return "Type::Tiny::Union"->new( + type_constraints => \@classes, + display_name => sprintf('InstanceOf[%s]', join q[,], map B::perlstring($_->class), @classes), + ); + }, +}); + +$meta->add_type({ + name => "ConsumerOf", + parent => $_obj, + constraint_generator => sub { + return $meta->get_type('ConsumerOf') unless @_; + require B; + require Type::Tiny::Role; + my @roles = map { + Types::TypeTiny::TypeTiny->check($_) + ? $_ + : "Type::Tiny::Role"->new(role => $_, display_name => sprintf('ConsumerOf[%s]', B::perlstring($_))) + } @_; + return $roles[0] if @roles == 1; + + require Type::Tiny::Intersection; + return "Type::Tiny::Intersection"->new( + type_constraints => \@roles, + display_name => sprintf('ConsumerOf[%s]', join q[,], map B::perlstring($_->role), @roles), + ); + }, +}); + +$meta->add_type({ + name => "HasMethods", + parent => $_obj, + constraint_generator => sub { + return $meta->get_type('HasMethods') unless @_; + require B; + require Type::Tiny::Duck; + return "Type::Tiny::Duck"->new( + methods => \@_, + display_name => sprintf('HasMethods[%s]', join q[,], map B::perlstring($_), @_), + ); + }, +}); + +$meta->add_type({ + name => "Enum", + parent => $_str, + constraint_generator => sub { + return $meta->get_type('Enum') unless @_; + require B; + require Type::Tiny::Enum; + return "Type::Tiny::Enum"->new( + values => \@_, + display_name => sprintf('Enum[%s]', join q[,], map B::perlstring($_), @_), + ); + }, +}); + +$meta->add_coercion({ + name => "MkOpt", + type_constraint => $meta->get_type("OptList"), + type_coercion_map => [ + $_arr, q{ Exporter::Tiny::mkopt($_) }, + $_hash, q{ Exporter::Tiny::mkopt($_) }, + $_undef, q{ [] }, + ], +}); + +$meta->add_coercion({ + name => "Join", + type_constraint => $_str, + coercion_generator => sub { + my ($self, $target, $sep) = @_; + Types::TypeTiny::StringLike->check($sep) + or _croak("Parameter to Join[`a] expected to be a string; got $sep"); + require B; + $sep = B::perlstring($sep); + return (ArrayRef(), qq{ join($sep, \@\$_) }); + }, +}); + +$meta->add_coercion({ + name => "Split", + type_constraint => $_arr, + coercion_generator => sub { + my ($self, $target, $re) = @_; + ref($re) eq q(Regexp) + or _croak("Parameter to Split[`a] expected to be a regular expresssion; got $re"); + my $regexp_string = "$re"; + $regexp_string =~ s/\\\//\\\\\//g; # toothpicks + return (Str(), qq{ [split /$regexp_string/, \$_] }); + }, +}); + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ + +=pod + +=for stopwords booleans vstrings typeglobs + +=encoding utf-8 + +=for stopwords datetimes + +=head1 NAME + +Types::Standard - bundled set of built-in types for Type::Tiny + +=head1 SYNOPSIS + + use v5.12; + use strict; + use warnings; + + package Horse { + use Moo; + use Types::Standard qw( Str Int Enum ArrayRef Object ); + use Type::Params qw( compile ); + use namespace::autoclean; + + has name => ( + is => 'ro', + isa => Str, + required => 1, + ); + has gender => ( + is => 'ro', + isa => Enum[qw( f m )], + ); + has age => ( + is => 'rw', + isa => Int->where( '$_ >= 0' ), + ); + has children => ( + is => 'ro', + isa => ArrayRef[Object], + default => sub { return [] }, + ); + + sub add_child { + state $check = compile( Object, Object ); # method signature + + my ($self, $child) = $check->(@_); # unpack @_ + push @{ $self->children }, $child; + + return $self; + } + } + + package main; + + my $boldruler = Horse->new( + name => "Bold Ruler", + gender => 'm', + age => 16, + ); + + my $secretariat = Horse->new( + name => "Secretariat", + gender => 'm', + age => 0, + ); + + $boldruler->add_child( $secretariat ); + + use Types::Standard qw( is_Object assert_Object ); + + # is_Object($thing) returns a boolean + my $is_it_an_object = is_Object($boldruler); + + # assert_Object($thing) returns $thing or dies + say assert_Object($boldruler)->name; # says "Bold Ruler" + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +This documents the details of the L type library. +L is a better starting place if you're new. + +L bundles a few types which seem to be useful. + +=head2 Moose-like + +The following types are similar to those described in +L. + +=over + +=item * + +B<< Any >> + +Absolutely any value passes this type constraint (even undef). + +=item * + +B<< Item >> + +Essentially the same as B. All other type constraints in this library +inherit directly or indirectly from B. + +=item * + +B<< Bool >> + +Values that are reasonable booleans. Accepts 1, 0, the empty string and +undef. + +=item * + +B<< Maybe[`a] >> + +Given another type constraint, also accepts undef. For example, +B<< Maybe[Int] >> accepts all integers plus undef. + +=item * + +B<< Undef >> + +Only undef passes this type constraint. + +=item * + +B<< Defined >> + +Only undef fails this type constraint. + +=item * + +B<< Value >> + +Any defined, non-reference value. + +=item * + +B<< Str >> + +Any string. + +(The only difference between B and B is that the former accepts +typeglobs and vstrings.) + +Other customers also bought: B<< StringLike >> from L. + +=item * + +B<< Num >> + +See B and B below. + +=item * + +B<< Int >> + +An integer; that is a string of digits 0 to 9, optionally prefixed with a +hyphen-minus character. + +=item * + +B<< ClassName >> + +The name of a loaded package. The package must have C<< @ISA >> or +C<< $VERSION >> defined, or must define at least one sub to be considered +a loaded package. + +=item * + +B<< RoleName >> + +Like B<< ClassName >>, but the package must I define a method called +C. This is subtly different from Moose's type constraint of the same +name; let me know if this causes you any problems. (I can't promise I'll +change anything though.) + +=item * + +B<< Ref[`a] >> + +Any defined reference value, including blessed objects. + +Unlike Moose, B is a parameterized type, allowing Scalar::Util::reftype +checks, a la + + Ref["HASH"] # hashrefs, including blessed hashrefs + +=item * + +B<< ScalarRef[`a] >> + +A value where C<< ref($value) eq "SCALAR" or ref($value) eq "REF" >>. + +If parameterized, the referred value must pass the additional constraint. +For example, B<< ScalarRef[Int] >> must be a reference to a scalar which +holds an integer value. + +=item * + +B<< ArrayRef[`a] >> + +A value where C<< ref($value) eq "ARRAY" >>. + +If parameterized, the elements of the array must pass the additional +constraint. For example, B<< ArrayRef[Num] >> must be a reference to an +array of numbers. + +As an extension to Moose's B type, a minimum and maximum array +length can be given: + + ArrayRef[CodeRef, 1] # ArrayRef of at least one CodeRef + ArrayRef[FileHandle, 0, 2] # ArrayRef of up to two FileHandles + ArrayRef[Any, 0, 100] # ArrayRef of up to 100 elements + +Other customers also bought: B<< ArrayLike >> from L. + +=item * + +B<< HashRef[`a] >> + +A value where C<< ref($value) eq "HASH" >>. + +If parameterized, the values of the hash must pass the additional +constraint. For example, B<< HashRef[Num] >> must be a reference to an +hash where the values are numbers. The hash keys are not constrained, +but Perl limits them to strings; see B below if you need to further +constrain the hash values. + +Other customers also bought: B<< HashLike >> from L. + +=item * + +B<< CodeRef >> + +A value where C<< ref($value) eq "CODE" >>. + +Other customers also bought: B<< CodeLike >> from L. + +=item * + +B<< RegexpRef >> + +A reference where C<< re::is_regexp($value) >> is true, or +a blessed reference where C<< $value->isa("Regexp") >> is true. + +=item * + +B<< GlobRef >> + +A value where C<< ref($value) eq "GLOB" >>. + +=item * + +B<< FileHandle >> + +A file handle. + +=item * + +B<< Object >> + +A blessed object. + +(This also accepts regexp refs.) + +=back + +=head2 Structured + +OK, so I stole some ideas from L. + +=over + +=item * + +B<< Map[`k, `v] >> + +Similar to B but parameterized with type constraints for both the +key and value. The constraint for keys would typically be a subtype of +B. + +=item * + +B<< Tuple[...] >> + +Subtype of B, accepting a list of type constraints for +each slot in the array. + +B<< Tuple[Int, HashRef] >> would match C<< [1, {}] >> but not C<< [{}, 1] >>. + +=item * + +B<< Dict[...] >> + +Subtype of B, accepting a list of type constraints for +each slot in the hash. + +For example B<< Dict[name => Str, id => Int] >> allows +C<< { name => "Bob", id => 42 } >>. + +=item * + +B<< Optional[`a] >> + +Used in conjunction with B and B to specify slots that are +optional and may be omitted (but not necessarily set to an explicit undef). + +B<< Dict[name => Str, id => Optional[Int]] >> allows C<< { name => "Bob" } >> +but not C<< { name => "Bob", id => "BOB" } >>. + +Note that any use of B<< Optional[`a] >> outside the context of +parameterized B and B type constraints makes little sense, +and its behaviour is undefined. (An exception: it is used by +L for a similar purpose to how it's used in B.) + +=back + +This module also exports a C function, which can be used as +follows. + +It can cause additional trailing values in a B to be slurped +into a structure and validated. For example, slurping into an arrayfef: + + my $type = Tuple[Str, slurpy ArrayRef[Int]]; + + $type->( ["Hello"] ); # ok + $type->( ["Hello", 1, 2, 3] ); # ok + $type->( ["Hello", [1, 2, 3]] ); # not ok + +Or into a hashref: + + my $type2 = Tuple[Str, slurpy Map[Int, RegexpRef]]; + + $type2->( ["Hello"] ); # ok + $type2->( ["Hello", 1, qr/one/i, 2, qr/two/] ); # ok + +It can cause additional values in a B to be slurped into a +hashref and validated: + + my $type3 = Dict[ values => ArrayRef, slurpy HashRef[Str] ]; + + $type3->( { values => [] } ); # ok + $type3->( { values => [], name => "Foo" } ); # ok + $type3->( { values => [], name => [] } ); # not ok + +In either B or B, B<< slurpy Any >> can be used to indicate +that additional values are acceptable, but should not be constrained in +any way. + +B<< slurpy Any >> is an optimized code path. Although the following are +essentially equivalent checks, the former should run a lot faster: + + Tuple[Int, slurpy Any] + Tuple[Int, slurpy ArrayRef] + +=begin trustme + +=item slurpy + +=end trustme + +=head2 Objects + +OK, so I stole some ideas from L. + +=over + +=item * + +B<< InstanceOf[`a] >> + +Shortcut for a union of L constraints. + +B<< InstanceOf["Foo", "Bar"] >> allows objects blessed into the C +or C classes, or subclasses of those. + +Given no parameters, just equivalent to B. + +=item * + +B<< ConsumerOf[`a] >> + +Shortcut for an intersection of L constraints. + +B<< ConsumerOf["Foo", "Bar"] >> allows objects where C<< $o->DOES("Foo") >> +and C<< $o->DOES("Bar") >> both return true. + +Given no parameters, just equivalent to B. + +=item * + +B<< HasMethods[`a] >> + +Shortcut for a L constraint. + +B<< HasMethods["foo", "bar"] >> allows objects where C<< $o->can("foo") >> +and C<< $o->can("bar") >> both return true. + +Given no parameters, just equivalent to B. + +=back + +=head2 More + +There are a few other types exported by this module: + +=over + +=item * + +B<< Overload[`a] >> + +With no parameters, checks that the value is an overloaded object. Can +be given one or more string parameters, which are specific operations +to check are overloaded. For example, the following checks for objects +which overload addition and subtraction. + + Overload["+", "-"] + +=item * + +B<< Tied[`a] >> + +A reference to a tied scalar, array or hash. + +Can be parameterized with a type constraint which will be applied to +the object returned by the C<< tied() >> function. As a convenience, +can also be parameterized with a string, which will be inflated to a +L. + + use Types::Standard qw(Tied); + use Type::Utils qw(class_type); + + my $My_Package = class_type { class => "My::Package" }; + + tie my %h, "My::Package"; + \%h ~~ Tied; # true + \%h ~~ Tied[ $My_Package ]; # true + \%h ~~ Tied["My::Package"]; # true + + tie my $s, "Other::Package"; + \$s ~~ Tied; # true + $s ~~ Tied; # false !! + +If you need to check that something is specifically a reference to +a tied hash, use an intersection: + + use Types::Standard qw( Tied HashRef ); + + my $TiedHash = (Tied) & (HashRef); + + tie my %h, "My::Package"; + tie my $s, "Other::Package"; + + \%h ~~ $TiedHash; # true + \$s ~~ $TiedHash; # false + +=item * + +B<< StrMatch[`a] >> + +A string that matches a regular expression: + + declare "Distance", + as StrMatch[ qr{^([0-9]+)\s*(mm|cm|m|km)$} ]; + +You can optionally provide a type constraint for the array of subexpressions: + + declare "Distance", + as StrMatch[ + qr{^([0-9]+)\s*(.+)$}, + Tuple[ + Int, + enum(DistanceUnit => [qw/ mm cm m km /]), + ], + ]; + +Here's an example using L: + + package Local::Host { + use Moose; + use Regexp::Common; + has ip_address => ( + is => 'ro', + required => 1, + isa => StrMatch[/^$RE{net}{IPv4}$/], + default => '127.0.0.1', + ); + } + +On certain versions of Perl, type constraints of the forms +B<< StrMatch[qr/../ >> and B<< StrMatch[qr/\A..\z/ >> with any number +of intervening dots can be optimized to simple length checks. + +=item * + +B<< Enum[`a] >> + +As per MooX::Types::MooseLike::Base: + + has size => (is => "ro", isa => Enum[qw( S M L XL XXL )]); + +=item * + +B<< OptList >> + +An arrayref of arrayrefs in the style of L output. + +=item * + +B<< LaxNum >>, B<< StrictNum >> + +In Moose 2.09, the B type constraint implementation was changed from +being a wrapper around L's C function to +a stricter regexp (which disallows things like "-Inf" and "Nan"). + +Types::Standard provides I implementations. B is measurably +faster. + +The B type constraint is currently an alias for B unless you +set the C environment variable to true before +loading Types::Standard, in which case it becomes an alias for B. +The constant C<< Types::Standard::STRICTNUM >> can be used to check if +B is being strict. + +Most people should probably use B or B. Don't explicitly +use B unless you specifically need an attribute which will accept +things like "Inf". + +=item * + +B<< CycleTuple[`a] >> + +Similar to B, but cyclical. + + CycleTuple[Int, HashRef] + +will allow C<< [1,{}] >> and C<< [1,{},2,{}] >> but disallow +C<< [1,{},2] >> and C<< [1,{},2,[]] >>. + +I think you understand B already. + +Currently B and C parameters are forbidden. There are +fairly limited use cases for them, and it's not exactly clear what they +should mean. + +The following is an efficient way of checking for an even-sized arrayref: + + CycleTuple[Any, Any] + +The following is an arrayref which would be suitable for coercing to a +hashref: + + CycleTuple[Str, Any] + +All the examples so far have used two parameters, but the following is +also a possible B: + + CycleTuple[Str, Int, HashRef] + +This will be an arrayref where the 0th, 3rd, 6th, etc values are +strings, the 1st, 4th, 7th, etc values are integers, and the 2nd, +5th, 8th, etc values are hashrefs. + +=back + +=head2 Coercions + +Most of the types in this type library have no coercions by default. +The exception is B as of Types::Standard 1.003_003, which coerces +from B via C<< !!$_ >>. + +Some standalone coercions may be exported. These can be combined +with type constraints using the C<< plus_coercions >> method. + +=over + +=item * + +B<< MkOpt >> + +A coercion from B, B or B to B. Example +usage in a Moose attribute: + + use Types::Standard qw( OptList MkOpt ); + + has options => ( + is => "ro", + isa => OptList->plus_coercions( MkOpt ), + coerce => 1, + ); + +=item * + +B<< Split[`a] >> + +Split a string on a regexp. + + use Types::Standard qw( ArrayRef Str Split ); + + has name => ( + is => "ro", + isa => ArrayRef->of(Str)->plus_coercions(Split[qr/\s/]), + coerce => 1, + ); + +=item * + +B<< Join[`a] >> + +Join an array of strings with a delimiter. + + use Types::Standard qw( Str Join ); + + my $FileLines = Str->plus_coercions(Join["\n"]); + + has file_contents => ( + is => "ro", + isa => $FileLines, + coerce => 1, + ); + +=back + +=head2 Constants + +=over + +=item C<< Types::Standard::STRICTNUM >> + +Indicates whether B is an alias for B. (It is usually an +alias for B.) + +=back + +=head2 Environment + +=over + +=item C + +Switches to more strict regexp-based number checking instead of using +C. + +=item C + +If set to false, can be used to suppress the loading of XS implementions of +some type constraints. + +=item C + +If C does not exist, can be set to true to suppress XS +usage similarly. (Several other CPAN distributions also pay attention to this +environment variable.) + +=back + +=begin private + +=item Stringable + +=item LazyLoad + +=end private + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +L. + +L, L, L, L. + +L, +L, +L. + +L provides some type constraints based on XML Schema's data +types; this includes constraints for ISO8601-formatted datetimes, integer +ranges (e.g. B<< PositiveInteger[maxInclusive=>10] >> and so on. + +L provides B and B type constraints that +were formerly found in Types::Standard. + +L and L provide replacements +for L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard/ArrayRef.pm @@ -0,0 +1,249 @@ +package Types::Standard::ArrayRef; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Types::Standard::ArrayRef::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::ArrayRef::VERSION = '1.010000'; +} + +$Types::Standard::ArrayRef::VERSION =~ tr/_//d; + +use Type::Tiny (); +use Types::Standard (); +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +no warnings; + +sub __constraint_generator +{ + return Types::Standard::ArrayRef unless @_; + + my $param = shift; + Types::TypeTiny::TypeTiny->check($param) + or _croak("Parameter to ArrayRef[`a] expected to be a type constraint; got $param"); + + my ($min, $max) = (0, -1); + $min = Types::Standard::Int->assert_return(shift) if @_; + $max = Types::Standard::Int->assert_return(shift) if @_; + + my $param_compiled_check = $param->compiled_check; + my $xsub; + if (Type::Tiny::_USE_XS and $min==0 and $max==-1) + { + my $paramname = Type::Tiny::XS::is_known($param_compiled_check); + $xsub = Type::Tiny::XS::get_coderef_for("ArrayRef[$paramname]") + if $paramname; + } + elsif (Type::Tiny::_USE_MOUSE and $param->_has_xsub and $min==0 and $max==-1) + { + require Mouse::Util::TypeConstraints; + my $maker = "Mouse::Util::TypeConstraints"->can("_parameterize_ArrayRef_for"); + $xsub = $maker->($param) if $maker; + } + + return ( + sub { + my $array = shift; + $param->check($_) || return for @$array; + return !!1; + }, + $xsub, + ) if $min==0 and $max==-1; + + return sub { + my $array = shift; + return if @$array < $min; + $param->check($_) || return for @$array; + return !!1; + } if $max==-1; + + return sub { + my $array = shift; + return if @$array > $max; + $param->check($_) || return for @$array; + return !!1; + } if $min==0; + + return sub { + my $array = shift; + return if @$array < $min; + return if @$array > $max; + $param->check($_) || return for @$array; + return !!1; + }; +} + +sub __inline_generator +{ + my $param = shift; + my ($min, $max) = (0, -1); + $min = shift if @_; + $max = shift if @_; + + my $param_compiled_check = $param->compiled_check; + my $xsubname; + if (Type::Tiny::_USE_XS and $min==0 and $max==-1) + { + my $paramname = Type::Tiny::XS::is_known($param_compiled_check); + $xsubname = Type::Tiny::XS::get_subname_for("ArrayRef[$paramname]"); + } + + return unless $param->can_be_inlined; + + return sub { + my $v = $_[1]; + return "$xsubname\($v\)" if $xsubname && !$Type::Tiny::AvoidCallbacks; + my $p = Types::Standard::ArrayRef->inline_check($v); + + if ($min != 0) { + $p .= sprintf(' and @{%s} >= %d', $v, $min); + } + if ($max > 0) { + $p .= sprintf(' and @{%s} <= %d', $v, $max); + } + + my $param_check = $param->inline_check('$i'); + return $p if $param->{uniq} eq Types::Standard::Any->{uniq}; + + "$p and do { " + . "my \$ok = 1; " + . "for my \$i (\@{$v}) { " + . "(\$ok = 0, last) unless $param_check " + . "}; " + . "\$ok " + ."}" + }; +} + +sub __deep_explanation +{ + my ($type, $value, $varname) = @_; + my $param = $type->parameters->[0]; + my ($min, $max) = (0, -1); + $min = $type->parameters->[1] if @{$type->parameters} > 1; # TODO + $max = $type->parameters->[2] if @{$type->parameters} > 2; # TODO + + if ($min != 0 and @$value < $min) { + return [ + sprintf('"%s" constrains array length at least %s', $type, $min), + sprintf('@{%s} is %d', $varname, scalar @$value), + ]; + } + + if ($max > 0 and @$value > $max) { + return [ + sprintf('"%s" constrains array length at most %d', $type, $max), + sprintf('@{%s} is %d', $varname, scalar @$value), + ]; + } + + for my $i (0 .. $#$value) + { + my $item = $value->[$i]; + next if $param->check($item); + return [ + sprintf('"%s" constrains each value in the array with "%s"', $type, $param), + @{ $param->validate_explain($item, sprintf('%s->[%d]', $varname, $i)) }, + ]; + } + + # This should never happen... + return; # uncoverable statement +} + +# TODO: min and max??? +sub __coercion_generator +{ + my ($parent, $child, $param) = @_; + return unless $param->has_coercion; + + my $coercable_item = $param->coercion->_source_type_union; + my $C = "Type::Coercion"->new(type_constraint => $child); + + if ($param->coercion->can_be_inlined and $coercable_item->can_be_inlined) + { + $C->add_type_coercions($parent => Types::Standard::Stringable { + my @code; + push @code, 'do { my ($orig, $return_orig, @new) = ($_, 0);'; + push @code, 'for (@$orig) {'; + push @code, sprintf('++$return_orig && last unless (%s);', $coercable_item->inline_check('$_')); + push @code, sprintf('push @new, (%s);', $param->coercion->inline_coercion('$_')); + push @code, '}'; + push @code, '$return_orig ? $orig : \\@new'; + push @code, '}'; + "@code"; + }); + } + else + { + $C->add_type_coercions( + $parent => sub { + my $value = @_ ? $_[0] : $_; + my @new; + for my $item (@$value) + { + return $value unless $coercable_item->check($item); + push @new, $param->coerce($item); + } + return \@new; + }, + ); + } + + return $C; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Standard::ArrayRef - internals for the Types::Standard ArrayRef type constraint + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This file contains some of the guts for L. +It will be loaded on demand. You may ignore its presence. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard/CycleTuple.pm @@ -0,0 +1,261 @@ +package Types::Standard::CycleTuple; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Types::Standard::CycleTuple::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::CycleTuple::VERSION = '1.010000'; +} + +$Types::Standard::CycleTuple::VERSION =~ tr/_//d; + +use Type::Tiny (); +use Types::Standard (); +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +my $_Optional = Types::Standard::Optional; +my $_arr = Types::Standard::ArrayRef; + +no warnings; + +my $cycleuniq = 0; + +sub __constraint_generator +{ + my @params = map { + ref($_) eq 'HASH' and exists($_->{slurpy}) + and _croak("Parameters to CycleTuple[...] cannot be slurpy"); + my $param = $_; + Types::TypeTiny::TypeTiny->check($param) + or _croak("Parameters to CycleTuple[...] expected to be type constraints; got $param"); + $param; + } @_; + my $count = @params; + my $tuple = Types::Standard::Tuple()->of(@params); + + _croak("Parameters to CycleTuple[...] cannot be optional") + if grep !!$_->is_strictly_a_type_of($_Optional), @params; + + sub { + my $value = shift; + return unless $_arr->check($value); + return if @$value % $count; + my $i = 0; + while ($i < $#$value) { + my $tmp = [@$value[ $i .. $i+$count-1 ]]; + return unless $tuple->check($tmp); + $i += $count; + } + !!1; + } +} + +sub __inline_generator +{ + my @params = map { + my $param = $_; + Types::TypeTiny::TypeTiny->check($param) + or _croak("Parameter to CycleTuple[`a] expected to be a type constraint; got $param"); + $param; + } @_; + my $count = @params; + my $tuple = Types::Standard::Tuple()->of(@params); + + return unless $tuple->can_be_inlined; + + sub { + $cycleuniq++; + + my $v = $_[1]; + my @checks = $_arr->inline_check($v); + push @checks, sprintf( + 'not(@%s %% %d)', + ($v=~/\A\$[a-z0-9_]+\z/i ? $v : "{$v}"), + $count, + ); + push @checks, sprintf( + 'do { my $cyclecount%d = 0; my $cycleok%d = 1; while ($cyclecount%d < $#{%s}) { my $cycletmp%d = [@{%s}[$cyclecount%d .. $cyclecount%d+%d]]; unless (%s) { $cycleok%d = 0; last; }; $cyclecount%d += %d; }; $cycleok%d; }', + $cycleuniq, + $cycleuniq, + $cycleuniq, + $v, + $cycleuniq, + $v, + $cycleuniq, + $cycleuniq, + $count - 1, + $tuple->inline_check("\$cycletmp$cycleuniq"), + $cycleuniq, + $cycleuniq, + $count, + $cycleuniq, + ) if grep { $_->inline_check('$xyz') ne '(!!1)' } @params; + join(' && ', @checks); + } +} + +sub __deep_explanation +{ + my ($type, $value, $varname) = @_; + + my @constraints = + map Types::TypeTiny::to_TypeTiny($_), @{ $type->parameters }; + + if (@$value % @constraints) + { + return [ + sprintf('"%s" expects a multiple of %d values in the array', $type, scalar(@constraints)), + sprintf('%d values found', scalar(@$value)), + ]; + } + + for my $i (0 .. $#$value) + { + my $constraint = $constraints[$i % @constraints]; + next if $constraint->check($value->[$i]); + + return [ + sprintf('"%s" constrains value at index %d of array with "%s"', $type, $i, $constraint), + @{ $constraint->validate_explain($value->[$i], sprintf('%s->[%s]', $varname, $i)) }, + ]; + } + + # This should never happen... + return; # uncoverable statement +} + +my $label_counter = 0; +sub __coercion_generator +{ + my ($parent, $child, @tuple) = @_; + + my $child_coercions_exist = 0; + my $all_inlinable = 1; + for my $tc (@tuple) + { + $all_inlinable = 0 if !$tc->can_be_inlined; + $all_inlinable = 0 if $tc->has_coercion && !$tc->coercion->can_be_inlined; + $child_coercions_exist++ if $tc->has_coercion; + } + + return unless $child_coercions_exist; + my $C = "Type::Coercion"->new(type_constraint => $child); + + if ($all_inlinable) + { + $C->add_type_coercions($parent => Types::Standard::Stringable { + my $label = sprintf("CTUPLELABEL%d", ++$label_counter); + my $label2 = sprintf("CTUPLEINNER%d", $label_counter); + my @code; + push @code, 'do { my ($orig, $return_orig, $tmp, @new) = ($_, 0);'; + push @code, "$label: {"; + push @code, sprintf('(($return_orig = 1), last %s) if scalar(@$orig) %% %d != 0;', $label, scalar @tuple); + push @code, sprintf('my $%s = 0; while ($%s < @$orig) {', $label2, $label2); + for my $i (0 .. $#tuple) + { + my $ct = $tuple[$i]; + my $ct_coerce = $ct->has_coercion; + + push @code, sprintf( + 'do { $tmp = %s; (%s) ? ($new[$%s + %d]=$tmp) : (($return_orig=1), last %s) };', + $ct_coerce + ? $ct->coercion->inline_coercion("\$orig->[\$$label2 + $i]") + : "\$orig->[\$$label2 + $i]", + $ct->inline_check('$tmp'), + $label2, + $i, + $label, + ); + } + push @code, sprintf('$%s += %d;', $label2, scalar(@tuple)); + push @code, '}'; + push @code, '}'; + push @code, '$return_orig ? $orig : \\@new'; + push @code, '}'; + "@code"; + }); + } + + else + { + $C->add_type_coercions( + $parent => sub { + my $value = @_ ? $_[0] : $_; + + if (scalar(@$value) % scalar(@tuple) != 0) + { + return $value; + } + + my @new; + for my $i (0 .. $#$value) + { + my $ct = $tuple[$i % @tuple]; + my $x = $ct->has_coercion ? $ct->coerce($value->[$i]) : $value->[$i]; + + return $value unless $ct->check($x); + + $new[$i] = $x; + } + + return \@new; + }, + ); + }; + + return $C; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Standard::CycleTuple - internals for the Types::Standard CycleTuple type constraint + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This file contains some of the guts for L. +It will be loaded on demand. You may ignore its presence. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard/Dict.pm @@ -0,0 +1,470 @@ +package Types::Standard::Dict; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Types::Standard::Dict::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::Dict::VERSION = '1.010000'; +} + +$Types::Standard::Dict::VERSION =~ tr/_//d; + +use Types::Standard (); +use Types::TypeTiny (); + +sub _croak ($;@) { require Carp; goto \&Carp::confess; require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +my $_optional = Types::Standard::Optional; +my $_hash = Types::Standard::HashRef; +my $_map = Types::Standard::Map; +my $_any = Types::Standard::Any; + +no warnings; + +sub pair_iterator { + _croak("Expected even-sized list") if @_ % 2; + my @array = @_; + sub { + return unless @array; + splice(@array, 0, 2); + }; +} + +sub __constraint_generator +{ + my $shash; + my $slurpy = ref($_[-1]) eq q(HASH) ? do { $shash = pop @_; Types::TypeTiny::to_TypeTiny($shash->{slurpy}) } : undef; + my $iterator = pair_iterator @_; + my %constraints; + my %is_optional; + my @keys; + + if ($slurpy) + { + Types::TypeTiny::TypeTiny->check($slurpy) + or _croak("Slurpy parameter to Dict[...] expected to be a type constraint; got $slurpy"); + + $shash->{slurpy} = $slurpy; # store canonicalized slurpy + } + + while (my ($k, $v) = $iterator->()) + { + $constraints{$k} = $v; + Types::TypeTiny::TypeTiny->check($v) + or _croak("Parameter for Dict[...] with key '$k' expected to be a type constraint; got $v"); + Types::TypeTiny::StringLike->check($k) + or _croak("Key for Dict[...] expected to be string; got $k"); + push @keys, $k; + $is_optional{$k} = !!$constraints{$k}->is_strictly_a_type_of($_optional); + } + + return sub + { + my $value = $_[0]; + if ($slurpy) + { + my %tmp = map { + exists($constraints{$_}) ? () : ($_ => $value->{$_}) + } keys %$value; + return unless $slurpy->check(\%tmp); + } + else + { + exists($constraints{$_}) || return for sort keys %$value; + } + for my $k (@keys) { + exists($value->{$k}) or ($is_optional{$k} ? next : return); + $constraints{$k}->check($value->{$k}) or return; + } + return !!1; + }; +} + +sub __inline_generator +{ + # We can only inline a parameterized Dict if all the + # constraints inside can be inlined. + + my $slurpy = ref($_[-1]) eq q(HASH) ? pop(@_)->{slurpy} : undef; + return if $slurpy && !$slurpy->can_be_inlined; + + # Is slurpy a very loose type constraint? + # i.e. Any, Item, Defined, Ref, or HashRef + my $slurpy_is_any = $slurpy && $_hash->is_a_type_of( $slurpy ); + + # Is slurpy a parameterized Map, or expressable as a parameterized Map? + my $slurpy_is_map = $slurpy + && $slurpy->is_parameterized + && (( + $slurpy->parent->strictly_equals($_map) + && $slurpy->parameters + )||( + $slurpy->parent->strictly_equals($_hash) + && [ $_any, $slurpy->parameters->[0] ] + )); + + my $iterator = pair_iterator @_; + my %constraints; + my @keys; + + while (my ($k, $c) = $iterator->()) + { + return unless $c->can_be_inlined; + $constraints{$k} = $c; + push @keys, $k; + } + + my $regexp = join "|", map quotemeta, @keys; + return sub + { + require B; + my $h = $_[1]; + join " and ", + Types::Standard::HashRef->inline_check($h), + ( $slurpy_is_any ? () + : $slurpy_is_map ? do { + '(not grep {' + ."my \$v = ($h)->{\$_};" + .sprintf( + 'not((/\\A(?:%s)\\z/) or ((%s) and (%s)))', + $regexp, + $slurpy_is_map->[0]->inline_check('$_'), + $slurpy_is_map->[1]->inline_check('$v'), + ) ."} keys \%{$h})" + } + : $slurpy ? do { + 'do {' + . "my \$slurpy_tmp = +{ map /\\A(?:$regexp)\\z/ ? () : (\$_ => ($h)->{\$_}), keys \%{$h} };" + . $slurpy->inline_check('$slurpy_tmp') + . '}' + } + : "not(grep !/\\A(?:$regexp)\\z/, keys \%{$h})" ), + ( map { + my $k = B::perlstring($_); + $constraints{$_}->is_strictly_a_type_of( $_optional ) + ? sprintf('(!exists %s->{%s} or %s)', $h, $k, $constraints{$_}->inline_check("$h\->{$k}")) + : ( "exists($h\->{$k})", $constraints{$_}->inline_check("$h\->{$k}") ) + } @keys ), + } +} + +sub __deep_explanation +{ + require B; + my ($type, $value, $varname) = @_; + my @params = @{ $type->parameters }; + + my $slurpy = ref($params[-1]) eq q(HASH) ? pop(@params)->{slurpy} : undef; + my $iterator = pair_iterator @params; + my %constraints; + my @keys; + + while (my ($k, $c) = $iterator->()) + { + push @keys, $k; + $constraints{$k} = $c; + } + + for my $k (@keys) + { + next if $constraints{$k}->has_parent && ($constraints{$k}->parent == Types::Standard::Optional) && (!exists $value->{$k}); + next if $constraints{$k}->check($value->{$k}); + + return [ + sprintf('"%s" requires key %s to appear in hash', $type, B::perlstring($k)) + ] unless exists $value->{$k}; + + return [ + sprintf('"%s" constrains value at key %s of hash with "%s"', $type, B::perlstring($k), $constraints{$k}), + @{ $constraints{$k}->validate_explain($value->{$k}, sprintf('%s->{%s}', $varname, B::perlstring($k))) }, + ]; + } + + if ($slurpy) + { + my %tmp = map { + exists($constraints{$_}) ? () : ($_ => $value->{$_}) + } keys %$value; + + my $explain = $slurpy->validate_explain(\%tmp, '$slurpy'); + return [ + sprintf('"%s" requires the hashref of additional key/value pairs to conform to "%s"', $type, $slurpy), + @$explain, + ] if $explain; + } + else + { + for my $k (sort keys %$value) + { + return [ + sprintf('"%s" does not allow key %s to appear in hash', $type, B::perlstring($k)) + ] unless exists $constraints{$k}; + } + } + + # This should never happen... + return; # uncoverable statement +} + +my $label_counter = 0; +our ($keycheck_counter, @KEYCHECK) = -1; +sub __coercion_generator +{ + my $slurpy = ref($_[-1]) eq q(HASH) ? pop(@_)->{slurpy} : undef; + my ($parent, $child, %dict) = @_; + my $C = "Type::Coercion"->new(type_constraint => $child); + + my $all_inlinable = 1; + my $child_coercions_exist = 0; + for my $tc (values %dict) + { + $all_inlinable = 0 if !$tc->can_be_inlined; + $all_inlinable = 0 if $tc->has_coercion && !$tc->coercion->can_be_inlined; + $child_coercions_exist++ if $tc->has_coercion; + } + $all_inlinable = 0 if $slurpy && !$slurpy->can_be_inlined; + $all_inlinable = 0 if $slurpy && $slurpy->has_coercion && !$slurpy->coercion->can_be_inlined; + + $child_coercions_exist++ if $slurpy && $slurpy->has_coercion; + return unless $child_coercions_exist; + + if ($all_inlinable) + { + $C->add_type_coercions($parent => Types::Standard::Stringable { + require B; + + my $keycheck = join "|", map quotemeta, sort { length($b) <=> length($a) or $a cmp $b } keys %dict; + $keycheck = $KEYCHECK[++$keycheck_counter] = qr{^($keycheck)$}ms; # regexp for legal keys + + my $label = sprintf("DICTLABEL%d", ++$label_counter); + my @code; + push @code, 'do { my ($orig, $return_orig, $tmp, %new) = ($_, 0);'; + push @code, "$label: {"; + if ($slurpy) + { + push @code, sprintf('my $slurped = +{ map +($_=~$%s::KEYCHECK[%d])?():($_=>$orig->{$_}), keys %%$orig };', __PACKAGE__, $keycheck_counter); + if ($slurpy->has_coercion) + { + push @code, sprintf('my $coerced = %s;', $slurpy->coercion->inline_coercion('$slurped')); + push @code, sprintf('((%s)&&(%s))?(%%new=%%$coerced):(($return_orig = 1), last %s);', $_hash->inline_check('$coerced'), $slurpy->inline_check('$coerced'), $label); + } + else + { + push @code, sprintf('(%s)?(%%new=%%$slurped):(($return_orig = 1), last %s);', $slurpy->inline_check('$slurped'), $label); + } + } + else + { + push @code, sprintf('($_ =~ $%s::KEYCHECK[%d])||(($return_orig = 1), last %s) for sort keys %%$orig;', __PACKAGE__, $keycheck_counter, $label); + } + for my $k (keys %dict) + { + my $ct = $dict{$k}; + my $ct_coerce = $ct->has_coercion; + my $ct_optional = $ct->is_a_type_of($_optional); + my $K = B::perlstring($k); + + push @code, sprintf( + 'if (exists $orig->{%s}) { $tmp = %s; (%s) ? ($new{%s}=$tmp) : (($return_orig=1), last %s) }', + $K, + $ct_coerce + ? $ct->coercion->inline_coercion("\$orig->{$K}") + : "\$orig->{$K}", + $ct->inline_check('$tmp'), + $K, + $label, + ); + } + push @code, '}'; + push @code, '$return_orig ? $orig : \\%new'; + push @code, '}'; + #warn "CODE:: @code"; + "@code"; + }); + } + + else + { + my %is_optional = map { + ; $_ => !!$dict{$_}->is_strictly_a_type_of($_optional) + } sort keys %dict; + $C->add_type_coercions( + $parent => sub { + my $value = @_ ? $_[0] : $_; + my %new; + + if ($slurpy) + { + my %slurped = map exists($dict{$_}) ? () : ($_ => $value->{$_}), keys %$value; + + if ($slurpy->check(\%slurped)) + { + %new = %slurped; + } + elsif ($slurpy->has_coercion) + { + my $coerced = $slurpy->coerce(\%slurped); + $slurpy->check($coerced) ? (%new = %$coerced) : (return $value); + } + else + { + return $value; + } + } + else + { + for my $k (keys %$value) + { + return $value unless exists $dict{$k}; + } + } + + for my $k (keys %dict) + { + next if $is_optional{$k} and not exists $value->{$k}; + + my $ct = $dict{$k}; + my $x = $ct->has_coercion ? $ct->coerce($value->{$k}) : $value->{$k}; + + return $value unless $ct->check($x); + + $new{$k} = $x; + } + + return \%new; + }, + ); + } + + return $C; +} + +sub __dict_is_slurpy +{ + my $self = shift; + + return !!0 if $self==Types::Standard::Dict(); + + my $dict = $self->find_parent(sub { $_->has_parent && $_->parent==Types::Standard::Dict() }); + ref($dict->parameters->[-1]) eq q(HASH) + ? $dict->parameters->[-1]{slurpy} + : !!0 +} + +sub __hashref_allows_key +{ + my $self = shift; + my ($key) = @_; + + return Types::Standard::Str()->check($key) if $self==Types::Standard::Dict(); + + my $dict = $self->find_parent(sub { $_->has_parent && $_->parent==Types::Standard::Dict() }); + my %params; + my $slurpy = $dict->my_dict_is_slurpy; + if ($slurpy) + { + my @args = @{$dict->parameters}; + pop @args; + %params = @args; + } + else + { + %params = @{ $dict->parameters } + } + + return !!1 + if exists($params{$key}); + return !!0 + if !$slurpy; + return Types::Standard::Str()->check($key) + if $slurpy==Types::Standard::Any() || $slurpy==Types::Standard::Item() || $slurpy==Types::Standard::Defined() || $slurpy==Types::Standard::Ref(); + return $slurpy->my_hashref_allows_key($key) + if $slurpy->is_a_type_of(Types::Standard::HashRef()); + return !!0; +} + +sub __hashref_allows_value +{ + my $self = shift; + my ($key, $value) = @_; + + return !!0 unless $self->my_hashref_allows_key($key); + return !!1 if $self==Types::Standard::Dict(); + + my $dict = $self->find_parent(sub { $_->has_parent && $_->parent==Types::Standard::Dict() }); + my %params; + my $slurpy = $dict->my_dict_is_slurpy; + if ($slurpy) + { + my @args = @{$dict->parameters}; + pop @args; + %params = @args; + } + else + { + %params = @{ $dict->parameters } + } + + return !!1 + if exists($params{$key}) && $params{$key}->check($value); + return !!0 + if !$slurpy; + return !!1 + if $slurpy==Types::Standard::Any() || $slurpy==Types::Standard::Item() || $slurpy==Types::Standard::Defined() || $slurpy==Types::Standard::Ref(); + return $slurpy->my_hashref_allows_value($key, $value) + if $slurpy->is_a_type_of(Types::Standard::HashRef()); + return !!0; +} + + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Standard::Dict - internals for the Types::Standard Dict type constraint + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This file contains some of the guts for L. +It will be loaded on demand. You may ignore its presence. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard/HashRef.pm @@ -0,0 +1,212 @@ +package Types::Standard::HashRef; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Types::Standard::HashRef::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::HashRef::VERSION = '1.010000'; +} + +$Types::Standard::HashRef::VERSION =~ tr/_//d; + +use Type::Tiny (); +use Types::Standard (); +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +no warnings; + +sub __constraint_generator +{ + return Types::Standard::HashRef unless @_; + + my $param = shift; + Types::TypeTiny::TypeTiny->check($param) + or _croak("Parameter to HashRef[`a] expected to be a type constraint; got $param"); + + my $param_compiled_check = $param->compiled_check; + my $xsub; + if (Type::Tiny::_USE_XS) + { + my $paramname = Type::Tiny::XS::is_known($param_compiled_check); + $xsub = Type::Tiny::XS::get_coderef_for("HashRef[$paramname]") + if $paramname; + } + elsif (Type::Tiny::_USE_MOUSE and $param->_has_xsub) + { + require Mouse::Util::TypeConstraints; + my $maker = "Mouse::Util::TypeConstraints"->can("_parameterize_HashRef_for"); + $xsub = $maker->($param) if $maker; + } + + return ( + sub + { + my $hash = shift; + $param->check($_) || return for values %$hash; + return !!1; + }, + $xsub, + ); +} + +sub __inline_generator +{ + my $param = shift; + + my $compiled = $param->compiled_check; + my $xsubname; + if (Type::Tiny::_USE_XS and not $Type::Tiny::AvoidCallbacks) + { + my $paramname = Type::Tiny::XS::is_known($compiled); + $xsubname = Type::Tiny::XS::get_subname_for("HashRef[$paramname]"); + } + + return unless $param->can_be_inlined; + return sub { + my $v = $_[1]; + return "$xsubname\($v\)" if $xsubname && !$Type::Tiny::AvoidCallbacks; + my $p = Types::Standard::HashRef->inline_check($v); + my $param_check = $param->inline_check('$i'); + + "$p and do { " + . "my \$ok = 1; " + . "for my \$i (values \%{$v}) { " + . "(\$ok = 0, last) unless $param_check " + . "}; " + . "\$ok " + ."}" + }; +} + +sub __deep_explanation +{ + require B; + my ($type, $value, $varname) = @_; + my $param = $type->parameters->[0]; + + for my $k (sort keys %$value) + { + my $item = $value->{$k}; + next if $param->check($item); + return [ + sprintf('"%s" constrains each value in the hash with "%s"', $type, $param), + @{ $param->validate_explain($item, sprintf('%s->{%s}', $varname, B::perlstring($k))) }, + ]; + } + + # This should never happen... + return; # uncoverable statement +} + +sub __coercion_generator +{ + my ($parent, $child, $param) = @_; + return unless $param->has_coercion; + + my $coercable_item = $param->coercion->_source_type_union; + my $C = "Type::Coercion"->new(type_constraint => $child); + + if ($param->coercion->can_be_inlined and $coercable_item->can_be_inlined) + { + $C->add_type_coercions($parent => Types::Standard::Stringable { + my @code; + push @code, 'do { my ($orig, $return_orig, %new) = ($_, 0);'; + push @code, 'for (keys %$orig) {'; + push @code, sprintf('$return_orig++ && last unless (%s);', $coercable_item->inline_check('$orig->{$_}')); + push @code, sprintf('$new{$_} = (%s);', $param->coercion->inline_coercion('$orig->{$_}')); + push @code, '}'; + push @code, '$return_orig ? $orig : \\%new'; + push @code, '}'; + "@code"; + }); + } + else + { + $C->add_type_coercions( + $parent => sub { + my $value = @_ ? $_[0] : $_; + my %new; + for my $k (keys %$value) + { + return $value unless $coercable_item->check($value->{$k}); + $new{$k} = $param->coerce($value->{$k}); + } + return \%new; + }, + ); + } + + return $C; +} + +sub __hashref_allows_key { + my $self = shift; + Types::Standard::Str()->check($_[0]); +} + +sub __hashref_allows_value { + my $self = shift; + my ($key, $value) = @_; + + return !!0 unless $self->my_hashref_allows_key($key); + return !!1 if $self==Types::Standard::HashRef(); + + my $href = $self->find_parent(sub { $_->has_parent && $_->parent==Types::Standard::HashRef() }); + my $param = $href->type_parameter; + + Types::Standard::Str()->check($key) and $param->check($value); +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Standard::HashRef - internals for the Types::Standard HashRef type constraint + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This file contains some of the guts for L. +It will be loaded on demand. You may ignore its presence. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard/Map.pm @@ -0,0 +1,253 @@ +package Types::Standard::Map; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Types::Standard::Map::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::Map::VERSION = '1.010000'; +} + +$Types::Standard::Map::VERSION =~ tr/_//d; + +use Type::Tiny (); +use Types::Standard (); +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +my $meta = Types::Standard->meta; + +no warnings; + +sub __constraint_generator +{ + return $meta->get_type('Map') unless @_; + + my ($keys, $values) = @_; + Types::TypeTiny::TypeTiny->check($keys) + or _croak("First parameter to Map[`k,`v] expected to be a type constraint; got $keys"); + Types::TypeTiny::TypeTiny->check($values) + or _croak("Second parameter to Map[`k,`v] expected to be a type constraint; got $values"); + + my @xsub; + if (Type::Tiny::_USE_XS) + { + my @known = map { + my $known = Type::Tiny::XS::is_known($_->compiled_check); + defined($known) ? $known : (); + } ($keys, $values); + + if (@known == 2) + { + my $xsub = Type::Tiny::XS::get_coderef_for( + sprintf "Map[%s,%s]", @known + ); + push @xsub, $xsub if $xsub; + } + } + + sub + { + my $hash = shift; + $keys->check($_) || return for keys %$hash; + $values->check($_) || return for values %$hash; + return !!1; + }, @xsub; +} + +sub __inline_generator +{ + my ($k, $v) = @_; + return unless $k->can_be_inlined && $v->can_be_inlined; + + my $xsubname; + if (Type::Tiny::_USE_XS) + { + my @known = map { + my $known = Type::Tiny::XS::is_known($_->compiled_check); + defined($known) ? $known : (); + } ($k, $v); + + if (@known == 2) + { + $xsubname = Type::Tiny::XS::get_subname_for( + sprintf "Map[%s,%s]", @known + ); + } + } + + return sub { + my $h = $_[1]; + return "$xsubname\($h\)" if $xsubname && !$Type::Tiny::AvoidCallbacks; + my $p = Types::Standard::HashRef->inline_check($h); + my $k_check = $k->inline_check('$k'); + my $v_check = $v->inline_check('$v'); + "$p and do { " + . "my \$ok = 1; " + . "for my \$v (values \%{$h}) { " + . "(\$ok = 0, last) unless $v_check " + . "}; " + . "for my \$k (keys \%{$h}) { " + . "(\$ok = 0, last) unless $k_check " + . "}; " + . "\$ok " + ."}" + }; +} + +sub __deep_explanation +{ + require B; + my ($type, $value, $varname) = @_; + my ($kparam, $vparam) = @{ $type->parameters }; + + for my $k (sort keys %$value) + { + unless ($kparam->check($k)) + { + return [ + sprintf('"%s" constrains each key in the hash with "%s"', $type, $kparam), + @{ $kparam->validate_explain($k, sprintf('key %s->{%s}', $varname, B::perlstring($k))) }, + ]; + } + + unless ($vparam->check($value->{$k})) + { + return [ + sprintf('"%s" constrains each value in the hash with "%s"', $type, $vparam), + @{ $vparam->validate_explain($value->{$k}, sprintf('%s->{%s}', $varname, B::perlstring($k))) }, + ]; + } + } + + # This should never happen... + return; # uncoverable statement +} + +sub __coercion_generator +{ + my ($parent, $child, $kparam, $vparam) = @_; + return unless $kparam->has_coercion || $vparam->has_coercion; + + my $kcoercable_item = $kparam->has_coercion ? $kparam->coercion->_source_type_union : $kparam; + my $vcoercable_item = $vparam->has_coercion ? $vparam->coercion->_source_type_union : $vparam; + my $C = "Type::Coercion"->new(type_constraint => $child); + + if ((!$kparam->has_coercion or $kparam->coercion->can_be_inlined) + and (!$vparam->has_coercion or $vparam->coercion->can_be_inlined) + and $kcoercable_item->can_be_inlined + and $vcoercable_item->can_be_inlined) + { + $C->add_type_coercions($parent => Types::Standard::Stringable { + my @code; + push @code, 'do { my ($orig, $return_orig, %new) = ($_, 0);'; + push @code, 'for (keys %$orig) {'; + push @code, sprintf('++$return_orig && last unless (%s);', $kcoercable_item->inline_check('$_')); + push @code, sprintf('++$return_orig && last unless (%s);', $vcoercable_item->inline_check('$orig->{$_}')); + push @code, sprintf('$new{(%s)} = (%s);', + $kparam->has_coercion ? $kparam->coercion->inline_coercion('$_') : '$_', + $vparam->has_coercion ? $vparam->coercion->inline_coercion('$orig->{$_}') : '$orig->{$_}', + ); + push @code, '}'; + push @code, '$return_orig ? $orig : \\%new'; + push @code, '}'; + "@code"; + }); + } + else + { + $C->add_type_coercions( + $parent => sub { + my $value = @_ ? $_[0] : $_; + my %new; + for my $k (keys %$value) + { + return $value unless $kcoercable_item->check($k) && $vcoercable_item->check($value->{$k}); + $new{$kparam->has_coercion ? $kparam->coerce($k) : $k} = + $vparam->has_coercion ? $vparam->coerce($value->{$k}) : $value->{$k}; + } + return \%new; + }, + ); + } + + return $C; +} + +sub __hashref_allows_key { + my $self = shift; + my ($key) = @_; + + return Types::Standard::Str()->check($key) if $self==Types::Standard::Map(); + + my $map = $self->find_parent(sub { $_->has_parent && $_->parent==Types::Standard::Map() }); + my ($kcheck, $vcheck) = @{ $map->parameters }; + + ($kcheck or Types::Standard::Any())->check($key); +} + +sub __hashref_allows_value { + my $self = shift; + my ($key, $value) = @_; + + return !!0 unless $self->my_hashref_allows_key($key); + return !!1 if $self==Types::Standard::Map(); + + my $map = $self->find_parent(sub { $_->has_parent && $_->parent==Types::Standard::Map() }); + my ($kcheck, $vcheck) = @{ $map->parameters }; + + ($kcheck or Types::Standard::Any())->check($key) + and ($vcheck or Types::Standard::Any())->check($value); +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Standard::Map - internals for the Types::Standard Map type constraint + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This file contains some of the guts for L. +It will be loaded on demand. You may ignore its presence. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard/ScalarRef.pm @@ -0,0 +1,155 @@ +package Types::Standard::ScalarRef; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Types::Standard::ScalarRef::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::ScalarRef::VERSION = '1.010000'; +} + +$Types::Standard::ScalarRef::VERSION =~ tr/_//d; + +use Types::Standard (); +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +no warnings; + +sub __constraint_generator +{ + return Types::Standard::ScalarRef unless @_; + + my $param = shift; + Types::TypeTiny::TypeTiny->check($param) + or _croak("Parameter to ScalarRef[`a] expected to be a type constraint; got $param"); + + return sub + { + my $ref = shift; + $param->check($$ref) || return; + return !!1; + }; +} + +sub __inline_generator +{ + my $param = shift; + return unless $param->can_be_inlined; + return sub { + my $v = $_[1]; + my $param_check = $param->inline_check("\${$v}"); + "(ref($v) eq 'SCALAR' or ref($v) eq 'REF') and $param_check"; + }; +} + +sub __deep_explanation +{ + my ($type, $value, $varname) = @_; + my $param = $type->parameters->[0]; + + for my $item ($$value) + { + next if $param->check($item); + return [ + sprintf('"%s" constrains the referenced scalar value with "%s"', $type, $param), + @{ $param->validate_explain($item, sprintf('${%s}', $varname)) }, + ]; + } + + # This should never happen... + return; # uncoverable statement +} + +sub __coercion_generator +{ + my ($parent, $child, $param) = @_; + return unless $param->has_coercion; + + my $coercable_item = $param->coercion->_source_type_union; + my $C = "Type::Coercion"->new(type_constraint => $child); + + if ($param->coercion->can_be_inlined and $coercable_item->can_be_inlined) + { + $C->add_type_coercions($parent => Types::Standard::Stringable { + my @code; + push @code, 'do { my ($orig, $return_orig, $new) = ($_, 0);'; + push @code, 'for ($$orig) {'; + push @code, sprintf('++$return_orig && last unless (%s);', $coercable_item->inline_check('$_')); + push @code, sprintf('$new = (%s);', $param->coercion->inline_coercion('$_')); + push @code, '}'; + push @code, '$return_orig ? $orig : \\$new'; + push @code, '}'; + "@code"; + }); + } + else + { + $C->add_type_coercions( + $parent => sub { + my $value = @_ ? $_[0] : $_; + my $new; + for my $item ($$value) + { + return $value unless $coercable_item->check($item); + $new = $param->coerce($item); + } + return \$new; + }, + ); + } + + return $C; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Standard::ScalarRef - internals for the Types::Standard ScalarRef type constraint + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This file contains some of the guts for L. +It will be loaded on demand. You may ignore its presence. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard/StrMatch.pm @@ -0,0 +1,173 @@ +package Types::Standard::StrMatch; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Types::Standard::StrMatch::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::StrMatch::VERSION = '1.010000'; +} + +$Types::Standard::StrMatch::VERSION =~ tr/_//d; + +use Type::Tiny (); +use Types::Standard (); +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +no warnings; + +our %expressions; +my $has_regexp_util; +my $serialize_regexp = sub { + $has_regexp_util = eval { + require Regexp::Util; + Regexp::Util->VERSION('0.003'); + 1; + } || 0 unless defined $has_regexp_util; + + my $re = shift; + my $serialized; + if ($has_regexp_util) { + $serialized = eval { Regexp::Util::serialize_regexp($re) }; + } + + unless (defined $serialized) { + my $key = sprintf('%s|%s', ref($re), $re); + $expressions{$key} = $re; + $serialized = sprintf('$Types::Standard::StrMatch::expressions{%s}', B::perlstring($key)); + } + + return $serialized; +}; + +sub __constraint_generator +{ + return Types::Standard->meta->get_type('StrMatch') unless @_; + + my ($regexp, $checker) = @_; + + Types::Standard::RegexpRef->check($regexp) + or _croak("First parameter to StrMatch[`a] expected to be a Regexp; got $regexp"); + + if (@_ > 1) + { + $checker = Types::TypeTiny::to_TypeTiny($checker); + Types::TypeTiny::TypeTiny->check($checker) + or _croak("Second parameter to StrMatch[`a] expected to be a type constraint; got $checker") + } + + $checker + ? sub { + my $value = shift; + return if ref($value); + my @m = ($value =~ $regexp); + $checker->check(\@m); + } + : sub { + my $value = shift; + !ref($value) and $value =~ $regexp; + } + ; +} + +sub __inline_generator +{ + require B; + my ($regexp, $checker) = @_; + my $serialized_re = $regexp->$serialize_regexp or return; + + if ($checker) + { + return unless $checker->can_be_inlined; + + return sub + { + my $v = $_[1]; + if ($Type::Tiny::AvoidCallbacks and $serialized_re =~ /Types::Standard::StrMatch::expressions/) { + require Carp; + Carp::carp("Cannot serialize regexp without callbacks; serializing using callbacks"); + } + sprintf + "!ref($v) and do { my \$m = [$v =~ %s]; %s }", + $serialized_re, + $checker->inline_check('$m'), + ; + }; + } + else + { + my $regexp_string = "$regexp"; + if ($regexp_string =~ /\A\(\?\^u?:\\A(\.+)\)\z/) { + my $length = length $1; + return sub { "!ref($_) and length($_)>=$length" }; + } + + if ($regexp_string =~ /\A\(\?\^u?:\\A(\.+)\\z\)\z/) { + my $length = length $1; + return sub { "!ref($_) and length($_)==$length" }; + } + + return sub + { + my $v = $_[1]; + if ($Type::Tiny::AvoidCallbacks and $serialized_re =~ /Types::Standard::StrMatch::expressions/) { + require Carp; + Carp::carp("Cannot serialize regexp without callbacks; serializing using callbacks"); + } + "!ref($v) and $v =~ $serialized_re"; + }; + } +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Standard::StrMatch - internals for the Types::Standard StrMatch type constraint + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This file contains some of the guts for L. +It will be loaded on demand. You may ignore its presence. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard/Tied.pm @@ -0,0 +1,112 @@ +package Types::Standard::Tied; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Types::Standard::Tied::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::Tied::VERSION = '1.010000'; +} + +$Types::Standard::Tied::VERSION =~ tr/_//d; + +use Type::Tiny (); +use Types::Standard (); +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +no warnings; + +sub __constraint_generator +{ + return Types::Standard->meta->get_type('Tied') unless @_; + + my $param = Types::TypeTiny::to_TypeTiny(shift); + unless (Types::TypeTiny::TypeTiny->check($param)) + { + Types::TypeTiny::StringLike->check($param) + or _croak("Parameter to Tied[`a] expected to be a class name; got $param"); + require Type::Tiny::Class; + $param = "Type::Tiny::Class"->new(class => "$param"); + } + + my $check = $param->compiled_check; + sub { + $check->(tied(Scalar::Util::reftype($_) eq 'HASH' ? %{$_} : Scalar::Util::reftype($_) eq 'ARRAY' ? @{$_} : Scalar::Util::reftype($_) =~ /^(SCALAR|REF)$/ ? ${$_} : undef)); + }; +} + +sub __inline_generator +{ + my $param = Types::TypeTiny::to_TypeTiny(shift); + unless (Types::TypeTiny::TypeTiny->check($param)) + { + Types::TypeTiny::StringLike->check($param) + or _croak("Parameter to Tied[`a] expected to be a class name; got $param"); + require Type::Tiny::Class; + $param = "Type::Tiny::Class"->new(class => "$param"); + } + return unless $param->can_be_inlined; + + sub { + require B; + my $var = $_[1]; + sprintf( + "%s and do { my \$TIED = tied(Scalar::Util::reftype($var) eq 'HASH' ? \%{$var} : Scalar::Util::reftype($var) eq 'ARRAY' ? \@{$var} : Scalar::Util::reftype($var) =~ /^(SCALAR|REF)\$/ ? \${$var} : undef); %s }", + Types::Standard::Ref()->inline_check($var), + $param->inline_check('$TIED') + ); + } +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Standard::Tied - internals for the Types::Standard Tied type constraint + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This file contains some of the guts for L. +It will be loaded on demand. You may ignore its presence. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/Standard/Tuple.pm @@ -0,0 +1,401 @@ +package Types::Standard::Tuple; + +use 5.006001; +use strict; +use warnings; + +BEGIN { + $Types::Standard::Tuple::AUTHORITY = 'cpan:TOBYINK'; + $Types::Standard::Tuple::VERSION = '1.010000'; +} + +$Types::Standard::Tuple::VERSION =~ tr/_//d; + +use Type::Tiny (); +use Types::Standard (); +use Types::TypeTiny (); + +sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak } + +my $_Optional = Types::Standard::Optional; + +no warnings; + +sub __constraint_generator +{ + my @constraints = @_; + my $slurpy; + if (exists $constraints[-1] and ref $constraints[-1] eq "HASH") + { + $slurpy = Types::TypeTiny::to_TypeTiny($constraints[-1]{slurpy}); + Types::TypeTiny::TypeTiny->check($slurpy) + or _croak("Slurpy parameter to Tuple[...] expected to be a type constraint; got $slurpy"); + pop(@constraints)->{slurpy} = $slurpy; # keep canonicalized version around + } + + for (@constraints) + { + Types::TypeTiny::TypeTiny->check($_) + or _croak("Parameters to Tuple[...] expected to be type constraints; got $_"); + } + + # By god, the Type::Tiny::XS API is currently horrible + my @xsub; + if (Type::Tiny::_USE_XS and !$slurpy) + { + my @known = map { + my $known; + $known = Type::Tiny::XS::is_known($_->compiled_check) + unless $_->is_strictly_a_type_of($_Optional); + defined($known) ? $known : (); + } @constraints; + + if (@known == @constraints) + { + my $xsub = Type::Tiny::XS::get_coderef_for( + sprintf "Tuple[%s]", join(',', @known) + ); + push @xsub, $xsub if $xsub; + } + } + + my @is_optional = map !!$_->is_strictly_a_type_of($_Optional), @constraints; + my $slurp_hash = $slurpy && $slurpy->is_a_type_of(Types::Standard::HashRef); + my $slurp_any = $slurpy && $slurpy->equals(Types::Standard::Any); + + my @sorted_is_optional = sort @is_optional; + join("|", @sorted_is_optional) eq join("|", @is_optional) + or _croak("Optional parameters to Tuple[...] cannot precede required parameters"); + + sub + { + my $value = $_[0]; + if ($#constraints < $#$value) + { + return !!0 unless $slurpy; + my $tmp; + if ($slurp_hash) + { + ($#$value - $#constraints+1) % 2 or return; + $tmp = +{@$value[$#constraints+1 .. $#$value]}; + $slurpy->check($tmp) or return; + } + elsif (not $slurp_any) + { + $tmp = +[@$value[$#constraints+1 .. $#$value]]; + $slurpy->check($tmp) or return; + } + } + for my $i (0 .. $#constraints) + { + ($i > $#$value) + and return !!$is_optional[$i]; + + $constraints[$i]->check($value->[$i]) + or return !!0; + } + return !!1; + }, @xsub; +} + +sub __inline_generator +{ + my @constraints = @_; + my $slurpy; + if (exists $constraints[-1] and ref $constraints[-1] eq "HASH") + { + $slurpy = pop(@constraints)->{slurpy}; + } + + return if grep { not $_->can_be_inlined } @constraints; + return if defined $slurpy && !$slurpy->can_be_inlined; + + my $xsubname; + if (Type::Tiny::_USE_XS and !$slurpy) + { + my @known = map { + my $known; + $known = Type::Tiny::XS::is_known($_->compiled_check) + unless $_->is_strictly_a_type_of($_Optional); + defined($known) ? $known : (); + } @constraints; + + if (@known == @constraints) + { + $xsubname = Type::Tiny::XS::get_subname_for( + sprintf "Tuple[%s]", join(',', @known) + ); + } + } + + my $tmpl = "do { my \$tmp = +[\@{%s}[%d..\$#{%s}]]; %s }"; + my $slurpy_any; + if (defined $slurpy) + { + $tmpl = 'do { my ($orig, $from, $to) = (%s, %d, $#{%s});' + . '($to-$from %% 2) and do { my $tmp = +{@{$orig}[$from..$to]}; %s }' + . '}' + if $slurpy->is_a_type_of(Types::Standard::HashRef); + $slurpy_any = 1 + if $slurpy->equals(Types::Standard::Any); + } + + my @is_optional = map !!$_->is_strictly_a_type_of($_Optional), @constraints; + my $min = 0 + grep !$_, @is_optional; + + return sub + { + my $v = $_[1]; + return "$xsubname\($v\)" if $xsubname && !$Type::Tiny::AvoidCallbacks; + join " and ", + Types::Standard::ArrayRef->inline_check($v), + ( + (scalar @constraints == $min and not $slurpy) + ? "\@{$v} == $min" + : sprintf( + "(\@{$v} == $min or (\@{$v} > $min and \@{$v} <= ${\(1+$#constraints)}) or (\@{$v} > ${\(1+$#constraints)} and %s))", + ( + $slurpy_any + ? '!!1' + : ( + $slurpy + ? sprintf($tmpl, $v, $#constraints+1, $v, $slurpy->inline_check('$tmp')) + : sprintf("\@{$v} <= %d", scalar @constraints) + ) + ), + ) + ), + map { + my $inline = $constraints[$_]->inline_check("$v\->[$_]"); + $inline eq '(!!1)' + ? () + : ( + $is_optional[$_] + ? sprintf('(@{%s} <= %d or %s)', $v, $_, $inline) + : $inline + ); + } 0 .. $#constraints; + }; +} + +sub __deep_explanation +{ + my ($type, $value, $varname) = @_; + + my @constraints = @{ $type->parameters }; + my $slurpy; + if (exists $constraints[-1] and ref $constraints[-1] eq "HASH") + { + $slurpy = Types::TypeTiny::to_TypeTiny(pop(@constraints)->{slurpy}); + } + @constraints = map Types::TypeTiny::to_TypeTiny($_), @constraints; + + if (@constraints < @$value and not $slurpy) + { + return [ + sprintf('"%s" expects at most %d values in the array', $type, scalar(@constraints)), + sprintf('%d values found; too many', scalar(@$value)), + ]; + } + + for my $i (0 .. $#constraints) + { + next if $constraints[$i]->is_strictly_a_type_of( Types::Standard::Optional ) && $i > $#$value; + next if $constraints[$i]->check($value->[$i]); + + return [ + sprintf('"%s" constrains value at index %d of array with "%s"', $type, $i, $constraints[$i]), + @{ $constraints[$i]->validate_explain($value->[$i], sprintf('%s->[%s]', $varname, $i)) }, + ]; + } + + if (defined($slurpy)) + { + my $tmp = $slurpy->is_a_type_of(Types::Standard::HashRef) + ? +{@$value[$#constraints+1 .. $#$value]} + : +[@$value[$#constraints+1 .. $#$value]]; + $slurpy->check($tmp) or return [ + sprintf( + 'Array elements from index %d are slurped into a %s which is constrained with "%s"', + $#constraints+1, + $slurpy->is_a_type_of(Types::Standard::HashRef) ? 'hashref' : 'arrayref', + $slurpy, + ), + @{ $slurpy->validate_explain($tmp, '$SLURPY') }, + ]; + } + + # This should never happen... + return; # uncoverable statement +} + +my $label_counter = 0; +sub __coercion_generator +{ + my ($parent, $child, @tuple) = @_; + + my $slurpy; + if (exists $tuple[-1] and ref $tuple[-1] eq "HASH") + { + $slurpy = pop(@tuple)->{slurpy}; + } + + my $child_coercions_exist = 0; + my $all_inlinable = 1; + for my $tc (@tuple, ($slurpy ? $slurpy : ())) + { + $all_inlinable = 0 if !$tc->can_be_inlined; + $all_inlinable = 0 if $tc->has_coercion && !$tc->coercion->can_be_inlined; + $child_coercions_exist++ if $tc->has_coercion; + } + + return unless $child_coercions_exist; + my $C = "Type::Coercion"->new(type_constraint => $child); + + my $slurpy_is_hashref = $slurpy && $slurpy->is_a_type_of(Types::Standard::HashRef); + + if ($all_inlinable) + { + $C->add_type_coercions($parent => Types::Standard::Stringable { + my $label = sprintf("TUPLELABEL%d", ++$label_counter); + my @code; + push @code, 'do { my ($orig, $return_orig, $tmp, @new) = ($_, 0);'; + push @code, "$label: {"; + push @code, sprintf('(($return_orig = 1), last %s) if @$orig > %d;', $label, scalar @tuple) unless $slurpy; + for my $i (0 .. $#tuple) + { + my $ct = $tuple[$i]; + my $ct_coerce = $ct->has_coercion; + my $ct_optional = $ct->is_a_type_of(Types::Standard::Optional); + + push @code, sprintf( + 'if (@$orig > %d) { $tmp = %s; (%s) ? ($new[%d]=$tmp) : (($return_orig=1), last %s) }', + $i, + $ct_coerce + ? $ct->coercion->inline_coercion("\$orig->[$i]") + : "\$orig->[$i]", + $ct->inline_check('$tmp'), + $i, + $label, + ); + } + if ($slurpy) + { + my $size = @tuple; + push @code, sprintf('if (@$orig > %d) {', $size); + push @code, sprintf( + ($slurpy_is_hashref + ? 'my $tail = do { no warnings; +{ @{$orig}[%d .. $#$orig]} };' + : 'my $tail = [ @{$orig}[%d .. $#$orig] ];'), + $size, + ); + push @code, $slurpy->has_coercion + ? sprintf('$tail = %s;', $slurpy->coercion->inline_coercion('$tail')) + : q(); + push @code, sprintf( + '(%s) ? push(@new, %s$tail) : ($return_orig++);', + $slurpy->inline_check('$tail'), + ($slurpy_is_hashref ? '%' : '@'), + ); + push @code, '}'; + } + push @code, '}'; + push @code, '$return_orig ? $orig : \\@new'; + push @code, '}'; + "@code"; + }); + } + + else + { + my @is_optional = map !!$_->is_strictly_a_type_of($_Optional), @tuple; + + $C->add_type_coercions( + $parent => sub { + my $value = @_ ? $_[0] : $_; + + if (!$slurpy and @$value > @tuple) + { + return $value; + } + + my @new; + for my $i (0 .. $#tuple) + { + return \@new if $i > $#$value and $is_optional[$i]; + + my $ct = $tuple[$i]; + my $x = $ct->has_coercion ? $ct->coerce($value->[$i]) : $value->[$i]; + + return $value unless $ct->check($x); + + $new[$i] = $x; + } + + if ($slurpy and @$value > @tuple) + { + no warnings; + my $tmp = $slurpy_is_hashref + ? { @{$value}[@tuple .. $#$value] } + : [ @{$value}[@tuple .. $#$value] ]; + $tmp = $slurpy->coerce($tmp) if $slurpy->has_coercion; + $slurpy->check($tmp) ? push(@new, $slurpy_is_hashref ? %$tmp : @$tmp) : return($value); + } + + return \@new; + }, + ); + }; + + return $C; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +Types::Standard::Tuple - internals for the Types::Standard Tuple type constraint + +=head1 STATUS + +This module is considered part of Type-Tiny's internals. It is not +covered by the +L. + +=head1 DESCRIPTION + +This file contains some of the guts for L. +It will be loaded on demand. You may ignore its presence. + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. + --- /dev/null +++ b/Kernel/cpan-lib/Types/TypeTiny.pm @@ -0,0 +1,665 @@ +package Types::TypeTiny; + +use strict; +use warnings; + +our $AUTHORITY = 'cpan:TOBYINK'; +our $VERSION = '1.010000'; + +$VERSION =~ tr/_//d; + +use Scalar::Util qw< blessed refaddr weaken >; + +our @EXPORT_OK = ( + map(@{[ $_, "is_$_", "assert_$_" ]}, __PACKAGE__->type_names), + qw/to_TypeTiny/ +); +our %EXPORT_TAGS = ( + types => [ __PACKAGE__->type_names ], + is => [ map "is_$_", __PACKAGE__->type_names ], + assert => [ map "assert_$_", __PACKAGE__->type_names ], +); + +my %cache; + +# This `import` method is designed to avoid loading Exporter::Tiny. +# This is so that if you stick to only using the purely OO parts of +# Type::Tiny, you can skip loading the exporter. +# +sub import +{ + # If this sub succeeds, it will replace itself. + # uncoverable subroutine + return unless @_ > 1; # uncoverable statement + no warnings "redefine"; # uncoverable statement + our @ISA = qw( Exporter::Tiny ); # uncoverable statement + require Exporter::Tiny; # uncoverable statement + my $next = \&Exporter::Tiny::import; # uncoverable statement + *import = $next; # uncoverable statement + my $class = shift; # uncoverable statement + my $opts = { ref($_[0]) ? %{+shift} : () }; # uncoverable statement + $opts->{into} ||= scalar(caller); # uncoverable statement + return $class->$next($opts, @_); # uncoverable statement +} + +for (__PACKAGE__->type_names) { + eval qq{ + sub is_$_ { $_()->check(shift) } + sub assert_$_ { $_()->assert_return(shift) } + }; +} + +sub meta +{ + return $_[0]; +} + +sub type_names +{ + qw( CodeLike StringLike TypeTiny HashLike ArrayLike _ForeignTypeConstraint ); +} + +sub has_type +{ + my %has = map +($_ => 1), shift->type_names; + !!$has{ $_[0] }; +} + +sub get_type +{ + my $self = shift; + return unless $self->has_type(@_); + no strict qw(refs); + &{$_[0]}(); +} + +sub coercion_names +{ + qw(); +} + +sub has_coercion +{ + my %has = map +($_ => 1), shift->coercion_names; + !!$has{ $_[0] }; +} + +sub get_coercion +{ + my $self = shift; + return unless $self->has_coercion(@_); + no strict qw(refs); + &{$_[0]}(); # uncoverable statement +} + +my ($__get_linear_isa_dfs, $tried_mro); +$__get_linear_isa_dfs = sub { + if (!$tried_mro && eval { require mro }) { + $__get_linear_isa_dfs = \&mro::get_linear_isa; + goto $__get_linear_isa_dfs; + } + no strict 'refs'; + my $classname = shift; + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) + { + my $plin = $__get_linear_isa_dfs->($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; +}; + +sub _check_overload +{ + my $package = shift; + if (ref $package) { + $package = blessed($package); + return !!0 if !defined $package; + } + my $op = shift; + my $mro = $__get_linear_isa_dfs->($package); + foreach my $p (@$mro) { + my $fqmeth = $p . q{::(} . $op; + return !!1 if defined &{$fqmeth}; + } + !!0; +} + +sub _get_check_overload_sub { + if ($Type::Tiny::AvoidCallbacks) { + return '(sub { require overload; overload::Overloaded(ref $_[0] or $_[0]) and overload::Method((ref $_[0] or $_[0]), $_[1]) })->' + } + return 'Types::TypeTiny::_check_overload'; +} + +sub StringLike () +{ + require Type::Tiny; + $cache{StringLike} ||= "Type::Tiny"->new( + name => "StringLike", + constraint => sub { defined($_ ) && !ref($_ ) or Scalar::Util::blessed($_ ) && Types::TypeTiny::_check_overload($_ , q[""]) }, + inlined => sub { qq/defined($_[1]) && !ref($_[1]) or Scalar::Util::blessed($_[1]) && ${\ +_get_check_overload_sub() }($_[1], q[""])/ }, + library => __PACKAGE__, + ); +} + +sub HashLike () +{ + require Type::Tiny; + $cache{HashLike} ||= "Type::Tiny"->new( + name => "HashLike", + constraint => sub { ref($_ ) eq q[HASH] or Scalar::Util::blessed($_ ) && Types::TypeTiny::_check_overload($_ , q[%{}]) }, + inlined => sub { qq/ref($_[1]) eq q[HASH] or Scalar::Util::blessed($_[1]) && ${\ +_get_check_overload_sub() }($_[1], q[\%{}])/ }, + library => __PACKAGE__, + ); +} + +sub ArrayLike () +{ + require Type::Tiny; + $cache{ArrayLike} ||= "Type::Tiny"->new( + name => "ArrayLike", + constraint => sub { ref($_ ) eq q[ARRAY] or Scalar::Util::blessed($_ ) && Types::TypeTiny::_check_overload($_ , q[@{}]) }, + inlined => sub { qq/ref($_[1]) eq q[ARRAY] or Scalar::Util::blessed($_[1]) && ${\ +_get_check_overload_sub() }($_[1], q[\@{}])/ }, + library => __PACKAGE__, + ); +} + +sub CodeLike () +{ + require Type::Tiny; + $cache{CodeLike} ||= "Type::Tiny"->new( + name => "CodeLike", + constraint => sub { ref($_ ) eq q[CODE] or Scalar::Util::blessed($_ ) && Types::TypeTiny::_check_overload($_ , q[&{}]) }, + inlined => sub { qq/ref($_[1]) eq q[CODE] or Scalar::Util::blessed($_[1]) && ${\ +_get_check_overload_sub() }($_[1], q[\&{}])/ }, + library => __PACKAGE__, + ); +} + +sub TypeTiny () +{ + require Type::Tiny; + $cache{TypeTiny} ||= "Type::Tiny"->new( + name => "TypeTiny", + constraint => sub { Scalar::Util::blessed($_ ) && $_ ->isa(q[Type::Tiny]) }, + inlined => sub { my $var = $_[1]; "Scalar::Util::blessed($var) && $var\->isa(q[Type::Tiny])" }, + library => __PACKAGE__, + _build_coercion => sub { + my $c = shift; + $c->add_type_coercions(_ForeignTypeConstraint(), \&to_TypeTiny); + $c->freeze; + }, + ); +} + +sub _ForeignTypeConstraint () +{ + require Type::Tiny; + $cache{_ForeignTypeConstraint} ||= "Type::Tiny"->new( + name => "_ForeignTypeConstraint", + constraint => \&_is_ForeignTypeConstraint, + inlined => sub { qq/ref($_[1]) && do { require Types::TypeTiny; Types::TypeTiny::_is_ForeignTypeConstraint($_[1]) }/ }, + library => __PACKAGE__, + ); +} + +my %ttt_cache; + +sub _is_ForeignTypeConstraint +{ + my $t = @_ ? $_[0] : $_; + return !!1 if ref $t eq 'CODE'; + if (my $class = blessed $t) + { + return !!0 if $class->isa("Type::Tiny"); + return !!1 if $class->isa("Moose::Meta::TypeConstraint"); + return !!1 if $class->isa("MooseX::Types::TypeDecorator"); + return !!1 if $class->isa("Validation::Class::Simple"); + return !!1 if $class->isa("Validation::Class"); + return !!1 if $t->can("check") && $t->can("get_message"); + } + !!0; +} + +sub to_TypeTiny +{ + my $t = @_ ? $_[0] : $_; + + return $t unless (my $ref = ref $t); + return $t if $ref =~ /^Type::Tiny\b/; + + return $ttt_cache{ refaddr($t) } if $ttt_cache{ refaddr($t) }; + + if (my $class = blessed $t) + { + return $t if $class->isa("Type::Tiny"); + return _TypeTinyFromMoose($t) if $class eq "MooseX::Types::TypeDecorator"; # needed before MooseX::Types 0.35. + return _TypeTinyFromMoose($t) if $class->isa("Moose::Meta::TypeConstraint"); + return _TypeTinyFromMoose($t) if $class->isa("MooseX::Types::TypeDecorator"); + return _TypeTinyFromMouse($t) if $class->isa("Mouse::Meta::TypeConstraint"); + return _TypeTinyFromValidationClass($t) if $class->isa("Validation::Class::Simple"); + return _TypeTinyFromValidationClass($t) if $class->isa("Validation::Class"); + return _TypeTinyFromGeneric($t) if $t->can("check") && $t->can("get_message"); # i.e. Type::API::Constraint + } + + return _TypeTinyFromCodeRef($t) if $ref eq q(CODE); + + $t; +} + +sub _TypeTinyFromMoose +{ + my $t = $_[0]; + + if (ref $t->{"Types::TypeTiny::to_TypeTiny"}) + { + return $t->{"Types::TypeTiny::to_TypeTiny"}; + } + + if ($t->name ne '__ANON__') + { + require Types::Standard; + my $ts = 'Types::Standard'->get_type($t->name); + return $ts if $ts->{_is_core}; + } + + my ($tt_class, $tt_opts) = + $t->can('parameterize') ? _TypeTinyFromMoose_parameterizable($t) : + $t->isa('Moose::Meta::TypeConstraint::Enum') ? _TypeTinyFromMoose_enum($t) : + $t->isa('Moose::Meta::TypeConstraint::Class') ? _TypeTinyFromMoose_class($t) : + $t->isa('Moose::Meta::TypeConstraint::Role') ? _TypeTinyFromMoose_role($t) : + $t->isa('Moose::Meta::TypeConstraint::Union') ? _TypeTinyFromMoose_union($t) : + $t->isa('Moose::Meta::TypeConstraint::DuckType') ? _TypeTinyFromMoose_ducktype($t) : + _TypeTinyFromMoose_baseclass($t); + + # Standard stuff to do with all type constraints from Moose, + # regardless of variety. + $tt_opts->{moose_type} = $t; + $tt_opts->{display_name} = $t->name; + $tt_opts->{message} = sub { $t->get_message($_) } if $t->has_message; + + my $new = $tt_class->new(%$tt_opts); + $ttt_cache{ refaddr($t) } = $new; + weaken($ttt_cache{ refaddr($t) }); + + $new->{coercion} = do { + require Type::Coercion::FromMoose; + 'Type::Coercion::FromMoose'->new( + type_constraint => $new, + moose_coercion => $t->coercion, + ); + } if $t->has_coercion; + + return $new; +} + +sub _TypeTinyFromMoose_baseclass +{ + my $t = shift; + my %opts; + $opts{parent} = to_TypeTiny($t->parent) if $t->has_parent; + $opts{constraint} = $t->constraint; + $opts{inlined} = sub { shift; $t->_inline_check(@_) } if $t->can("can_be_inlined") && $t->can_be_inlined; + + # Cowardly refuse to inline types that need to close over stuff + if ($opts{inlined}) { + my %env = %{ $t->inline_environment || {} }; + delete($opts{inlined}) if keys %env; + } + + require Type::Tiny; + return 'Type::Tiny' => \%opts; +} + +sub _TypeTinyFromMoose_union +{ + my $t = shift; + require Type::Tiny::Union; + return 'Type::Tiny::Union' => { type_constraints => [ map _TypeTinyFromMoose($_), @{$t->type_constraints} ] }; +} + +sub _TypeTinyFromMoose_enum +{ + my $t = shift; + require Type::Tiny::Enum; + return 'Type::Tiny::Enum' => { values => [@{ $t->values }] }; +} + +sub _TypeTinyFromMoose_class +{ + my $t = shift; + require Type::Tiny::Class; + return 'Type::Tiny::Class' => { class => $t->class }; +} + +sub _TypeTinyFromMoose_role +{ + my $t = shift; + require Type::Tiny::Role; + return 'Type::Tiny::Role' => { role => $t->role }; +} + +sub _TypeTinyFromMoose_ducktype +{ + my $t = shift; + require Type::Tiny::Duck; + return 'Type::Tiny::Duck' => { methods => [@{ $t->methods }] }; +} + +sub _TypeTinyFromMoose_parameterizable +{ + my $t = shift; + my ($class, $opts) = _TypeTinyFromMoose_baseclass($t); + $opts->{constraint_generator} = sub { + # convert args into Moose native types; not strictly necessary + my @args = map { TypeTiny->check($_) ? $_->moose_type : $_ } @_; + _TypeTinyFromMoose( $t->parameterize(@args) ); + }; + return ($class, $opts); +} + +sub _TypeTinyFromValidationClass +{ + my $t = $_[0]; + + require Type::Tiny; + require Types::Standard; + + my %opts = ( + parent => Types::Standard::HashRef(), + _validation_class => $t, + ); + + if ($t->VERSION >= "7.900048") + { + $opts{constraint} = sub { + $t->params->clear; + $t->params->add(%$_); + my $f = $t->filtering; $t->filtering('off'); + my $r = eval { $t->validate }; + $t->filtering($f || 'pre'); + return $r; + }; + $opts{message} = sub { + $t->params->clear; + $t->params->add(%$_); + my $f = $t->filtering; $t->filtering('off'); + my $r = (eval { $t->validate } ? "OK" : $t->errors_to_string); + $t->filtering($f || 'pre'); + return $r; + }; + } + else # need to use hackish method + { + $opts{constraint} = sub { + $t->params->clear; + $t->params->add(%$_); + no warnings "redefine"; + local *Validation::Class::Directive::Filters::execute_filtering = sub { $_[0] }; + eval { $t->validate }; + }; + $opts{message} = sub { + $t->params->clear; + $t->params->add(%$_); + no warnings "redefine"; + local *Validation::Class::Directive::Filters::execute_filtering = sub { $_[0] }; + eval { $t->validate } ? "OK" : $t->errors_to_string; + }; + } + + require Type::Tiny; + my $new = "Type::Tiny"->new(%opts); + + $new->coercion->add_type_coercions( + Types::Standard::HashRef() => sub { + my %params = %$_; + for my $k (keys %params) + { delete $params{$_} unless $t->get_fields($k) }; + $t->params->clear; + $t->params->add(%params); + eval { $t->validate }; + $t->get_hash; + }, + ); + + $ttt_cache{ refaddr($t) } = $new; + weaken($ttt_cache{ refaddr($t) }); + return $new; +} + +sub _TypeTinyFromGeneric +{ + my $t = $_[0]; + + my %opts = ( + constraint => sub { $t->check(@_ ? @_ : $_) }, + message => sub { $t->get_message(@_ ? @_ : $_) }, + ); + + $opts{display_name} = $t->name if $t->can("name"); + + $opts{coercion} = sub { $t->coerce(@_ ? @_ : $_) } + if $t->can("has_coercion") && $t->has_coercion && $t->can("coerce"); + + if ($t->can('can_be_inlined') && $t->can_be_inlined && $t->can('inline_check')) { + $opts{inlined} = sub { $t->inline_check($_[1]) }; + } + + require Type::Tiny; + my $new = "Type::Tiny"->new(%opts); + $ttt_cache{ refaddr($t) } = $new; + weaken($ttt_cache{ refaddr($t) }); + return $new; +} + +sub _TypeTinyFromMouse +{ + my $t = $_[0]; + + my %opts = ( + constraint => sub { $t->check(@_ ? @_ : $_) }, + message => sub { $t->get_message(@_ ? @_ : $_) }, + ); + + $opts{display_name} = $t->name if $t->can("name"); + + $opts{coercion} = sub { $t->coerce(@_ ? @_ : $_) } + if $t->can("has_coercion") && $t->has_coercion && $t->can("coerce"); + + if ($t->{'constraint_generator'}) { + $opts{constraint_generator} = sub { + # convert args into Moose native types; not strictly necessary + my @args = map { TypeTiny->check($_) ? $_->mouse_type : $_ } @_; + _TypeTinyFromMouse( $t->parameterize(@args) ); + }; + } + + require Type::Tiny; + my $new = "Type::Tiny"->new(%opts); + $ttt_cache{ refaddr($t) } = $new; + weaken($ttt_cache{ refaddr($t) }); + return $new; +} + +my $QFS; +sub _TypeTinyFromCodeRef +{ + my $t = $_[0]; + + my %opts = ( + constraint => sub { + return !!eval { $t->($_) }; + }, + message => sub { + local $@; + eval { $t->($_); 1 } or do { chomp $@; return $@ if $@ }; + return sprintf('%s did not pass type constraint', Type::Tiny::_dd($_)); + }, + ); + + if ($QFS ||= "Sub::Quote"->can("quoted_from_sub")) + { + my (undef, $perlstring, $captures) = @{ $QFS->($t) || [] }; + if ($perlstring) + { + $perlstring = "!!eval{ $perlstring }"; + $opts{inlined} = sub + { + my $var = $_[1]; + Sub::Quote::inlinify( + $perlstring, + $var, + $var eq q($_) ? '' : "local \$_ = $var;", + 1, + ); + } if $perlstring && !$captures; + } + } + + require Type::Tiny; + my $new = "Type::Tiny"->new(%opts); + $ttt_cache{ refaddr($t) } = $new; + weaken($ttt_cache{ refaddr($t) }); + return $new; +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=for stopwords arrayfication hashification + +=head1 NAME + +Types::TypeTiny - type constraints used internally by Type::Tiny + +=head1 STATUS + +This module is covered by the +L. + +=head1 DESCRIPTION + +Dogfooding. + +This isn't a real Type::Library-based type library; that would involve +too much circularity. But it exports some type constraints which, while +designed for use within Type::Tiny, may be more generally useful. + +=head2 Types + +=over + +=item C<< StringLike >> + +Accepts strings and objects overloading stringification. + +=item C<< HashLike >> + +Accepts hashrefs and objects overloading hashification. + +=item C<< ArrayLike >> + +Accepts arrayrefs and objects overloading arrayfication. + +=item C<< CodeLike >> + +Accepts coderefs and objects overloading codification. + +=item C<< TypeTiny >> + +Accepts blessed L objects. + +=item C<< _ForeignTypeConstraint >> + +Any reference which to_TypeTiny recognizes as something that can be coerced +to a Type::Tiny object. + +Yeah, the underscore is included. + +=back + +=head2 Coercion Functions + +=over + +=item C<< to_TypeTiny($constraint) >> + +Promotes (or "demotes" if you prefer) a Moose::Meta::TypeConstraint object +to a Type::Tiny object. + +Can also handle L objects. Type constraints built from +Validation::Class objects deliberately I field filters when they +do constraint checking (and go to great lengths to do so); using filters for +coercion only. (The behaviour of C if we don't do that is just too +weird!) + +Can also handle any object providing C and C methods. +(This includes L objects.) If the object also +provides C and C methods, these will be used too. + +Can also handle coderefs (but not blessed coderefs or objects overloading +C<< &{} >>). Coderefs are expected to return true iff C<< $_ >> passes the +constraint. If C<< $_ >> fails the type constraint, they may either return +false, or die with a helpful error message. + +=back + +=head2 Methods + +These are implemented so that C<< Types::TypeTiny->meta->get_type($foo) >> +works, for rough compatibility with a real L type library. + +=over + +=item C<< meta >> + +=item C<< type_names >> + +=item C<< get_type($name) >> + +=item C<< has_type($name) >> + +=item C<< coercion_names >> + +=item C<< get_coercion($name) >> + +=item C<< has_coercion($name) >> + +=back + +=head1 BUGS + +Please report any bugs to +L. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Toby Inkster Etobyink@cpan.orgE. + +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2013-2014, 2017-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. +