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 __END__
 109
 110 =pod
 111
 112 =head1 NAME
 113
 114 MooseX::Getopt::Session - A CLI session for MooseX::Getopt
 115
 116 =head1 SYNOPSIS
 117
 118   ## in your script
 119   #!/usr/bin/perl
 120
 121   use My::App;
 122
 123   my $getopt = MooseX::Getopt::Session->new;
 124
 125   my $app = My::App->new_with_options( getopt => $getopt );
 126   my $cmd = My::App::Cmd->new_with_options( getopt => $getopt );
 127
 128 =head1 DESCRIPTION
 129
 130 This class handles CLI session for L<MooseX::Getopt>.  The session can
 131 be shared between more than one classes which does L<MooseX::Getopt>.
 132 If C<getopt> parameter is missing, new session is created for one class.
 133
 134 The L<MooseX::Getopt::Session> scans all classes and gets these which do
 135 L<MooseX::Getopt>.  These classes will make an option list for
 136 L<MooseX::Getopt::Parser>.
 137
 138 =head1 METHODS
 139
 140 =over 4
 141
 142 =item B<new (%params)>
 143
 144 This method creates new CLI session object for L<MooseX::Getopt>.  The
 145 session should be started with C<build_options> method.
 146
 147 =item B<build_options>
 148
 149 This method creates the list of attributes which contains options and
 150 calls C<build_options> method from L<MooseX::Getopt::Parser> with this
 151 object and attributes list as parameters.
 152
 153 =item B<parser>
 154
 155 This accessor contains a parser object which does
 156 L<MooseX::Getopt::Parser>.  It can be set explicite, i.e. if you need to
 157 modify the way parser works, or new object via
 158 L<MooseX::Getopt::Parser::Default> factory will be created.
 159
 160 =item B<classes_filter>
 161
 162 This accessor contains a coderef with classes filter which is used for
 163 searching proper classes to create options list.  The filter passes any
 164 class by default but L<MooseX::Getopt> will search the attributes only
 165 in own class, if new session is created implicity.
 166
 167 =item B<ARGV>
 168
 169 This accessor contains a reference to a copy of the C<@ARGV> array as it
 170 originally existed at the time of C<new_with_options>.
 171
 172 =item B<extra_argv>
 173
 174 This accessor contains an arrayref of leftover C<@ARGV> elements that
 175 L<Getopt::Long> did not parse.  Note that the real C<@ARGV> is left
 176 un-mangled.
 177
 178 =item B<options>
 179
 180 This accessor contains an arrayref of options parsed from command line by
 181 L<MooseX::Getopt::Parser>.  If the options list are not empty before parsing
 182 the command line, the old list will be included to new list.
 183
 184 =item B<status>
 185
 186 This accessor contains a true value if L<MooseX::Getopt::Parser> was
 187 called via C<build_options> method and it succeeded.
 188
 189 =item B<meta>
 190
 191 This returns the role meta object.
 192
 193 =back
 194
 195 =head1 SEE ALSO
 196
 197 =over 4
 198
 199 =item L<MooseX::Getopt>
 200
 201 =item L<MooseX::Getopt::Parser>
 202
 203 =back
 204
 205 =head1 BUGS
 206
 207 All complex software has bugs lurking in it, and this module is no
 208 exception. If you find a bug please either email me, or add the bug
 209 to cpan-RT.
 210
 211 =head1 AUTHOR
 212
 213 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 214
 215 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 216
 217 Yuval Kogman, E<lt>nothingmuch@woobling.orgE<gt>
 218
 219 =head1 CONTRIBUTORS
 220
 221 Ryan D Johnson, E<lt>ryan@innerfence.comE<gt>
 222
 223 Piotr Roszatycki, E<lt>dexter@cpan.orgE<gt>
 224
 225 =head1 COPYRIGHT AND LICENSE
 226
 227 Copyright 2007-2008 by Infinity Interactive, Inc.
 228
 229 L<http://www.iinteractive.com>
 230
 231 This library is free software; you can redistribute it and/or modify
 232 it under the same terms as Perl itself.
 233
 234 =cut