[Moose-commits] r7763 - in Moose/trunk: . lib/Moose/Util
t/040_type_constraints
autarch at code2.0beta.co.uk
autarch at code2.0beta.co.uk
Sat Feb 21 22:00:59 GMT 2009
Author: autarch
Date: 2009-02-21 14:00:59 -0800 (Sat, 21 Feb 2009)
New Revision: 7763
Modified:
Moose/trunk/Changes
Moose/trunk/lib/Moose/Util/TypeConstraints.pm
Moose/trunk/t/040_type_constraints/001_util_type_constraints.t
Log:
Change how the TC sugar bits work so that the arguments are
unambiguous (as long as you use the sugar).
If type or subtype is called without sugar helpers, the behavior
remains the same (but is deprecated).
Added tests for the things that are fixed, as well as for the old behavior.
Modified: Moose/trunk/Changes
===================================================================
--- Moose/trunk/Changes 2009-02-21 20:23:21 UTC (rev 7762)
+++ Moose/trunk/Changes 2009-02-21 22:00:59 UTC (rev 7763)
@@ -9,13 +9,20 @@
- 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)
@@ -24,6 +31,10 @@
- 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)
Modified: Moose/trunk/lib/Moose/Util/TypeConstraints.pm
===================================================================
--- Moose/trunk/lib/Moose/Util/TypeConstraints.pm 2009-02-21 20:23:21 UTC (rev 7762)
+++ Moose/trunk/lib/Moose/Util/TypeConstraints.pm 2009-02-21 22:00:59 UTC (rev 7763)
@@ -6,7 +6,7 @@
use Carp ();
use List::MoreUtils qw( all );
-use Scalar::Util 'blessed';
+use Scalar::Util qw( blessed reftype );
use Moose::Exporter;
our $VERSION = '0.71';
@@ -26,10 +26,6 @@
sub message (&);
sub optimize_as (&);
-## private stuff ...
-sub _create_type_constraint ($$$;$$);
-sub _install_type_coercions ($$);
-
## --------------------------------------------------------
use Moose::Meta::TypeConstraint;
@@ -260,28 +256,50 @@
# 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" }
+ # crazy back-compat code for being called without sugar ...
#
- # 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 @_ == 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 {
@@ -315,13 +333,13 @@
_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) = @_;
@@ -359,18 +377,14 @@
## --------------------------------------------------------
sub _create_type_constraint ($$$;$$) {
- my $name = shift;
- my $parent = shift;
- my $check = shift;
+ my $name = shift;
+ my $parent = shift;
+ my $check = shift;
+ my $message = shift;
+ my $optimized = shift;
- my ( $message, $optimized );
- for (@_) {
- $message = $_->{message} if exists $_->{message};
- $optimized = $_->{optimized} if exists $_->{optimized};
- }
+ my $pkg_defined_in = scalar( caller(1) );
- my $pkg_defined_in = scalar( caller(0) );
-
if ( defined $name ) {
my $type = $REGISTRY->get_type_constraint($name);
@@ -388,7 +402,7 @@
}
my %opts = (
- name => $name,
+ name => $name,
package_defined_in => $pkg_defined_in,
( $check ? ( constraint => $check ) : () ),
@@ -857,19 +871,25 @@
=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
L<Moose::Meta::TypeConstraint>.
Modified: Moose/trunk/t/040_type_constraints/001_util_type_constraints.t
===================================================================
--- Moose/trunk/t/040_type_constraints/001_util_type_constraints.t 2009-02-21 20:23:21 UTC (rev 7762)
+++ Moose/trunk/t/040_type_constraints/001_util_type_constraints.t 2009-02-21 22:00:59 UTC (rev 7763)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 52;
+use Test::More tests => 73;
use Test::Exception;
use Scalar::Util ();
@@ -134,3 +134,65 @@
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');
+}
+
More information about the Moose-commits
mailing list