/usr/share/perl5/MooseX/Meta/TypeConstraint/Structured.pm is in libmoosex-types-structured-perl 0.30-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | package ## Hide from PAUSE
MooseX::Meta::TypeConstraint::Structured;
# ABSTRACT: Structured type constraints.
use Moose;
use Devel::PartialDump;
use Moose::Util::TypeConstraints ();
use MooseX::Meta::TypeCoercion::Structured;
extends 'Moose::Meta::TypeConstraint';
has 'type_constraints' => (
is=>'ro',
isa=>'Ref',
predicate=>'has_type_constraints',
);
has 'constraint_generator' => (
is=>'ro',
isa=>'CodeRef',
predicate=>'has_constraint_generator',
);
has coercion => (
is => 'ro',
isa => 'Object',
builder => '_build_coercion',
);
sub _build_coercion {
my ($self) = @_;
return MooseX::Meta::TypeCoercion::Structured->new(
type_constraint => $self,
);
}
sub _clean_message {
my $message = shift @_;
$message =~s/MooseX::Types::Structured:://g;
return $message;
}
override 'validate' => sub {
my ($self, $value, $message_stack) = @_;
unless ($message_stack) {
$message_stack = MooseX::Types::Structured::MessageStack->new();
}
$message_stack->inc_level;
if ($self->_compiled_type_constraint->($value, $message_stack)) {
## Everything is good, no error message to return
return undef;
} else {
## Whoops, need to figure out the right error message
my $args = Devel::PartialDump::dump($value);
$message_stack->dec_level;
if($message_stack->has_messages) {
if($message_stack->level) {
## we are inside a deeply structured constraint
return $self->get_message($args);
} else {
my $message_str = $message_stack->as_string;
return _clean_message($self->get_message("$args, Internal Validation Error is: $message_str"));
}
} else {
return $self->get_message($args);
}
}
};
sub generate_constraint_for {
my ($self, $type_constraints) = @_;
return $self->constraint_generator->($self, $type_constraints);
}
sub parameterize {
my ($self, @type_constraints) = @_;
my $class = ref $self;
my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
my $constraint_generator = $self->__infer_constraint_generator;
return $class->new(
name => $name,
parent => $self,
type_constraints => \@type_constraints,
constraint_generator => $constraint_generator,
);
}
sub __infer_constraint_generator {
my ($self) = @_;
if($self->has_constraint_generator) {
return $self->constraint_generator;
} else {
return sub {
## I'm not sure about this stuff but everything seems to work
my $tc = shift @_;
my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
$self->constraint->($merged_tc, @_);
};
}
}
around 'compile_type_constraint' => sub {
my ($compile_type_constraint, $self, @args) = @_;
if($self->has_type_constraints) {
my $type_constraints = $self->type_constraints;
my $constraint = $self->generate_constraint_for($type_constraints);
$self->_set_constraint($constraint);
}
return $self->$compile_type_constraint(@args);
};
around 'create_child_type' => sub {
my ($create_child_type, $self, %opts) = @_;
return $self->$create_child_type(
%opts,
constraint_generator => $self->__infer_constraint_generator,
);
};
sub equals {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
or return;
return unless $other->isa(__PACKAGE__);
return (
$self->parent->equals($other->parent)
and
$self->type_constraints_equals($other)
);
}
sub is_a_type_of {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
or return;
if ( $other->isa(__PACKAGE__) and @{ $other->type_constraints || [] }) {
if ( $self->parent->is_a_type_of($other->parent) ) {
return $self->_type_constraints_op_all($other, "is_a_type_of");
} elsif ( $self->parent->is_a_type_of($other) ) {
return 1;
# FIXME compare?
} else {
return 0;
}
} else {
return $self->SUPER::is_a_type_of($other);
}
}
sub is_subtype_of {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
or return;
if ( $other->isa(__PACKAGE__) ) {
if ( $other->type_constraints and $self->type_constraints ) {
if ( $self->parent->is_a_type_of($other->parent) ) {
return (
$self->_type_constraints_op_all($other, "is_a_type_of")
and
$self->_type_constraints_op_any($other, "is_subtype_of")
);
} elsif ( $self->parent->is_a_type_of($other) ) {
return 1;
# FIXME compare?
} else {
return 0;
}
} else {
if ( $self->type_constraints ) {
if ( $self->SUPER::is_subtype_of($other) ) {
return 1;
} else {
return;
}
} else {
return $self->parent->is_subtype_of($other->parent);
}
}
} else {
return $self->SUPER::is_subtype_of($other);
}
}
sub type_constraints_equals {
my ( $self, $other ) = @_;
$self->_type_constraints_op_all($other, "equals");
}
sub _type_constraints_op_all {
my ($self, $other, $op) = @_;
return unless $other->isa(__PACKAGE__);
my @self_type_constraints = @{$self->type_constraints||[]};
my @other_type_constraints = @{$other->type_constraints||[]};
return unless @self_type_constraints == @other_type_constraints;
## Incoming ay be either arrayref or hashref, need top compare both
while(@self_type_constraints) {
my $self_type_constraint = shift @self_type_constraints;
my $other_type_constraint = shift @other_type_constraints;
$_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
for $self_type_constraint, $other_type_constraint;
my $result = $self_type_constraint->$op($other_type_constraint);
return unless $result;
}
return 1; ##If we get this far, everything is good.
}
sub _type_constraints_op_any {
my ($self, $other, $op) = @_;
return unless $other->isa(__PACKAGE__);
my @self_type_constraints = @{$self->type_constraints||[]};
my @other_type_constraints = @{$other->type_constraints||[]};
return unless @self_type_constraints == @other_type_constraints;
## Incoming ay be either arrayref or hashref, need top compare both
while(@self_type_constraints) {
my $self_type_constraint = shift @self_type_constraints;
my $other_type_constraint = shift @other_type_constraints;
$_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
for $self_type_constraint, $other_type_constraint;
return 1 if $self_type_constraint->$op($other_type_constraint);
}
return 0;
}
around 'get_message' => sub {
my ($get_message, $self, $value) = @_;
$value = Devel::PartialDump::dump($value)
if ref $value;
return $self->$get_message($value);
};
__PACKAGE__->meta->make_immutable(inline_constructor => 0);
__END__
=pod
=encoding UTF-8
=for :stopwords John Napiorkowski Florian Ragwitz יובל קוג'מן (Yuval Kogman) Tomas (t0m)
Doran Robert Sedlacek subref parameterize servicable
=head1 NAME
MooseX::Meta::TypeConstraint::Structured - Structured type constraints.
=head1 VERSION
version 0.30
=head1 DESCRIPTION
A structure is a set of L<Moose::Meta::TypeConstraint> that are 'aggregated' in
such a way as that they are all applied to an incoming list of arguments. The
idea here is that a Type Constraint could be something like, "An C<Int> followed by
an C<Int> and then a C<Str>" and that this could be done so with a declaration like:
Tuple[Int,Int,Str]; ## Example syntax
So a structure is a list of type constraints (the C<Int,Int,Str> in the above
example) which are intended to function together.
=head1 ATTRIBUTES
=head2 type_constraints
A list of L<Moose::Meta::TypeConstraint> objects.
=head2 constraint_generator
=head1 METHODS
=head2 validate
Messing with validate so that we can support nicer error messages.
=head2 generate_constraint_for ($type_constraints)
Given some type constraints, use them to generate validation rules for an ref
of values (to be passed at check time)
=head2 parameterize (@type_constraints)
Given a ref of type constraints, create a structured type.
=head2 __infer_constraint_generator
=head2 compile_type_constraint
hook into compile_type_constraint so we can set the correct validation rules.
=head2 create_child_type
modifier to make sure we get the constraint_generator
=head2 is_a_type_of
=head2 is_subtype_of
=head2 equals
Override the base class behavior.
=head2 type_constraints_equals
Checks to see if the internal type constraints are equal.
=head2 get_message
Give you a better peek into what's causing the error. For now we stringify the
incoming deep value with L<Devel::PartialDump> and pass that on to either your
custom error message or the default one. In the future we'll try to provide a
more complete stack trace of the actual offending elements
A subref or closure that contains the way we validate incoming values against
a set of type constraints.
This returns a CODEREF which generates a suitable constraint generator. Not
user servicable, you'll never call this directly.
=head1 SEE ALSO
The following modules or resources may be of interest.
L<Moose>, L<Moose::Meta::TypeConstraint>
=head1 AUTHORS
=over 4
=item *
John Napiorkowski <jjnapiork@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Tomas (t0m) Doran <bobtfish@bobtfish.net>
=item *
Robert Sedlacek <rs@474.at>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by John Napiorkowski.
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
|