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