X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FTypes%2FBase.pm;h=87906f8e572be62826138a97902b9af4612d02b2;hb=4fe418ef8e65a7277d25459d5c80341ab76dce3f;hp=0bd4ee0578a959cf792440dd72017c3dcac749c7;hpb=52d358e2cf004a8b632b655832f7e9101db3c4dc;p=gitmo%2FMooseX-Types.git diff --git a/lib/MooseX/Types/Base.pm b/lib/MooseX/Types/Base.pm index 0bd4ee0..87906f8 100644 --- a/lib/MooseX/Types/Base.pm +++ b/lib/MooseX/Types/Base.pm @@ -1,25 +1,19 @@ package MooseX::Types::Base; +use Moose; -=head1 NAME - -MooseX::Types::Base - Type library base class - -=cut - -#use warnings; -#use strict; +# ABSTRACT: Type library base class -use Sub::Install qw( install_sub ); -use Carp qw( croak ); -use MooseX::Types::Util qw( filter_tags ); +use Carp::Clan qw( ^MooseX::Types ); +use MooseX::Types::Util qw( filter_tags ); +use Sub::Exporter qw( build_exporter ); use Moose::Util::TypeConstraints; -use Moose; -use namespace::clean; + +use namespace::autoclean; =head1 DESCRIPTION You normally won't need to interact with this class by yourself. It is -merely a collection of functionality that type libraries need to +merely a collection of functionality that type libraries need to interact with moose and the rest of the L module. =cut @@ -32,7 +26,7 @@ my $UndefMsg = q{Unable to find type '%s' in library '%s'}; =head2 import -Provides the import mechanism for your library. See +Provides the import mechanism for your library. See L for syntax details on this. =cut @@ -40,73 +34,80 @@ L for syntax details on this. sub import { my ($class, @args) = @_; - # 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)); + # filter or create options hash for S:E + my $options = (@args and (ref($args[0]) eq 'HASH')) ? $args[0] : undef; + unless ($options) { + $options = {foo => 23}; + unshift @args, $options; + } - # :all replaces types with full list - @$types = $class->type_names if $tags->{all}; + # all types known to us + my @types = $class->type_names; + # determine the wrapper, -into is supported for compatibility reasons + my $wrapper = $options->{ -wrapper } || 'MooseX::Types'; + $args[0]->{into} = $options->{ -into } + if exists $options->{ -into }; + + my (%ex_spec, %ex_util); TYPE: - # export all requested types - for my $type (@$types) { - $class->export_type_into( - $callee, - $type, - sprintf($UndefMsg, $type, $class), - ($options ? %$options : ()), - ); + for my $type_short (@types) { + + # find type name and object, create undefined message + my $type_full = $class->get_type($type_short) + or croak "No fully qualified type name stored for '$type_short'"; + my $type_cons = find_type_constraint($type_full); + my $undef_msg = sprintf($UndefMsg, $type_short, $class); + + # the type itself + push @{ $ex_spec{exports} }, + $type_short, + sub { + bless $wrapper->type_export_generator($type_short, $type_full), + 'MooseX::Types::EXPORTED_TYPE_CONSTRAINT'; + }; + + # the check helper + push @{ $ex_spec{exports} }, + "is_${type_short}", + sub { $wrapper->check_export_generator($type_short, $type_full, $undef_msg) }; + + # only export coercion helper if full (for libraries) or coercion is defined + next TYPE + unless $options->{ -full } + or ($type_cons and $type_cons->has_coercion); + push @{ $ex_spec{exports} }, + "to_${type_short}", + sub { $wrapper->coercion_export_generator($type_short, $type_full, $undef_msg) }; + $ex_util{ $type_short }{to}++; # shortcut to remember this exists } - return 1; -} -=head2 export_type_into + # create S:E exporter and increase export level unless specified explicitly + my $exporter = build_exporter \%ex_spec; + $options->{into_level}++ + unless $options->{into}; -Exports one specific type into a target package. - -=cut + # remember requested symbols to determine what helpers to auto-export + my %was_requested = + map { ($_ => 1) } + grep { not ref } + @args; -sub export_type_into { - my ($class, $target, $type, $undef_msg, %args) = @_; - - # the real type name and its type object - my $full = $class->get_type($type); - my $tobj = find_type_constraint($full); - - # a possible wrapper around library functionality - my $wrap = $args{ -wrapper } || 'MooseX::Types'; - - # install Type name constant - install_sub({ - code => $wrap->type_export_generator($type, $full), - into => $target, - as => $type, - }); - - # install is_Type test function - install_sub({ - code => $wrap->check_export_generator($type, $full, $undef_msg), - into => $target, - as => "is_$type", - }); - - # only install to_Type coercion handler if type can coerce - # or if we want to provide them anyway, e.g. declarations - if ($args{ -full } or $tobj->has_coercion) { - - # install to_Type coercion handler - install_sub({ - code => $wrap->coercion_export_generator($type, $full, $undef_msg), - into => $target, - as => "to_$type", - }); + # determine which additional symbols (helpers) to export along + my %add; + EXPORT: + for my $type (grep { exists $was_requested{ $_ } } @types) { + $add{ "is_$type" }++ + unless $was_requested{ "is_$type" }; + next EXPORT + unless exists $ex_util{ $type }{to}; + $add{ "to_$type" }++ + unless $was_requested{ "to_$type" }; } - return 1; + # and on to the real exporter + my @new_args = (@args, keys %add); + return $class->$exporter(@new_args); } =head2 get_type @@ -183,14 +184,93 @@ sub type_storage { } } -=head1 SEE ALSO +=head2 registered_class_types -L +Returns the class types registered within this library. Don't use directly. + +=cut + +sub registered_class_types { + my ($class) = @_; + + { + no strict 'refs'; + return \%{ $class . '::__MOOSEX_TYPELIBRARY_CLASS_TYPES' }; + } +} + +=head2 register_class_type + +Register a C for use in this library by class name. + +=cut + +sub register_class_type { + my ($class, $type) = @_; + + croak "Not a class_type" + unless $type->isa('Moose::Meta::TypeConstraint::Class'); + + $class->registered_class_types->{$type->class} = $type; +} + +=head2 get_registered_class_type -=head1 AUTHOR AND COPYRIGHT +Get a C registered in this library by name. -Robert 'phaylon' Sedlacek Crs@474.atE>, with many thanks to -the C<#moose> cabal on C. +=cut + +sub get_registered_class_type { + my ($class, $name) = @_; + + $class->registered_class_types->{$name}; +} + +=head2 registered_role_types + +Returns the role types registered within this library. Don't use directly. + +=cut + +sub registered_role_types { + my ($class) = @_; + + { + no strict 'refs'; + return \%{ $class . '::__MOOSEX_TYPELIBRARY_ROLE_TYPES' }; + } +} + +=head2 register_role_type + +Register a C for use in this library by role name. + +=cut + +sub register_role_type { + my ($class, $type) = @_; + + croak "Not a role_type" + unless $type->isa('Moose::Meta::TypeConstraint::Role'); + + $class->registered_role_types->{$type->role} = $type; +} + +=head2 get_registered_role_type + +Get a C registered in this library by role name. + +=cut + +sub get_registered_role_type { + my ($class, $name) = @_; + + $class->registered_role_types->{$name}; +} + +=head1 SEE ALSO + +L =head1 LICENSE