our $VERSION = '0.01';
+use Scalar::Util qw/blessed/;
+
use Sub::Name ();
use Any::Moose;
+use Any::Moose 'Util' => [ 'find_meta' ];
extends any_moose('Meta::TypeConstraint');
+=head1 ATTRIBUTES
+
+=head2 C<mapper>
+
+=cut
+
has 'mapper' => (
is => 'ro',
isa => 'CodeRef',
);
-has 'parent_name' => (
+=head2 C<parent>
+
+=cut
+
+has 'parent' => (
is => 'ro',
- isa => 'ClassName',
+ isa => any_moose('Meta::TypeConstraint'),
required => 1,
);
+=head2 C<user_constraint>
+
+=cut
+
has 'user_constraint' => (
is => 'ro',
isa => 'Maybe[CodeRef]',
required => 1,
);
+=head1 METHODS
+
+=cut
+
around 'new' => sub {
my ($orig, $class, %args) = @_;
unless (exists $args{mapper}) {
- $args{mapper} = sub { join '::', $_[0]->parent_name, $_[1] };
+ $args{mapper} = sub { join '::', $_[0]->parent->name, $_[1] };
}
my $parent = delete $args{parent};
- $args{parent_name} = defined $parent
- ? (blessed($parent) ? $parent->name : $parent)
- : '__ANON__';
+ unless (blessed $parent) {
+ $parent = find_meta($parent)->type_constraint;
+ }
+ __PACKAGE__->meta->find_attribute_by_name('parent')
+ ->type_constraint->assert_valid($parent);
+ $args{parent} = $parent;
- $args{user_constraint} = $args{constraint};
+ $args{user_constraint} = delete $args{constraint};
if (any_moose() eq 'Moose') {
$args{coercion} = Moose::Meta::TypeCoercion->new;
}
- my $parent_name = $args{parent_name};
- $parent_name =~ s/::+/_/g;
-
my $tc;
- $args{constraint} = Sub::Name::subname("${parent_name}_load" => sub {
- my ($thing) = @_;
+ $args{constraint} = Sub::Name::subname('_load' => sub {
+ $tc->load(@_);
+ });
- # First, try a possible user defined constraint
- my $user = $tc->user_constraint;
- if (defined $user) {
- my $ok = $user->($thing);
- return 1 if $ok;
- }
+ $tc = $class->$orig(%args);
+};
- # When ->check is called inside coerce, a return value of 0 means that
- # coercion should take place, while 1 signifies that the value is already
- # OK.
+=head2 C<load>
- my $class = blessed($thing);
- return 0 unless $class;
- return 1 if $class->isa($tc->parent_name);
+=cut
- my $mapper = $tc->mapper;
- my $pm = $class = $tc->$mapper($class);
+sub load {
+ my ($tc, $thing) = @_;
- $pm =~ s{::}{/}g;
- $pm .= '.pm';
- return 0 if $INC{$pm}; # already loaded
+ # When ->check is called inside coerce, a return value of 0 means that
+ # coercion should take place, while 1 signifies that the value is already
+ # OK.
- local $@;
- eval { require $pm; 1 };
+ # First, try a possible user defined constraint
+ my $user = $tc->user_constraint;
+ if (defined $user) {
+ my $ok = $user->($thing);
+ return 1 if $ok;
+ }
- return 0;
- });
+ # Then, try the parent constraint
+ return 1 if $tc->parent->check($thing);
- $tc = $class->$orig(%args);
-};
+ # If $thing isn't even an object, don't bother trying to coerce it
+ my $class = blessed($thing);
+ return 0 unless defined $class;
+
+ # Find the file to autoload
+ my $mapper = $tc->mapper;
+ my $pm = $class = $tc->$mapper($class);
+ $pm =~ s{::}{/}g;
+ $pm .= '.pm';
+ return 0 if $INC{$pm}; # already loaded
+
+ local $@;
+ eval { require $pm; 1 };
+
+ return 0;
+}
around 'coerce' => sub {
my ($orig, $tc, $thing) = @_;
# The original coerce gets an hold onto the type coercions *before* calling
# the constraint. Thus, we have to force the loading before recalling into
- # $orig. This is achieved by calling ->check.
- return $thing if $tc->check($thing);
+ # $orig. This is achieved by calling ->load.
+ return $thing if $tc->load($thing);
$tc->$orig($thing);
};