use warnings;
use Carp 'confess';
-use Scalar::Util 'blessed';
+use Scalar::Util 'blessed', 'reftype';
use B 'svref_2object';
use Sub::Exporter;
-our $VERSION = '0.12';
+our $VERSION = '0.15';
our $AUTHORITY = 'cpan:STEVAN';
+## --------------------------------------------------------
+# Prototyped subs must be predeclared because we have a
+# circular dependency with Moose::Meta::Attribute et. al.
+# so in case of us being use'd first the predeclaration
+# ensures the prototypes are in scope when consumers are
+# compiled.
+
+# creation and location
+sub find_type_constraint ($);
+sub find_or_create_type_constraint ($;$);
+sub create_type_constraint_union (@);
+sub create_parameterized_type_constraint ($);
+
+# dah sugah!
+sub type ($$;$$);
+sub subtype ($$;$$$);
+sub coerce ($@);
+sub as ($);
+sub from ($);
+sub where (&);
+sub via (&);
+sub message (&);
+sub optimize_as (&);
+sub enum ($;@);
+
+## private stuff ...
+sub _create_type_constraint ($$$;$$);
+sub _install_type_coercions ($$);
+
+## --------------------------------------------------------
+
use Moose::Meta::TypeConstraint;
+use Moose::Meta::TypeConstraint::Union;
+use Moose::Meta::TypeConstraint::Parameterized;
use Moose::Meta::TypeCoercion;
+use Moose::Meta::TypeCoercion::Union;
+use Moose::Meta::TypeConstraint::Registry;
my @exports = qw/
type subtype as where message optimize_as
}
}
-{
- my %TYPES;
- sub find_type_constraint ($) {
- return $TYPES{$_[0]}->[1]
- if exists $TYPES{$_[0]};
- return;
- }
+## --------------------------------------------------------
+## type registry and some useful functions for it
+## --------------------------------------------------------
+
+my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new;
+
+sub get_type_constraint_registry { $REGISTRY }
+sub list_all_type_constraints { keys %{$REGISTRY->type_constraints} }
+sub export_type_constraints_as_functions {
+ my $pkg = caller();
+ no strict 'refs';
+ foreach my $constraint (keys %{$REGISTRY->type_constraints}) {
+ *{"${pkg}::${constraint}"} = $REGISTRY->get_type_constraint($constraint)
+ ->_compiled_type_constraint;
+ }
+}
+
+sub create_type_constraint_union (@) {
+ my @type_constraint_names;
- sub _dump_type_constraints {
- require Data::Dumper;
- Data::Dumper::Dumper(\%TYPES);
+ if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
+ @type_constraint_names = _parse_type_constraint_union($_[0]);
+ }
+ else {
+ @type_constraint_names = @_;
}
- sub _create_type_constraint ($$$;$$) {
- my $name = shift;
- my $parent = shift;
- my $check = shift;;
+ (scalar @type_constraint_names >= 2)
+ || confess "You must pass in at least 2 type names to make a union";
- my ($message, $optimized);
- for (@_) {
- $message = $_->{message} if exists $_->{message};
- $optimized = $_->{optimized} if exists $_->{optimized};
- }
+ ($REGISTRY->has_type_constraint($_))
+ || confess "Could not locate type constraint ($_) for the union"
+ foreach @type_constraint_names;
+
+ return Moose::Meta::TypeConstraint::Union->new(
+ type_constraints => [
+ map {
+ $REGISTRY->get_type_constraint($_)
+ } @type_constraint_names
+ ],
+ );
+}
- my $pkg_defined_in = scalar(caller(1));
- ($TYPES{$name}->[0] eq $pkg_defined_in)
- || confess "The type constraint '$name' has already been created "
- if defined $name && exists $TYPES{$name};
- $parent = find_type_constraint($parent) if defined $parent;
- my $constraint = Moose::Meta::TypeConstraint->new(
- name => $name || '__ANON__',
- parent => $parent,
- constraint => $check,
- message => $message,
- optimized => $optimized,
- );
- $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name;
- return $constraint;
- }
+sub create_parameterized_type_constraint ($) {
+ my $type_constraint_name = shift;
+
+ my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
+
+ (defined $base_type && defined $type_parameter)
+ || confess "Could not parse type name ($type_constraint_name) correctly";
+
+ ($REGISTRY->has_type_constraint($base_type))
+ || confess "Could not locate the base type ($base_type)";
+
+ return Moose::Meta::TypeConstraint::Parameterized->new(
+ name => $type_constraint_name,
+ parent => $REGISTRY->get_type_constraint($base_type),
+ type_parameter => find_or_create_type_constraint(
+ $type_parameter => {
+ parent => $REGISTRY->get_type_constraint('Object'),
+ constraint => sub { $_[0]->isa($type_parameter) }
+ }
+ ),
+ );
+}
- sub _install_type_coercions ($$) {
- my ($type_name, $coercion_map) = @_;
- my $type = find_type_constraint($type_name);
- (!$type->has_coercion)
- || confess "The type coercion for '$type_name' has already been registered";
- my $type_coercion = Moose::Meta::TypeCoercion->new(
- type_coercion_map => $coercion_map,
- type_constraint => $type
- );
- $type->coercion($type_coercion);
- }
+sub find_or_create_type_constraint ($;$) {
+ my ($type_constraint_name, $options_for_anon_type) = @_;
- sub create_type_constraint_union (@) {
- my (@type_constraint_names) = @_;
- return Moose::Meta::TypeConstraint->union(
- map {
- find_type_constraint($_)
- } @type_constraint_names
+ return $REGISTRY->get_type_constraint($type_constraint_name)
+ if $REGISTRY->has_type_constraint($type_constraint_name);
+
+ my $constraint;
+
+ if (_detect_type_constraint_union($type_constraint_name)) {
+ $constraint = create_type_constraint_union($type_constraint_name);
+ }
+ elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
+ $constraint = create_parameterized_type_constraint($type_constraint_name);
+ }
+ else {
+ # NOTE:
+ # otherwise assume that we should create
+ # an ANON type with the $options_for_anon_type
+ # options which can be passed in. It should
+ # be noted that these don't get registered
+ # so we need to return it.
+ # - SL
+ return Moose::Meta::TypeConstraint->new(
+ name => '__ANON__',
+ %{$options_for_anon_type}
);
}
- sub export_type_contstraints_as_functions {
- my $pkg = caller();
- no strict 'refs';
- foreach my $constraint (keys %TYPES) {
- *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint;
- }
- }
-
- sub list_all_type_constraints { keys %TYPES }
+ $REGISTRY->add_type_constraint($constraint);
+ return $constraint;
}
+## --------------------------------------------------------
+## exported functions ...
+## --------------------------------------------------------
+
+sub find_type_constraint ($) { $REGISTRY->get_type_constraint(@_) }
+
# type constructors
sub type ($$;$$) {
}
sub subtype ($$;$$$) {
- unshift @_ => undef if scalar @_ <= 2;
+ # 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:
+ # subtype(MyNumbers => as Num); # now MyNumbers is the same as Num
+ # ... yeah I know it's ugly code
+ # - SL
+ unshift @_ => undef if scalar @_ <= 2 && (reftype($_[1]) || '') eq 'CODE';
goto &_create_type_constraint;
}
my ($type_name, @values) = @_;
(scalar @values >= 2)
|| confess "You must have at least two values to enumerate through";
- my $regexp = join '|' => @values;
+ my %valid = map { $_ => 1 } @values;
_create_type_constraint(
$type_name,
'Str',
- sub { qr/^$regexp$/i }
+ sub { $valid{$_} }
);
}
-# define some basic types
+## --------------------------------------------------------
+## desugaring functions ...
+## --------------------------------------------------------
+
+sub _create_type_constraint ($$$;$$) {
+ my $name = shift;
+ my $parent = shift;
+ my $check = shift || sub { 1 };
+
+ my ($message, $optimized);
+ for (@_) {
+ $message = $_->{message} if exists $_->{message};
+ $optimized = $_->{optimized} if exists $_->{optimized};
+ }
+
+ my $pkg_defined_in = scalar(caller(0));
+
+ 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;
+ }
+
+ $parent = $REGISTRY->get_type_constraint($parent) if defined $parent;
+
+ my $constraint = Moose::Meta::TypeConstraint->new(
+ name => $name || '__ANON__',
+ parent => $parent,
+ constraint => $check,
+ message => $message,
+ optimized => $optimized,
+ package_defined_in => $pkg_defined_in,
+ );
+
+ $REGISTRY->add_type_constraint($constraint)
+ if defined $name;
+
+ return $constraint;
+}
+
+sub _install_type_coercions ($$) {
+ my ($type_name, $coercion_map) = @_;
+ my $type = $REGISTRY->get_type_constraint($type_name);
+ (!$type->has_coercion)
+ || confess "The type coercion for '$type_name' has already been registered";
+ my $type_coercion = Moose::Meta::TypeCoercion->new(
+ type_coercion_map => $coercion_map,
+ type_constraint => $type
+ );
+ $type->coercion($type_coercion);
+}
+
+## --------------------------------------------------------
+## type notation parsing ...
+## --------------------------------------------------------
+
+{
+ # All I have to say is mugwump++ cause I know
+ # do not even have enough regexp-fu to be able
+ # to have written this (I can only barely
+ # understand it as it is)
+ # - SL
+
+ use re "eval";
+
+ my $valid_chars = qr{[\w:]};
+ my $type_atom = qr{ $valid_chars+ };
+
+ my $type = qr{ $valid_chars+ (?: \[ (??{$any}) \] )? }x;
+ my $type_capture_parts = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x;
+ my $type_with_parameter = qr{ $valid_chars+ \[ (??{$any}) \] }x;
+
+ my $op_union = qr{ \s* \| \s* }x;
+ my $union = qr{ $type (?: $op_union $type )+ }x;
+
+ our $any = qr{ $type | $union }x;
+
+ sub _parse_parameterized_type_constraint {
+ $_[0] =~ m{ $type_capture_parts }x;
+ return ($1, $2);
+ }
+
+ sub _detect_parameterized_type_constraint {
+ $_[0] =~ m{ ^ $type_with_parameter $ }x;
+ }
+
+ sub _parse_type_constraint_union {
+ my $given = shift;
+ my @rv;
+ while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
+ push @rv => $1;
+ }
+ (pos($given) eq length($given))
+ || confess "'$given' didn't parse (parse-pos="
+ . pos($given)
+ . " and str-length="
+ . length($given)
+ . ")";
+ @rv;
+ }
+
+ sub _detect_type_constraint_union {
+ $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
+ }
+}
+
+## --------------------------------------------------------
+# define some basic built-in types
+## --------------------------------------------------------
type 'Any' => where { 1 }; # meta-type including all
type 'Item' => where { 1 }; # base-type
=> as 'Object'
=> where { $_->can('does') }
=> optimize_as { blessed($_[0]) && $_[0]->can('does') };
+
+subtype 'ClassName'
+ => as 'Str'
+ => where { eval { $_->isa('UNIVERSAL') } }
+ => optimize_as { !ref($_[0]) && eval { $_[0]->isa('UNIVERSAL') } };
+
+## --------------------------------------------------------
+# end of built-in types ...
+## --------------------------------------------------------
{
my @BUILTINS = list_all_type_constraints();
Num
Int
Str
+ ClassName
Ref
ScalarRef
ArrayRef
B<NOTE:> The C<Undef> type constraint does not work correctly
in every occasion, please use it sparringly.
+B<NOTE:> The C<ClassName> type constraint is simply a subtype
+of string which responds true to C<isa('UNIVERSAL')>. This means
+that your class B<must> be loaded for this type constraint to
+pass. I know this is not ideal for all, but it is a saner
+restriction than most others.
+
=head2 Use with Other Constraint Modules
This module should play fairly nicely with other constraint
=head1 FUNCTIONS
-=head2 Type Constraint Registry
+=head2 Type Constraint Construction & Locating
=over 4
-=item B<find_type_constraint ($type_name)>
+=item B<create_type_constraint_union ($pipe_seperated_types | @type_constraint_names)>
-This function can be used to locate a specific type constraint
-meta-object. What you do with it from there is up to you :)
+Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>,
+this will return a L<Moose::Meta::TypeConstraint::Union> instance.
-=item B<create_type_constraint_union (@type_constraint_names)>
+=item B<create_parameterized_type_constraint ($type_name)>
-Given a list of C<@type_constraint_names>, this will return a
-B<Moose::Meta::TypeConstraint::Union> instance.
+Given a C<$type_name> in the form of:
-=item B<export_type_contstraints_as_functions>
+ BaseType[ContainerType]
-This will export all the current type constraints as functions
-into the caller's namespace. Right now, this is mostly used for
-testing, but it might prove useful to others.
+this will extract the base type and container type and build an instance of
+L<Moose::Meta::TypeConstraint::Parameterized> for it.
+
+=item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
+
+This will attempt to find or create a type constraint given the a C<$type_name>.
+If it cannot find it in the registry, it will see if it should be a union or
+container type an create one if appropriate, and lastly if nothing can be
+found or created that way, it will create an anon-type using the
+C<$options_for_anon_type> HASH ref to populate it.
+
+=item B<find_type_constraint ($type_name)>
+
+This function can be used to locate a specific type constraint
+meta-object, of the class L<Moose::Meta::TypeConstraint> or a
+derivative. What you do with it from there is up to you :)
+
+=item B<get_type_constraint_registry>
+
+Fetch the L<Moose::Meta::TypeConstraint::Registry> object which
+keeps track of all type constraints.
=item B<list_all_type_constraints>
those which are defined in this module. See the section
labeled L<Default Type Constraints> for a complete list.
+=item B<export_type_constraints_as_functions>
+
+This will export all the current type constraints as functions
+into the caller's namespace. Right now, this is mostly used for
+testing, but it might prove useful to others.
+
=back
=head2 Type Constraint Constructors
They will then register the type constraints in a global store
where Moose can get to them if it needs to.
-See the L<SYNOPOSIS> for an example of how to use these.
+See the L<SYNOPSIS> for an example of how to use these.
=over 4
This will create a basic subtype for a given set of strings.
The resulting constraint will be a subtype of C<Str> and
-will match any of the items in C<@values>. See the L<SYNOPSIS>
-for a simple example.
+will match any of the items in C<@values>. It is case sensitive.
+See the L<SYNOPSIS> for a simple example.
B<NOTE:> This is not a true proper enum type, it is simple
a convient constraint builder.
=head2 Type Coercion Constructors
Type constraints can also contain type coercions as well. If you
-ask your accessor too coerce, the Moose will run the type-coercion
+ask your accessor to coerce, then Moose will run the type-coercion
code first, followed by the type constraint check. This feature
should be used carefully as it is very powerful and could easily
take off a limb if you are not careful.
-See the L<SYNOPOSIS> for an example of how to use these.
+See the L<SYNOPSIS> for an example of how to use these.
=over 4
projects / gitmo/Moose.git / blobdiff