Linux cpanel.rrshost.in 5.15.0-25-generic #25-Ubuntu SMP Wed Mar 30 15:54:22 UTC 2022 x86_64
Apache
: 109.123.238.221 | : 172.70.127.197
128 Domain
8.2.28
aev999
Terminal
AUTO ROOT
Adminer
Backdoor Destroyer
Linux Exploit
Lock Shell
Lock File
Create User
CREATE RDP
PHP Mailer
BACKCONNECT
HASH IDENTIFIER
README
+ Create Folder
+ Create File
/
usr /
share /
perl5 /
Type /
Tiny /
[ HOME SHELL ]
Name
Size
Permission
Action
Manual
[ DIR ]
drwxr-xr-x
Class.pm
8.38
KB
-rw-r--r--
ConstrainedObject.pm
6.14
KB
-rw-r--r--
Duck.pm
5.54
KB
-rw-r--r--
Enum.pm
11.79
KB
-rw-r--r--
Intersection.pm
7.27
KB
-rw-r--r--
Manual.pod
6.28
KB
-rw-r--r--
Role.pm
4.28
KB
-rw-r--r--
Union.pm
10.87
KB
-rw-r--r--
_HalfOp.pm
1.73
KB
-rw-r--r--
Delete
Unzip
Zip
${this.title}
Close
Code Editor : ConstrainedObject.pm
package Type::Tiny::ConstrainedObject; use 5.006001; use strict; use warnings; BEGIN { $Type::Tiny::ConstrainedObject::AUTHORITY = 'cpan:TOBYINK'; $Type::Tiny::ConstrainedObject::VERSION = '1.012004'; } $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 new sub has_parent { !!1; } sub parent { require Types::Standard; Types::Standard::Object(); } sub _short_name { die "subclasses must implement this"; # uncoverable statement } 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 ); } } #/ else [ if ( !ref $constraint )] } #/ while ( @_ ) 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 ); } #/ if ( keys %env ) 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<Type::Tiny::Class>, L<Type::Tiny::Role>, L<Type::Tiny::Duck>, and any type constraints that inherit from C<Object> or C<Overload> in L<Types::Standard>. These methods will also work for L<Type::Tiny::Intersection> if at least one of the types in the intersection provides these methods. These methods will also work for L<Type::Tiny::Union> 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<stringifies_to> 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<https://github.com/tobyink/p5-type-tiny/issues>. =head1 SEE ALSO L<Type::Tiny::Manual>. L<Type::Tiny>. =head1 AUTHOR Toby Inkster E<lt>tobyink@cpan.orgE<gt>. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2019-2021 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.
Close
