lib/MooseX/Getopt/GLD.pm

   1 package MooseX::Getopt::GLD;
   2
   3 use Moose::Role;
   4
   5 around '_getopt_spec' => sub {
   6     my $orig = shift;
   7     my $self = shift;
   8
   9     return $self->_gld_spec(@_);
  10     # Ignore $orig, code for _gld_spec here
  11 };
  12
  13 around '_get_options' => sub {
  14     my $orig = shift;
  15     my $class = shift;
  16
  17     my ($params, $opt_spec) = @_;
  18     return Getopt::Long::Descriptive::describe_options(
  19         $class->_usage_format(%$params), @$opt_spec
  20     );
  21 };
  22
  23
  24 sub _gld_spec {
  25     my ( $class, %params ) = @_;
  26
  27     my ( @options, %name_to_init_arg );
  28
  29     my $constructor_params = $params{params};
  30
  31     foreach my $opt ( @{ $params{options} } ) {
  32         push @options, [
  33             $opt->{opt_string},
  34             $opt->{doc} || ' ', # FIXME new GLD shouldn't need this hack
  35             {
  36                 ( ( $opt->{required} && !exists($constructor_params->{$opt->{init_arg}}) ) ? (required => $opt->{required}) : () ),
  37                 # NOTE:
  38                 # remove this 'feature' because it didn't work
  39                 # all the time, and so is better to not bother
  40                 # since Moose will handle the defaults just
  41                 # fine anyway.
  42                 # - SL
  43                 #( exists $opt->{default}  ? (default  => $opt->{default})  : () ),
  44             },
  45         ];
  46
  47         my $identifier = $opt->{name};
  48         $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names
  49
  50         $name_to_init_arg{$identifier} = $opt->{init_arg};
  51     }
  52
  53     return ( \@options, \%name_to_init_arg );
  54 }
  55
  56 1;
  57
  58 __END__
  59
  60 =pod
  61
  62 =head1 NAME
  63
  64 MooseX::Getopt::GLD - role to implement specific functionality for
  65 L<Getopt::Long::Descriptive>
  66
  67 =head1 SYNOPSIS
  68
  69 For internal use.
  70
  71 =head1 DESCRIPTION
  72
  73 This is a role for C<MooseX::Getopt>.
  74
  75 =head1 METHODS
  76
  77 =over 4
  78
  79 =item meta
  80
  81 =back
  82
  83 =head1 BUGS
  84
  85 All complex software has bugs lurking in it, and this module is no
  86 exception. If you find a bug please either email me, or add the bug
  87 to cpan-RT.
  88
  89 =head1 AUTHOR
  90
  91 Dagfinn Ilmari MannsE<aring>ker E<lt>ilmari@ilmari.orgE<gt>
  92
  93 Stevan Little E<lt>stevan@iinteractive.comE<gt>
  94
  95 Yuval Kogman  C<< <nuffin@cpan.org> >>
  96
  97 =head1 COPYRIGHT AND LICENSE
  98
  99 Copyright 2007-2008 by Infinity Interactive, Inc.
 100
 101 L<http://www.iinteractive.com>
 102
 103 This library is free software; you can redistribute it and/or modify
 104 it under the same terms as Perl itself.
 105
 106 =cut
 107 =head1