- A new recipe, applying a role to an object instance. (Dave
Rolsky)
- * Moose::Util::TypeConstraints::Optimized
- - Just use Class::MOP for the optimized ClassName check. (Dave
- Rolsky)
-
* Moose::Exporter
- Allow overriding specific keywords from "also" packages. (doy)
+ * Moose::Util::TypeConstraints
+ - Calling type or subtype without the sugar helpers (as, where,
+ message) is now deprecated.
+ - The subtype function tried hard to guess what you meant, but
+ often got it wrong. For example:
+
+ my $subtype = subtype as 'ArrayRef[Object]';
+
+ This caused an error in the past, but now works as you'd
+ expect.
+
* Tests
- Replace hardcoded cookbook tests with Test::Inline POD
to ensure they don't get out of sync. (Dave Rolsky)
- Working on the above turned up a number of little bugs in the
recipe code. (Dave Rolsky)
+ * Moose::Util::TypeConstraints::Optimized
+ - Just use Class::MOP for the optimized ClassName check. (Dave
+ Rolsky)
+
0.70 Sat, February 14, 2009
* Moose::Util::TypeConstraints
- Added the RoleName type (stevan)
use Carp ();
use List::MoreUtils qw( all );
-use Scalar::Util 'blessed';
+use Scalar::Util qw( blessed reftype );
use Moose::Exporter;
our $VERSION = '0.71';
sub message (&);
sub optimize_as (&);
-## private stuff ...
-sub _create_type_constraint ($$$;$$);
-sub _install_type_coercions ($$);
-
## --------------------------------------------------------
use Moose::Meta::TypeConstraint;
# type constructors
sub type {
- splice(@_, 1, 0, undef);
- goto &_create_type_constraint;
+ if ( all { ( reftype($_) || '' ) eq 'CODE' || ! ref $_ } @_ ) {
+ # back-compat version, called without sugar
+ _create_type_constraint( $_[0], undef, $_[1] );
+ }
+ else {
+ my $name = shift;
+
+ my %p = map { %{$_} } @_;
+
+ _create_type_constraint( $name, undef, $p{check}, $p{message}, $p{optimized} );
+ }
}
sub subtype {
- # NOTE:
- # this adds an undef for the name
- # if this is an anon-subtype:
- # subtype(Num => where { $_ % 2 == 0 }) # anon 'even' subtype
- # 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:
+ # crazy back-compat code for being called without sugar ...
#
- # 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 @_ == 3 && all { ref($_) =~ /^(?:CODE|HASH)$/ } @_[ 1, 2 ];
- goto &_create_type_constraint;
+ # subtype 'Parent', sub { where };
+ if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) {
+ return _create_type_constraint( undef, @_ );
+ }
+
+ # subtype 'Parent', sub { where }, sub { message };
+ # subtype 'Parent', sub { where }, sub { message }, sub { optimized };
+ if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
+ @_[ 1 .. $#_ ] ) {
+ return _create_type_constraint( undef, @_ );
+ }
+
+ # subtype 'Name', 'Parent', ...
+ if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) {
+ return _create_type_constraint(@_);
+ }
+
+ my $name = ref $_[0] ? undef : shift;
+
+ my %p = map { %{$_} } @_;
+
+ # subtype Str => where { ... };
+ if ( ! exists $p{parent} ) {
+ $p{parent} = $name;
+ $name = undef;
+ }
+
+ _create_type_constraint( $name, $p{parent}, $p{check}, $p{message}, $p{optimized} );
}
sub class_type {
_install_type_coercions($type_name, \@coercion_map);
}
-sub as { @_ }
-sub from { @_ }
-sub where (&) { $_[0] }
-sub via (&) { $_[0] }
+sub as ($) { { parent => $_[0] } }
+sub where (&) { { check => $_[0] } }
+sub message (&) { { message => $_[0] } }
+sub optimize_as (&) { { optimized => $_[0] } }
-sub message (&) { +{ message => $_[0] } }
-sub optimize_as (&) { +{ optimized => $_[0] } }
+sub from {@_}
+sub via (&) { $_[0] }
sub enum {
my ($type_name, @values) = @_;
## --------------------------------------------------------
sub _create_type_constraint ($$$;$$) {
- my $name = shift;
- my $parent = shift;
- my $check = shift;
-
- my ( $message, $optimized );
- for (@_) {
- $message = $_->{message} if exists $_->{message};
- $optimized = $_->{optimized} if exists $_->{optimized};
- }
+ my $name = shift;
+ my $parent = shift;
+ my $check = shift;
+ my $message = shift;
+ my $optimized = shift;
- my $pkg_defined_in = scalar( caller(0) );
+ my $pkg_defined_in = scalar( caller(1) );
if ( defined $name ) {
my $type = $REGISTRY->get_type_constraint($name);
}
my %opts = (
- name => $name,
+ name => $name,
package_defined_in => $pkg_defined_in,
( $check ? ( constraint => $check ) : () ),
=over 4
-=item B<type ($name, $where_clause)>
+=item B<type 'Name' => where { } ... >
This creates a base type, which has no parent.
-=item B<subtype ($name, $parent, $where_clause, ?$message)>
+Note that calling C<type> I<without> the sugar helpers (C<where>,
+C<message>, etc), is deprecated.
+
+=item B<subtype 'Name' => as 'Parent' => where { } ...>
This creates a named subtype.
If you provide a parent that Moose does not recognize, it will
automatically create a new class type constraint for this name.
-=item B<subtype ($parent, $where_clause, ?$message)>
+Note that calling C<subtype> I<without> the sugar helpers (C<where>,
+C<message>, etc), is deprecated.
+
+=item B<subtype as 'Parent' => where { } ...>
This creates an unnamed subtype and will return the type
constraint meta-object, which will be an instance of
use strict;
use warnings;
-use Test::More tests => 52;
+use Test::More tests => 73;
use Test::Exception;
use Scalar::Util ();
throws_ok {$r->add_type_constraint('foo')} qr/not a valid type constraint/, '->add_type_constraint("foo") throws';
throws_ok {$r->add_type_constraint(bless {}, 'SomeClass')} qr/not a valid type constraint/, '->add_type_constraint(SomeClass->new) throws';
+# Test some specific things that in the past did not work,
+# specifically weird variations on anon subtypes.
+
+{
+ my $subtype = subtype as 'Str';
+ isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' );
+ is( $subtype->parent->name, 'Str', 'parent is Str' );
+ # This test sucks but is the best we can do
+ is( $subtype->constraint->(), 1,
+ 'subtype has the null constraint' );
+ ok( ! $subtype->has_message, 'subtype has no message' );
+}
+
+{
+ my $subtype = subtype 'ArrayRef[Num|Str]';
+ isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' );
+ is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' );
+ ok( ! $subtype->has_message, 'subtype has no message' );
+}
+
+{
+ my $subtype = subtype 'ArrayRef[Num|Str]' => message { 'foo' };
+ isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' );
+ is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' );
+ ok( $subtype->has_message, 'subtype does have a message' );
+}
+
+# Back-compat for being called without sugar. Previously, calling with
+# sugar was indistinguishable from calling directly.
+
+{
+ my $type = type( 'Number2', sub { Scalar::Util::looks_like_number($_) } );
+
+ ok( $type->check(5), '... this is a Num' );
+ ok( ! $type->check('Foo'), '... this is not a Num' );
+}
+
+{
+ # anon subtype
+ my $subtype = subtype( 'Number2', sub { $_ > 0 } );
+
+ ok( $subtype->check(5), '... this is a Natural');
+ ok( ! $subtype->check(-5), '... this is not a Natural');
+ ok( ! $subtype->check('Foo'), '... this is not a Natural');
+}
+
+{
+ my $subtype = subtype( 'Natural2', 'Number2', sub { $_ > 0 } );
+
+ ok( $subtype->check(5), '... this is a Natural');
+ ok( ! $subtype->check(-5), '... this is not a Natural');
+ ok( ! $subtype->check('Foo'), '... this is not a Natural');
+}
+
+{
+ my $subtype = subtype( 'Natural3', 'Number2' );
+
+ ok( $subtype->check(5), '... this is a Natural');
+ ok( $subtype->check(-5), '... this is a Natural');
+ ok( ! $subtype->check('Foo'), '... this is not a Natural');
+}
+
projects / gitmo/Moose.git / commitdiff