use Sub::Uplevel;
use Moose::Util::TypeConstraints;
-use MooseX::TypeLibrary::Base;
+use MooseX::TypeLibrary::Base ();
use MooseX::TypeLibrary::Util qw( filter_tags );
use MooseX::TypeLibrary::UndefinedType;
use Sub::Install qw( install_sub );
MooseX::TypeLibrary comes with a library of Moose' built-in types called
L<MooseX::TypeLibrary::Moose>.
+=head1 WRAPPING A LIBRARY
+
+You can define your own wrapper subclasses to manipulate the behaviour
+of a set of library exports. Here is an example:
+
+ package MyWrapper;
+ use strict;
+ use Class::C3;
+ use base 'MooseX::TypeLibrary::Wrapper';
+
+ sub coercion_export_generator {
+ my $class = shift;
+ my $code = $class->next::method(@_);
+ return sub {
+ my $value = $code->(@_);
+ warn "Coercion returned undef!"
+ unless defined $value;
+ return $value;
+ };
+ }
+
+ 1;
+
+This class wraps the coercion generator (e.g., C<to_Int()>) and warns
+if a coercion returned an undefined value. You can wrap any library
+with this:
+
+ package Foo;
+ use strict;
+ use MyWrapper MyLibrary => [qw( Foo Bar )],
+ Moose => [qw( Str Int )];
+
+ ...
+ 1;
+
+The C<Moose> library name is a special shortcut for
+L<MooseX::TypeLibrary::Moose>.
+
+=head2 Generator methods you can overload
+
+=over 4
+
+=item type_export_generator( $short, $full )
+
+Creates a closure returning the type's L<Moose::Meta::TypeConstraint>
+object.
+
+=item check_export_generator( $short, $full, $undef_message )
+
+This creates the closure used to test if a value is valid for this type.
+
+=item coercion_export_generator( $short, $full, $undef_message )
+
+This is the closure that's doing coercions.
+
+=back
+
+=head2 Provided Parameters
+
+=over 4
+
+=item $short
+
+The short, exported name of the type.
+
+=item $full
+
+The fully qualified name of this type as L<Moose> knows it.
+
+=item $undef_message
+
+A message that will be thrown when type functionality is used but the
+type does not yet exist.
+
+=back
+
=head1 METHODS
=head2 import
}
# run type constraints import
- return Moose::Util::TypeConstraints
- ->import({ into => $callee });
-# return uplevel 1,
-# Moose::Util::TypeConstraints->can('import'),
-# 'Moose::Util::TypeConstraints';
+ return Moose::Util::TypeConstraints->import({ into => $callee });
}
=head2 type_export_generator
=cut
sub import {
- my ($class, @orig_types) = @_;
+ my ($class, @args) = @_;
- # separate tags from types
- my ($tags, $types) = filter_tags @orig_types;
+ # separate tags from types and possible options
+ my ($options) = grep { ref $_ eq 'HASH' } @args;
+ my ($tags, $types)
+ = filter_tags
+ grep { ref $_ ne 'HASH' }
+ @args;
+ my $callee = ($options && $options->{ -into } || scalar(caller));
# :all replaces types with full list
@$types = $class->type_names if $tags->{all};
# export all requested types
for my $type (@$types) {
$class->export_type_into(
- scalar(caller),
+ $callee,
$type,
sprintf($UndefMsg, $type, $class),
+ ($options ? %$options : ()),
);
}
return 1;
# the real type name and its type object
my $full = $class->get_type($type);
my $tobj = find_type_constraint($full);
- ### Exporting: $full
+
+ # a possible wrapper around library functionality
+ my $wrap = $args{ -wrapper } || 'MooseX::TypeLibrary';
# install Type name constant
install_sub({
- code => MooseX::TypeLibrary->type_export_generator($type, $full),
+ code => $wrap->type_export_generator($type, $full),
into => $target,
as => $type,
});
# install is_Type test function
install_sub({
- code => MooseX::TypeLibrary
- ->check_export_generator($type, $full, $undef_msg),
+ code => $wrap->check_export_generator($type, $full, $undef_msg),
into => $target,
as => "is_$type",
});
# install to_Type coercion handler
install_sub({
- code => MooseX::TypeLibrary->coercion_export_generator(
- $type, $full, $undef_msg ),
+ code => $wrap->coercion_export_generator($type, $full, $undef_msg),
into => $target,
as => "to_$type",
});
--- /dev/null
+package MooseX::TypeLibrary::Wrapper;
+use warnings;
+use strict;
+use base 'MooseX::TypeLibrary';
+
+use Carp qw( croak );
+use Class::Inspector;
+use namespace::clean;
+
+sub import {
+ my ($class, @args) = @_;
+ my %libraries = @args == 1 ? (Moose => $args[0]) : @args;
+
+ for my $l (keys %libraries) {
+
+ croak qq($class expects an array reference as import spec)
+ unless ref $libraries{ $l } eq 'ARRAY';
+
+ my $library_class
+ = ($l eq 'Moose' ? 'MooseX::TypeLibrary::Moose' : $l );
+ require Class::Inspector->filename($library_class)
+ unless Class::Inspector->loaded($library_class);
+
+ $library_class->import(
+ @{ $libraries{ $l } },
+ { -into => scalar(caller) }
+ );
+ }
+ return 1;
+}
+
+1;
--- /dev/null
+#!/usr/bin/env perl
+use warnings;
+use strict;
+
+use Test::More;
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use TestWrapper TestLibrary => [qw( NonEmptyStr IntArrayRef )],
+ Moose => [qw( Str Int )];
+
+my @tests = (
+ [ 'NonEmptyStr', 12, "12", [], "foobar", "" ],
+ [ 'IntArrayRef', 12, [12], {}, [17, 23], {} ],
+);
+
+plan tests => (@tests * 8);
+
+# new array ref so we can safely shift from it
+for my $data (map { [@$_] } @tests) {
+ my $type = shift @$data;
+
+ # Type name export
+ {
+ ok my $code = __PACKAGE__->can($type), "$type() was exported";
+ is $code->(), "TestLibrary::$type", "$type() returned correct type name";
+ }
+
+ # coercion handler export
+ {
+ my ($coerce, $coercion_result, $cannot_coerce) = map { shift @$data } 1 .. 3;
+ ok my $code = __PACKAGE__->can("to_$type"), "to_$type() coercion was exported";
+ is_deeply scalar $code->($coerce), $coercion_result, "to_$type() coercion works";
+ ok ! $code->($cannot_coerce), "to_$type() returns false on invalid value";
+ }
+
+ # type test handler
+ {
+ my ($valid, $invalid) = map { shift @$data } 1 .. 2;
+ ok my $code = __PACKAGE__->can("is_$type"), "is_$type() check was exported";
+ ok $code->($valid), "is_$type() check true on valid value";
+ ok ! $code->($invalid), "is_$type() check false on invalid value";
+ }
+}
+
+
--- /dev/null
+package TestWrapper;
+use strict;
+use warnings;
+
+use Class::C3;
+use base 'MooseX::TypeLibrary::Wrapper';
+
+sub type_export_generator {
+ my $class = shift;
+ my ($type, $full) = @_;
+ my $code = $class->next::method(@_);
+ return sub { $code->(@_) };
+}
+
+sub check_export_generator {
+ my $class = shift;
+ my ($type, $full, $undef_msg) = @_;
+ my $code = $class->next::method(@_);
+ return sub {
+ return $code unless @_;
+ return $code->(@_);
+ };
+}
+
+sub coercion_export_generator {
+ my $class = shift;
+ my ($type, $full, $undef_msg) = @_;
+ my $code = $class->next::method(@_);
+ return sub {
+ my $val = $code->(@_);
+ die "coercion returned undef\n" unless defined $val;
+ return $val;
+ };
+}
+
+1;
projects / gitmo/MooseX-Types.git / commitdiff