X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FTypes%2FBase.pm;h=ba5f555b3819130db672855fbd2f86db93acea10;hb=3da38ef893627fa8efeecd85c69ffd1ff4ddb4e6;hp=f5d32b79990199d72879ca18592f3dc6a484677a;hpb=9563f55e99998c6618453988ccba898bc5613192;p=gitmo%2FMooseX-Types.git diff --git a/lib/MooseX/Types/Base.pm b/lib/MooseX/Types/Base.pm index f5d32b7..ba5f555 100644 --- a/lib/MooseX/Types/Base.pm +++ b/lib/MooseX/Types/Base.pm @@ -1,4 +1,6 @@ package MooseX::Types::Base; +our $VERSION = "0.24"; +use Moose; =head1 NAME @@ -6,14 +8,10 @@ MooseX::Types::Base - Type library base class =cut -#use warnings; -#use strict; - -use Sub::Install qw( install_sub ); 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 -except => [qw( meta )]; @@ -41,74 +39,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 types known to us + my @types = $class->type_names; - # :all replaces types with full list - @$types = $class->type_names if $tags->{all}; + # 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 - -Exports one specific type into a target package. - -=cut - -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) - or croak "No fully qualified type name stored for '$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 and $tobj->has_coercion) { - - # install to_Type coercion handler - install_sub({ - code => $wrap->coercion_export_generator($type, $full, $undef_msg), - into => $target, - as => "to_$type", - }); + # create S:E exporter and increase export level unless specified explicitly + my $exporter = build_exporter \%ex_spec; + $options->{into_level}++ + unless $options->{into}; + + # remember requested symbols to determine what helpers to auto-export + my %was_requested = + map { ($_ => 1) } + grep { not ref } + @args; + + # 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 @@ -185,14 +189,97 @@ sub type_storage { } } +=head2 registered_class_types + +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 + +Get a C registered in this library by name. + +=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 AUTHOR AND COPYRIGHT +=head1 AUTHOR -Robert 'phaylon' Sedlacek Crs@474.atE>, with many thanks to -the C<#moose> cabal on C. +See L. =head1 LICENSE