use warnings;
use Carp ();
+use List::MoreUtils qw( all );
use Scalar::Util 'blessed';
use Moose::Exporter;
-our $VERSION = '0.57';
+our $VERSION = '0.65';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
# ensures the prototypes are in scope when consumers are
# compiled.
-# creation and location
-sub find_type_constraint ($);
-sub register_type_constraint ($);
-sub find_or_create_type_constraint ($;$);
-sub find_or_parse_type_constraint ($);
-sub find_or_create_isa_type_constraint ($);
-sub find_or_create_does_type_constraint ($);
-sub create_type_constraint_union (@);
-sub create_parameterized_type_constraint ($);
-sub create_class_type_constraint ($;$);
-sub create_role_type_constraint ($;$);
-sub create_enum_type_constraint ($$);
-
# dah sugah!
-sub type ($$;$$);
-sub subtype ($$;$$$);
-sub class_type ($;$);
-sub coerce ($@);
-sub as ($);
-sub from ($);
sub where (&);
sub via (&);
sub message (&);
sub optimize_as (&);
-sub enum ($;@);
## private stuff ...
sub _create_type_constraint ($$$;$$);
Moose::Exporter->setup_import_methods(
as_is => [
qw(
- type subtype class_type role_type as where message optimize_as
+ type subtype class_type role_type maybe_type
+ as where message optimize_as
coerce from via
enum
find_type_constraint
}
}
-sub create_type_constraint_union (@) {
+sub create_type_constraint_union {
my @type_constraint_names;
if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
(scalar @type_constraint_names >= 2)
|| Moose->throw_error("You must pass in at least 2 type names to make a union");
- my @type_constraints = sort {$a->name cmp $b->name} map {
+ my @type_constraints = map {
find_or_parse_type_constraint($_) ||
Moose->throw_error("Could not locate type constraint ($_) for the union");
} @type_constraint_names;
-
+
return Moose::Meta::TypeConstraint::Union->new(
type_constraints => \@type_constraints
);
}
-sub create_parameterized_type_constraint ($) {
+sub create_parameterized_type_constraint {
my $type_constraint_name = shift;
my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
return _create_parameterized_type_constraint(
$base_type_tc,
- $type_parameter,
+ $type_parameter
);
} else {
Moose->throw_error("Could not locate the base type ($base_type)");
sub _create_parameterized_type_constraint {
my ( $base_type_tc, $type_parameter ) = @_;
if ( $base_type_tc->can('parameterize') ) {
- my @type_parameters_tc
- = $base_type_tc->parse_type_parameter($type_parameter);
- return $base_type_tc->parameterize(@type_parameters_tc);
- }
- else {
+ return $base_type_tc->parameterize($type_parameter);
+ } else {
return Moose::Meta::TypeConstraint::Parameterized->new(
- name => $base_type_tc->name . '[' . $type_parameter . ']',
+ name => $base_type_tc->name . '[' . $type_parameter . ']',
parent => $base_type_tc,
- type_parameter =>
- find_or_create_isa_type_constraint($type_parameter),
+ type_parameter => find_or_create_isa_type_constraint($type_parameter),
);
}
-}
+}
#should we also support optimized checks?
-sub create_class_type_constraint ($;$) {
+sub create_class_type_constraint {
my ( $class, $options ) = @_;
# too early for this check
Moose::Meta::TypeConstraint::Class->new( %options );
}
-sub create_role_type_constraint ($;$) {
+sub create_role_type_constraint {
my ( $role, $options ) = @_;
# too early for this check
}
-sub find_or_create_type_constraint ($;$) {
+sub find_or_create_type_constraint {
my ( $type_constraint_name, $options_for_anon_type ) = @_;
if ( my $constraint = find_or_parse_type_constraint($type_constraint_name) ) {
return;
}
-sub find_or_create_isa_type_constraint ($) {
+sub find_or_create_isa_type_constraint {
my $type_constraint_name = shift;
find_or_parse_type_constraint($type_constraint_name) || create_class_type_constraint($type_constraint_name)
}
-sub find_or_create_does_type_constraint ($) {
+sub find_or_create_does_type_constraint {
my $type_constraint_name = shift;
find_or_parse_type_constraint($type_constraint_name) || create_role_type_constraint($type_constraint_name)
}
-sub find_or_parse_type_constraint ($) {
+sub find_or_parse_type_constraint {
my $type_constraint_name = normalize_type_constraint_name(shift);
my $constraint;
}
sub normalize_type_constraint_name {
- my $type_constraint_name = shift @_;
- $type_constraint_name =~s/\s//g;
+ my $type_constraint_name = shift;
+ $type_constraint_name =~ s/\s//g;
return $type_constraint_name;
}
+sub _confess {
+ my $error = shift;
+
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ Carp::confess($error);
+}
+
## --------------------------------------------------------
## exported functions ...
## --------------------------------------------------------
-sub find_type_constraint ($) {
+sub find_type_constraint {
my $type = shift;
if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
}
}
-sub register_type_constraint ($) {
+sub register_type_constraint {
my $constraint = shift;
Moose->throw_error("can't register an unnamed type constraint") unless defined $constraint->name;
$REGISTRY->add_type_constraint($constraint);
# type constructors
-sub type ($$;$$) {
+sub type {
splice(@_, 1, 0, undef);
goto &_create_type_constraint;
}
-sub subtype ($$;$$$) {
+sub subtype {
# NOTE:
# this adds an undef for the name
# if this is an anon-subtype:
# subtype(Num => where { $_ % 2 == 0 }) # anon 'even' subtype
- # but if the last arg is not a code
- # ref then it is a subtype alias:
+ # or
+ # subtype(Num => where { $_ % 2 == 0 }) message { "$_ must be an even number" }
+ #
+ # but if the last arg is not a code ref then it is a subtype
+ # alias:
+ #
# subtype(MyNumbers => as Num); # now MyNumbers is the same as Num
# ... yeah I know it's ugly code
# - SL
- unshift @_ => undef if scalar @_ <= 2 && ('CODE' eq ref($_[1]));
+ unshift @_ => undef if scalar @_ == 2 && ( 'CODE' eq ref( $_[-1] ) );
+ unshift @_ => undef
+ if scalar @_ == 3 && all { ref($_) =~ /^(?:CODE|HASH)$/ } @_[ 1, 2 ];
goto &_create_type_constraint;
}
-sub class_type ($;$) {
+sub class_type {
register_type_constraint(
create_class_type_constraint(
$_[0],
);
}
-sub coerce ($@) {
+sub maybe_type {
+ my ($type_parameter) = @_;
+
+ register_type_constraint(
+ $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter)
+ );
+}
+
+sub coerce {
my ($type_name, @coercion_map) = @_;
_install_type_coercions($type_name, \@coercion_map);
}
-sub as ($) { $_[0] }
-sub from ($) { $_[0] }
+sub as { @_ }
+sub from { @_ }
sub where (&) { $_[0] }
sub via (&) { $_[0] }
sub message (&) { +{ message => $_[0] } }
sub optimize_as (&) { +{ optimized => $_[0] } }
-sub enum ($;@) {
+sub enum {
my ($type_name, @values) = @_;
# NOTE:
# if only an array-ref is passed then
);
}
-sub create_enum_type_constraint ($$) {
+sub create_enum_type_constraint {
my ( $type_name, $values ) = @_;
Moose::Meta::TypeConstraint::Enum->new(
my $parent = shift;
my $check = shift;
- my ($message, $optimized);
+ my ( $message, $optimized );
for (@_) {
$message = $_->{message} if exists $_->{message};
$optimized = $_->{optimized} if exists $_->{optimized};
}
- my $pkg_defined_in = scalar(caller(0));
+ my $pkg_defined_in = scalar( caller(0) );
- if (defined $name) {
+ if ( defined $name ) {
my $type = $REGISTRY->get_type_constraint($name);
- ($type->_package_defined_in eq $pkg_defined_in)
- || confess ("The type constraint '$name' has already been created in "
- . $type->_package_defined_in . " and cannot be created again in "
- . $pkg_defined_in)
- if defined $type;
- }
-
- my $class = "Moose::Meta::TypeConstraint";
-
- # FIXME should probably not be a special case
- if ( defined $parent and $parent = find_or_parse_type_constraint($parent) ) {
- $class = "Moose::Meta::TypeConstraint::Parameterizable"
- if $parent->isa("Moose::Meta::TypeConstraint::Parameterizable");
+ ( $type->_package_defined_in eq $pkg_defined_in )
+ || _confess(
+ "The type constraint '$name' has already been created in "
+ . $type->_package_defined_in
+ . " and cannot be created again in "
+ . $pkg_defined_in )
+ if defined $type;
}
- my $constraint = $class->new(
- name => $name || '__ANON__',
+ my %opts = (
+ name => $name,
package_defined_in => $pkg_defined_in,
- ($parent ? (parent => $parent ) : ()),
- ($check ? (constraint => $check) : ()),
- ($message ? (message => $message) : ()),
- ($optimized ? (optimized => $optimized) : ()),
+ ( $check ? ( constraint => $check ) : () ),
+ ( $message ? ( message => $message ) : () ),
+ ( $optimized ? ( optimized => $optimized ) : () ),
);
- # NOTE:
- # if we have a type constraint union, and no
- # type check, this means we are just aliasing
- # the union constraint, which means we need to
- # handle this differently.
- # - SL
- if (not(defined $check)
- && $parent->isa('Moose::Meta::TypeConstraint::Union')
- && $parent->has_coercion
- ){
- $constraint->coercion(Moose::Meta::TypeCoercion::Union->new(
- type_constraint => $parent
- ));
+ my $constraint;
+ if ( defined $parent
+ and $parent
+ = blessed $parent ? $parent : find_or_parse_type_constraint($parent) )
+ {
+ $constraint = $parent->create_child_type(%opts);
+ }
+ else {
+ $constraint = Moose::Meta::TypeConstraint->new(%opts);
}
$REGISTRY->add_type_constraint($constraint)
my $any;
- my $type = qr{ $valid_chars+ (?: \[ \s* (??{$any}) \s* \] )? }x;
+ my $type = qr{ $valid_chars+ (?: \[ \s* (??{$any}) \s* \] )? }x;
my $type_capture_parts = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
- my $type_with_parameter = qr{ $valid_chars+ \[ \s* (??{$any}) \s* \] }x;
+ my $type_with_parameter = qr{ $valid_chars+ \[ \s* (??{$any}) \s* \] }x;
my $op_union = qr{ \s* \| \s* }x;
my $union = qr{ $type (?: $op_union $type )+ }x;
- ## New Stuff for structured types.
- my $comma = qr{,};
- my $indirection = qr{=>};
- my $divider_ops = qr{ $comma | $indirection }x;
- my $structure_divider = qr{\s* $divider_ops \s*}x;
- my $structure_elements = qr{ ($type $structure_divider*)+ }x;
-
- $any = qr{ $type | $union | $structure_elements }x;
+ $any = qr{ $type | $union }x;
sub _parse_parameterized_type_constraint {
{ no warnings 'void'; $any; } # force capture of interpolated lexical
- my($base, $elements) = ($_[0] =~ m{ $type_capture_parts }x);
- return ($base,$elements);
+ $_[0] =~ m{ $type_capture_parts }x;
+ return ($1, $2);
}
sub _detect_parameterized_type_constraint {
# define some basic built-in types
## --------------------------------------------------------
+# By making these classes immutable before creating all the types we
+# below, we avoid repeatedly calling the slow MOP-based accessors.
+$_->make_immutable(
+ inline_constructor => 1,
+ constructor_name => "_new",
+
+ # these are Class::MOP accessors, so they need inlining
+ inline_accessors => 1
+ ) for grep { $_->is_mutable }
+ map { $_->meta }
+ qw(
+ Moose::Meta::TypeConstraint
+ Moose::Meta::TypeConstraint::Union
+ Moose::Meta::TypeConstraint::Parameterized
+ Moose::Meta::TypeConstraint::Parameterizable
+ Moose::Meta::TypeConstraint::Class
+ Moose::Meta::TypeConstraint::Role
+ Moose::Meta::TypeConstraint::Enum
+ Moose::Meta::TypeConstraint::Registry
+);
+
type 'Any' => where { 1 }; # meta-type including all
type 'Item' => where { 1 }; # base-type
B<NOTE:> Any type followed by a type parameter C<[`a]> can be
parameterized, this means you can say:
- ArrayRef[Int] # an array of intergers
+ ArrayRef[Int] # an array of integers
HashRef[CodeRef] # a hash of str to CODE ref mappings
Maybe[Str] # value may be a string, may be undefined
Creates a type constraint with the name C<$role> and the metaclass
L<Moose::Meta::TypeConstraint::Role>.
+=item B<maybe_type ($type)>
+
+Creates a type constraint for either C<undef> or something of the
+given type.
+
=item B<enum ($name, @values)>
This will create a basic subtype for a given set of strings.
=item B<find_or_create_does_type_constraint ($type_name)>
-Attempts to parse the type name using L<find_or_parse_type_constraint> and if
+Attempts to parse the type name using C<find_or_parse_type_constraint> and if
no appropriate constraint is found will create a new anonymous one.
The C<isa> variant will use C<create_class_type_constraint> and the C<does>
=back
-=head1 Error Management
-
-=over 4
-
-=item B<confess>
-
-If the caller is a Moose metaclass, use its L<Moose::Meta::Class/throw_error>
-routine, otherwise use L<Carp/confess>.
-
-=back
-
=head2 Namespace Management
=over 4
projects / gitmo/Moose.git / blobdiff