lib/MooseX/Getopt/OptionTypeMap.pm

   1
   2 package MooseX::Getopt::OptionTypeMap;
   3
   4 use Moose 'confess', 'blessed';
   5 use Moose::Util::TypeConstraints 'find_type_constraint';
   6
   7 our $VERSION   = '0.17';
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 my %option_type_map = (
  11     'Bool'     => '!',
  12     'Str'      => '=s',
  13     'Int'      => '=i',
  14     'Num'      => '=f',
  15     'ArrayRef' => '=s@',
  16     'HashRef'  => '=s%',
  17 );
  18
  19 sub has_option_type {
  20     my (undef, $type_or_name) = @_;
  21
  22     return 1 if exists $option_type_map{blessed($type_or_name) ? $type_or_name->name : $type_or_name};
  23
  24     my $current = blessed($type_or_name) ? $type_or_name : find_type_constraint($type_or_name);
  25
  26     (defined $current)
  27         || confess "Could not find the type constraint for '$type_or_name'";
  28
  29     while (my $parent = $current->parent) {
  30         return 1 if exists $option_type_map{$parent->name};
  31         $current = $parent;
  32     }
  33
  34     return 0;
  35 }
  36
  37 sub get_option_type {
  38     my (undef, $type_or_name) = @_;
  39
  40     my $name = blessed($type_or_name) ? $type_or_name->name : $type_or_name;
  41
  42     return $option_type_map{$name} if exists $option_type_map{$name};
  43
  44     my $current = ref $type_or_name ? $type_or_name : find_type_constraint($type_or_name);
  45
  46     (defined $current)
  47         || confess "Could not find the type constraint for '$type_or_name'";
  48
  49     while ( $current = $current->parent ) {
  50         return $option_type_map{$current->name}
  51             if exists $option_type_map{$current->name};
  52     }
  53
  54     return;
  55 }
  56
  57 sub add_option_type_to_map {
  58     my (undef, $type_name, $option_string) = @_;
  59     (defined $type_name && defined $option_string)
  60         || confess "You must supply both a type name and an option string";
  61
  62     if ( blessed($type_name) ) {
  63         $type_name = $type_name->name;
  64     } else {
  65         (find_type_constraint($type_name))
  66             || confess "The type constraint '$type_name' does not exist";
  67     }
  68
  69     $option_type_map{$type_name} = $option_string;
  70 }
  71
  72 no Moose; no Moose::Util::TypeConstraints; 1;
  73
  74 __END__
  75
  76
  77 =pod
  78
  79 =head1 NAME
  80
  81 MooseX::Getopt::OptionTypeMap - Storage for the option to type mappings
  82
  83 =head1 DESCRIPTION
  84
  85 See the I<Custom Type Constraints> section in the L<MooseX::Getopt> docs
  86 for more info about how to use this module.
  87
  88 =head1 METHODS
  89
  90 These are all class methods and should be called as such.
  91
  92 =over 4
  93
  94 =item B<has_option_type ($type_or_name)>
  95
  96 =item B<get_option_type ($type_or_name)>
  97
  98 =item B<add_option_type_to_map ($type_name, $option_spec)>
  99
 100 =item B<meta>
 101
 102 =back
 103
 104 =head1 BUGS
 105
 106 All complex software has bugs lurking in it, and this module is no
 107 exception. If you find a bug please either email me, or add the bug
 108 to cpan-RT.
 109
 110 =head1 AUTHOR
 111
 112 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 113
 114 =head1 COPYRIGHT AND LICENSE
 115
 116 Copyright 2007-2008 by Infinity Interactive, Inc.
 117
 118 L<http://www.iinteractive.com>
 119
 120 This library is free software; you can redistribute it and/or modify
 121 it under the same terms as Perl itself.
 122
 123 =cut