lib/MooseX/Getopt/GLD.pm

   1
   2 package MooseX::Getopt::GLD;
   3 use Moose::Role;
   4
   5 use Getopt::Long::Descriptive;
   6
   7 with 'MooseX::Getopt::Basic';
   8
   9 around _getopt_spec => sub {
  10     shift;
  11     shift->_gld_spec(@_);
  12 };
  13
  14 around _getopt_get_options => sub {
  15     shift;
  16     my ($class, $params, $opt_spec) = @_;
  17     return Getopt::Long::Descriptive::describe_options($class->_usage_format(%$params), @$opt_spec);
  18 };
  19
  20 sub _gld_spec {
  21     my ( $class, %params ) = @_;
  22
  23     my ( @options, %name_to_init_arg );
  24
  25     my $constructor_params = $params{params};
  26
  27     foreach my $opt ( @{ $params{options} } ) {
  28         push @options, [
  29             $opt->{opt_string},
  30             $opt->{doc} || ' ', # FIXME new GLD shouldn't need this hack
  31             {
  32                 ( ( $opt->{required} && !exists($constructor_params->{$opt->{init_arg}}) ) ? (required => $opt->{required}) : () ),
  33                 # NOTE:
  34                 # remove this 'feature' because it didn't work
  35                 # all the time, and so is better to not bother
  36                 # since Moose will handle the defaults just
  37                 # fine anyway.
  38                 # - SL
  39                 #( exists $opt->{default}  ? (default  => $opt->{default})  : () ),
  40             },
  41         ];
  42
  43         my $identifier = lc($opt->{name});
  44         $identifier =~ s/\W/_/g; # Getopt::Long does this to all option names
  45
  46         $name_to_init_arg{$identifier} = $opt->{init_arg};
  47     }
  48
  49     return ( \@options, \%name_to_init_arg );
  50 }
  51
  52 no Moose::Role; 1;
  53
  54 __END__
  55
  56 =pod
  57
  58 =head1 NAME
  59
  60 MooseX::Getopt::GLD - A Moose role for processing command line options with Getopt::Long::Descriptive
  61
  62 =head1 SYNOPSIS
  63
  64   ## In your class
  65   package My::App;
  66   use Moose;
  67
  68   with 'MooseX::Getopt::GLD';
  69
  70   has 'out' => (is => 'rw', isa => 'Str', required => 1);
  71   has 'in'  => (is => 'rw', isa => 'Str', required => 1);
  72
  73   # ... rest of the class here
  74
  75   ## in your script
  76   #!/usr/bin/perl
  77
  78   use My::App;
  79
  80   my $app = My::App->new_with_options();
  81   # ... rest of the script here
  82
  83   ## on the command line
  84   % perl my_app_script.pl -in file.input -out file.dump
  85
  86 =head1 DESCRIPTION
  87
  88 =head1 COPYRIGHT AND LICENSE
  89
  90 Copyright 2007-2009 by Infinity Interactive, Inc.
  91
  92 L<http://www.iinteractive.com>
  93
  94 This library is free software; you can redistribute it and/or modify
  95 it under the same terms as Perl itself.
  96
  97 =cut