lib/MooseX/Getopt/Session.pm

   1
   2 package MooseX::Getopt::Session;
   3
   4 use Moose;
   5
   6 use MooseX::Getopt::Parser::Default;
   7
   8
   9 use constant _default_getopt_parser => 'MooseX::Getopt::Parser::Default';
  10
  11
  12 # Pluggined MooseX::Getopt::Parser parser
  13 has parser => (
  14     is      => 'rw',
  15     does    => 'MooseX::Getopt::Parser',
  16     default => sub { $_[0]->_default_getopt_parser->new },
  17 );
  18
  19 # Filter for classes which are searched for getopt trait
  20 has classes_filter => (
  21     is      => 'rw',
  22     isa     => 'CodeRef',
  23     default => sub { sub { 1; } },
  24 );
  25
  26 # Original @ARGV values
  27 has ARGV => (
  28     is      => 'rw',
  29     isa     => 'ArrayRef[Str]',
  30     default => sub { [@ARGV] },
  31 );
  32
  33 # Unrecognized @ARGV values
  34 has extra_argv => (
  35     is      => 'rw',
  36     isa     => 'ArrayRef[Str]',
  37     default => sub { [] },
  38 );
  39
  40 # Hash with options parsed from argv
  41 has options => (
  42     is      => 'rw',
  43     isa     => 'HashRef',
  44     default => sub { {} },
  45 );
  46
  47 # Status returned by Getopt parser
  48 has status => (
  49     is        => 'rw',
  50     isa       => 'Bool',
  51     predicate => 'has_status',
  52 );
  53
  54
  55 sub build_options {
  56     my ($self) = @_;
  57
  58     my @attrs = map { $_->_compute_getopt_attrs } $self->_compute_getopt_classes;
  59
  60     return $self->parser->build_options( $self, @attrs );
  61 };
  62
  63
  64 sub _compute_getopt_classes {
  65     my $self = shift;
  66
  67     return grep {
  68         $self->classes_filter->()
  69     } grep {
  70         $_->isa('Moose::Object') && $_->does('MooseX::Getopt')
  71     } Class::MOP->get_all_metaclasses;
  72 };
  73
  74
  75 sub _get_cmd_flags_for_attr {
  76     my ( $self, $attr ) = @_;
  77
  78     my $flag = $attr->name;
  79
  80     my @aliases;
  81
  82     if ( $attr->does('MooseX::Getopt::Meta::Attribute::Trait') ) {
  83         $flag    = $attr->cmd_flag         if $attr->has_cmd_flag;
  84         @aliases = @{ $attr->cmd_aliases } if $attr->has_cmd_aliases;
  85     };
  86
  87     return ( $flag, @aliases );
  88 };
  89
  90
  91 sub _get_cmd_type_for_attr {
  92     my ( $self, $attr ) = @_;
  93
  94     my $type;
  95
  96     $type = $attr->type_constraint if $attr->has_type_constraint;
  97
  98     if ( $attr->does('MooseX::Getopt::Meta::Attribute::Trait') ) {
  99         $type = $attr->cmd_type if $attr->has_cmd_type;
 100     };
 101
 102     return $type;
 103 };
 104
 105
 106 1;
 107
 108
 109 __END__
 110
 111 =pod
 112
 113 =head1 NAME
 114
 115 MooseX::Getopt::Session - A CLI session for MooseX::Getopt
 116
 117 =head1 SYNOPSIS
 118
 119   ## in your script
 120   #!/usr/bin/perl
 121
 122   use My::App;
 123
 124   my $getopt = MooseX::Getopt::Session->new;
 125
 126   my $app = My::App->new_with_options( getopt => $getopt );
 127   my $cmd = My::App::Cmd->new_with_options( getopt => $getopt );
 128
 129 =head1 DESCRIPTION
 130
 131 This class handles CLI session for L<MooseX::Getopt>.  The session can
 132 be shared between more than one classes which does L<MooseX::Getopt>.
 133 If C<getopt> parameter is missing, new session is created for one class.
 134
 135 The L<MooseX::Getopt::Session> scans all classes and gets these which do
 136 L<MooseX::Getopt>.  These classes will make an option list for
 137 L<MooseX::Getopt::Parser>.
 138
 139 =head1 METHODS
 140
 141 =over 4
 142
 143 =item B<new (%params)>
 144
 145 This method creates new CLI session object for L<MooseX::Getopt>.  The
 146 session should be started with C<build_options> method.
 147
 148 =item B<build_options>
 149
 150 This method creates the list of attributes which contains options and
 151 calls C<build_options> method from L<MooseX::Getopt::Parser> with this
 152 object and attributes list as parameters.
 153
 154 =item B<parser>
 155
 156 This accessor contains a parser object which does
 157 L<MooseX::Getopt::Parser>.  It can be set explicite, i.e. if you need to
 158 modify the way parser works, or new object via
 159 L<MooseX::Getopt::Parser::Default> factory will be created.
 160
 161 =item B<classes_filter>
 162
 163 This accessor contains a coderef with classes filter which is used for
 164 searching proper classes to create options list.  The filter passes any
 165 class by default but L<MooseX::Getopt> will search the attributes only
 166 in own class, if new session is created implicity.
 167
 168 =item B<ARGV>
 169
 170 This accessor contains a reference to a copy of the C<@ARGV> array as it
 171 originally existed at the time of C<new_with_options>.
 172
 173 =item B<extra_argv>
 174
 175 This accessor contains an arrayref of leftover C<@ARGV> elements that
 176 L<Getopt::Long> did not parse.  Note that the real C<@ARGV> is left
 177 un-mangled.
 178
 179 =item B<options>
 180
 181 This accessor contains an arrayref of options parsed from command line by
 182 L<MooseX::Getopt::Parser>.  If the options list are not empty before parsing
 183 the command line, the old list will be included to new list.
 184
 185 =item B<status>
 186
 187 This accessor contains a true value if L<MooseX::Getopt::Parser> was
 188 called via C<build_options> method and it succeeded.
 189
 190 =item B<meta>
 191
 192 This returns the role meta object.
 193
 194 =back
 195
 196 =head1 SEE ALSO
 197
 198 =over 4
 199
 200 =item L<MooseX::Getopt>
 201
 202 =item L<MooseX::Getopt::Parser>
 203
 204 =back
 205
 206 =head1 BUGS
 207
 208 All complex software has bugs lurking in it, and this module is no
 209 exception. If you find a bug please either email me, or add the bug
 210 to cpan-RT.
 211
 212 =head1 AUTHOR
 213
 214 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 215
 216 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 217
 218 Yuval Kogman, E<lt>nothingmuch@woobling.orgE<gt>
 219
 220 Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
 221
 222 =head1 CONTRIBUTORS
 223
 224 Ryan D Johnson, E<lt>ryan@innerfence.comE<gt>
 225
 226 =head1 COPYRIGHT AND LICENSE
 227
 228 Copyright 2007-2008 by Infinity Interactive, Inc.
 229
 230 L<http://www.iinteractive.com>
 231
 232 This library is free software; you can redistribute it and/or modify
 233 it under the same terms as Perl itself.
 234
 235 =cut