use B 'svref_2object';
use Sub::Exporter;
-our $VERSION = '0.14';
+our $VERSION = '0.15';
our $AUTHORITY = 'cpan:STEVAN';
## --------------------------------------------------------
# compiled.
# creation and location
-sub find_type_constraint ($);
-sub find_or_create_type_constraint ($;$);
-sub create_type_constraint_union (@);
-sub create_container_type_constraint ($);
+sub find_type_constraint ($);
+sub find_or_create_type_constraint ($;$);
+sub create_type_constraint_union (@);
+sub create_parameterized_type_constraint ($);
# dah sugah!
sub type ($$;$$);
use Moose::Meta::TypeConstraint;
use Moose::Meta::TypeConstraint::Union;
-use Moose::Meta::TypeConstraint::Container;
+use Moose::Meta::TypeConstraint::Parameterized;
use Moose::Meta::TypeCoercion;
use Moose::Meta::TypeCoercion::Union;
use Moose::Meta::TypeConstraint::Registry;
sub create_type_constraint_union (@) {
my @type_constraint_names;
- if (scalar @_ == 1 && $_[0] =~ /\|/) {
- @type_constraint_names = (split /\s*\|\s*/ => $_[0]);
+ if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
+ @type_constraint_names = _parse_type_constraint_union($_[0]);
}
else {
@type_constraint_names = @_;
);
}
-sub create_container_type_constraint ($) {
+sub create_parameterized_type_constraint ($) {
my $type_constraint_name = shift;
- my ($base_type, $container_type) = ($type_constraint_name =~ /^(.*)\[(.*)\]$/);
+ my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
- (defined $base_type && defined $container_type)
+ (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)";
-
- ($REGISTRY->has_type_constraint($container_type))
- || confess "Could not locate the container type ($container_type)";
- return Moose::Meta::TypeConstraint::Container->new(
+ return Moose::Meta::TypeConstraint::Parameterized->new(
name => $type_constraint_name,
parent => $REGISTRY->get_type_constraint($base_type),
- container_type => $REGISTRY->get_type_constraint($container_type),
+ type_parameter => find_or_create_type_constraint(
+ $type_parameter => {
+ parent => $REGISTRY->get_type_constraint('Object'),
+ constraint => sub { $_[0]->isa($type_parameter) }
+ }
+ ),
);
}
my $constraint;
- if ($type_constraint_name =~ /\|/) {
+ if (_detect_type_constraint_union($type_constraint_name)) {
$constraint = create_type_constraint_union($type_constraint_name);
}
- elsif ($type_constraint_name =~ /^.*?\[.*?\]$/) {
- $constraint = create_container_type_constraint($type_constraint_name);
+ elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
+ $constraint = create_parameterized_type_constraint($type_constraint_name);
}
else {
# NOTE:
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{$_} }
);
}
}
## --------------------------------------------------------
+## 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
## --------------------------------------------------------
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_container_type_constraint ($type_name)>
+=item B<create_parameterized_type_constraint ($type_name)>
Given a C<$type_name> in the form of:
BaseType[ContainerType]
this will extract the base type and container type and build an instance of
-L<Moose::Meta::TypeConstraint::Container> for it.
+L<Moose::Meta::TypeConstraint::Parameterized> for it.
=item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
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.
projects / gitmo/Moose.git / blobdiff