use OO syntax for handling subref

[gitmo/MooseX-Getopt.git] / lib / MooseX / Getopt / OptionTypeMap.pm

diff --git a/lib/MooseX/Getopt/OptionTypeMap.pm b/lib/MooseX/Getopt/OptionTypeMap.pm
index c9e1e05..4102c75 100644 (file)
--- a/lib/MooseX/Getopt/OptionTypeMap.pm
+++ b/lib/MooseX/Getopt/OptionTypeMap.pm
@@ -1,30 +1,37 @@
-
 package MooseX::Getopt::OptionTypeMap;
+# ABSTRACT: Storage for the option to type mappings
 
-use Moose 'confess';
+use Moose 'confess', 'blessed';
 use Moose::Util::TypeConstraints 'find_type_constraint';
 
-our $VERSION   = '0.03';
-our $AUTHORITY = 'cpan:STEVAN';
-
 my %option_type_map = (
     'Bool'     => '!',
     'Str'      => '=s',
     'Int'      => '=i',
     'Num'      => '=f',
     'ArrayRef' => '=s@',
-    'HashRef'  => '=s%',    
+    'HashRef'  => '=s%',
 );
 
 sub has_option_type {
-    my (undef, $type_name) = @_;
-    return 1 if exists $option_type_map{$type_name};
+    my (undef, $type_or_name) = @_;
+
+    if (blessed($type_or_name)
+        && $type_or_name->isa('Moose::Meta::TypeConstraint::Union')) {
+        foreach my $union_type (@{$type_or_name->type_constraints}) {
+            return 1
+                if __PACKAGE__->has_option_type($union_type);
+        }
+        return 0;
+    }
+
+    return 1 if exists $option_type_map{blessed($type_or_name) ? $type_or_name->name : $type_or_name};
+
+    my $current = blessed($type_or_name) ? $type_or_name : find_type_constraint($type_or_name);
 
-    my $current = find_type_constraint($type_name);
-    
     (defined $current)
-        || confess "Could not find the type constraint for '$type_name'";
-    
+        || confess "Could not find the type constraint for '$type_or_name'";
+
     while (my $parent = $current->parent) {
         return 1 if exists $option_type_map{$parent->name};
         $current = $parent;
@@ -34,20 +41,30 @@ sub has_option_type {
 }
 
 sub get_option_type {
-    my (undef, $type_name) = @_;
-    
-    return $option_type_map{$type_name}
-        if exists $option_type_map{$type_name};
+    my (undef, $type_or_name) = @_;
+
+    if (blessed($type_or_name)
+        && $type_or_name->isa('Moose::Meta::TypeConstraint::Union')) {
+        foreach my $union_type (@{$type_or_name->type_constraints}) {
+            my $option_type = __PACKAGE__->get_option_type($union_type);
+            return $option_type
+                if defined $option_type;
+        }
+        return;
+    }
+
+    my $name = blessed($type_or_name) ? $type_or_name->name : $type_or_name;
+
+    return $option_type_map{$name} if exists $option_type_map{$name};
+
+    my $current = ref $type_or_name ? $type_or_name : find_type_constraint($type_or_name);
 
-    my $current = find_type_constraint($type_name);
-    
     (defined $current)
-        || confess "Could not find the type constraint for '$type_name'";    
-    
-    while (my $parent = $current->parent) {
-        return $option_type_map{$parent->name}
-            if exists $option_type_map{$parent->name};
-        $current = $parent;
+        || confess "Could not find the type constraint for '$type_or_name'";
+
+    while ( $current = $current->parent ) {
+        return $option_type_map{$current->name}
+            if exists $option_type_map{$current->name};
     }
 
     return;
@@ -57,60 +74,31 @@ sub add_option_type_to_map {
     my (undef, $type_name, $option_string) = @_;
     (defined $type_name && defined $option_string)
         || confess "You must supply both a type name and an option string";
-    (find_type_constraint($type_name))
-        || confess "The type constraint '$type_name' does not exist";
-    $option_type_map{$type_name} = $option_string;
-}
-
-no Moose; no Moose::Util::TypeConstraints; 1;
-
-__END__
 
+    if ( blessed($type_name) ) {
+        $type_name = $type_name->name;
+    } else {
+        (find_type_constraint($type_name))
+            || confess "The type constraint '$type_name' does not exist";
+    }
 
-=pod
+    $option_type_map{$type_name} = $option_string;
+}
 
-=head1 NAME
+no Moose::Util::TypeConstraints;
+no Moose;
 
-MooseX::Getopt::OptionTypeMap - Storage for the option to type mappings
+1;
 
 =head1 DESCRIPTION
 
 See the I<Custom Type Constraints> section in the L<MooseX::Getopt> docs
 for more info about how to use this module.
 
-=head1 METHODS
-
-These are all class methods and should be called as such.
-
-=over 4
-
-=item B<has_option_type ($type_name)>
-
-=item B<get_option_type ($type_name)>
-
-=item B<add_option_type_to_map ($type_name, $option_spec)>
-
-=item B<meta>
-
-=back
-
-=head1 BUGS
-
-All complex software has bugs lurking in it, and this module is no 
-exception. If you find a bug please either email me, or add the bug
-to cpan-RT.
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2007-2008 by Infinity Interactive, Inc.
+=method B<has_option_type ($type_or_name)>
 
-L<http://www.iinteractive.com>
+=method B<get_option_type ($type_or_name)>
 
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+=method B<add_option_type_to_map ($type_name, $option_spec)>
 
 =cut