local-lib5/lib/perl5/AppConfig/Getopt.pm

   1 #============================================================================
   2 #
   3 # AppConfig::Getopt.pm
   4 #
   5 # Perl5 module to interface AppConfig::* to Johan Vromans' Getopt::Long
   6 # module.  Getopt::Long implements the POSIX standard for command line
   7 # options, with GNU extensions, and also traditional one-letter options.
   8 # AppConfig::Getopt constructs the necessary Getopt:::Long configuration
   9 # from the internal AppConfig::State and delegates the parsing of command
  10 # line arguments to it.  Internal variable values are updated by callback
  11 # from GetOptions().
  12 #
  13 # Written by Andy Wardley <abw@wardley.org>
  14 #
  15 # Copyright (C) 1997-2007 Andy Wardley.  All Rights Reserved.
  16 # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
  17 #
  18 #============================================================================
  19
  20 package AppConfig::Getopt;
  21 use strict;
  22 use warnings;
  23 use AppConfig::State;
  24 use Getopt::Long 2.17;
  25 our $VERSION = '1.65';
  26
  27
  28 #------------------------------------------------------------------------
  29 # new($state, \@args)
  30 #
  31 # Module constructor.  The first, mandatory parameter should be a
  32 # reference to an AppConfig::State object to which all actions should
  33 # be applied.  The second parameter may be a reference to a list of
  34 # command line arguments.  This list reference is passed to parse() for
  35 # processing.
  36 #
  37 # Returns a reference to a newly created AppConfig::Getopt object.
  38 #------------------------------------------------------------------------
  39
  40 sub new {
  41     my $class = shift;
  42     my $state = shift;
  43     my $self = {
  44         STATE => $state,
  45    };
  46
  47     bless $self, $class;
  48
  49     # call parse() to parse any arg list passed
  50     $self->parse(@_)
  51         if @_;
  52
  53     return $self;
  54 }
  55
  56
  57 #------------------------------------------------------------------------
  58 # parse(@$config, \@args)
  59 #
  60 # Constructs the appropriate configuration information and then delegates
  61 # the task of processing command line options to Getopt::Long.
  62 #
  63 # Returns 1 on success or 0 if one or more warnings were raised.
  64 #------------------------------------------------------------------------
  65
  66 sub parse {
  67     my $self  = shift;
  68     my $state = $self->{ STATE };
  69     my (@config, $args, $getopt);
  70
  71     local $" = ', ';
  72
  73     # we trap $SIG{__WARN__} errors and patch them into AppConfig::State
  74     local $SIG{__WARN__} = sub {
  75         my $msg = shift;
  76
  77         # AppConfig::State doesn't expect CR terminated error messages
  78         # and it uses printf, so we protect any embedded '%' chars
  79         chomp($msg);
  80         $state->_error("%s", $msg);
  81     };
  82
  83     # slurp all config items into @config
  84     push(@config, shift) while defined $_[0] && ! ref($_[0]);
  85
  86     # add debug status if appropriate (hmm...can't decide about this)
  87 #    push(@config, 'debug') if $state->_debug();
  88
  89     # next parameter may be a reference to a list of args
  90     $args = shift;
  91
  92     # copy any args explicitly specified into @ARGV
  93     @ARGV = @$args if defined $args;
  94
  95     # we enclose in an eval block because constructor may die()
  96     eval {
  97         # configure Getopt::Long
  98         Getopt::Long::Configure(@config);
  99
 100         # construct options list from AppConfig::State variables
 101         my @opts = $self->{ STATE   }->_getopt_state();
 102
 103         # DEBUG
 104         if ($state->_debug()) {
 105             print STDERR "Calling GetOptions(@opts)\n";
 106             print STDERR "\@ARGV = (@ARGV)\n";
 107         };
 108
 109         # call GetOptions() with specifications constructed from the state
 110         $getopt = GetOptions(@opts);
 111     };
 112     if ($@) {
 113         chomp($@);
 114         $state->_error("%s", $@);
 115         return 0;
 116     }
 117
 118     # udpdate any args reference passed to include only that which is left
 119     # in @ARGV
 120     @$args = @ARGV if defined $args;
 121
 122     return $getopt;
 123 }
 124
 125
 126 #========================================================================
 127 # AppConfig::State
 128 #========================================================================
 129
 130 package AppConfig::State;
 131
 132 #------------------------------------------------------------------------
 133 # _getopt_state()
 134 #
 135 # Constructs option specs in the Getopt::Long format for each variable
 136 # definition.
 137 #
 138 # Returns a list of specification strings.
 139 #------------------------------------------------------------------------
 140
 141 sub _getopt_state {
 142     my $self = shift;
 143     my ($var, $spec, $args, $argcount, @specs);
 144
 145     my $linkage = sub { $self->set(@_) };
 146
 147     foreach $var (keys %{ $self->{ VARIABLE } }) {
 148         $spec  = join('|', $var, @{ $self->{ ALIASES }->{ $var } || [ ] });
 149
 150         # an ARGS value is used, if specified
 151         unless (defined ($args = $self->{ ARGS }->{ $var })) {
 152             # otherwise, construct a basic one from ARGCOUNT
 153             ARGCOUNT: {
 154                 last ARGCOUNT unless
 155                     defined ($argcount = $self->{ ARGCOUNT }->{ $var });
 156
 157                 $args = "=s",  last ARGCOUNT if $argcount eq ARGCOUNT_ONE;
 158                 $args = "=s@", last ARGCOUNT if $argcount eq ARGCOUNT_LIST;
 159                 $args = "=s%", last ARGCOUNT if $argcount eq ARGCOUNT_HASH;
 160                 $args = "!";
 161             }
 162         }
 163         $spec .= $args if defined $args;
 164
 165         push(@specs, $spec, $linkage);
 166     }
 167
 168     return @specs;
 169 }
 170
 171
 172
 173 1;
 174
 175 __END__
 176
 177 =head1 NAME
 178
 179 AppConfig::Getopt - Perl5 module for processing command line arguments via delegation to Getopt::Long.
 180
 181 =head1 SYNOPSIS
 182
 183     use AppConfig::Getopt;
 184
 185     my $state  = AppConfig::State->new(\%cfg);
 186     my $getopt = AppConfig::Getopt->new($state);
 187
 188     $getopt->parse(\@args);            # read args
 189
 190 =head1 OVERVIEW
 191
 192 AppConfig::Getopt is a Perl5 module which delegates to Johan Vroman's
 193 Getopt::Long module to parse command line arguments and update values
 194 in an AppConfig::State object accordingly.
 195
 196 AppConfig::Getopt is distributed as part of the AppConfig bundle.
 197
 198 =head1 DESCRIPTION
 199
 200 =head2 USING THE AppConfig::Getopt MODULE
 201
 202 To import and use the AppConfig::Getopt module the following line should appear
 203 in your Perl script:
 204
 205     use AppConfig::Getopt;
 206
 207 AppConfig::Getopt is used automatically if you use the AppConfig module
 208 and create an AppConfig::Getopt object through the getopt() method.
 209
 210 AppConfig::Getopt is implemented using object-oriented methods.  A new
 211 AppConfig::Getopt object is created and initialised using the new() method.
 212 This returns a reference to a new AppConfig::Getopt object.  A reference to
 213 an AppConfig::State object should be passed in as the first parameter:
 214
 215     my $state  = AppConfig::State->new();
 216     my $getopt = AppConfig::Getopt->new($state);
 217
 218 This will create and return a reference to a new AppConfig::Getopt object.
 219
 220 =head2 PARSING COMMAND LINE ARGUMENTS
 221
 222 The C<parse()> method is used to read a list of command line arguments and
 223 update the state accordingly.
 224
 225 The first (non-list reference) parameters may contain a number of
 226 configuration strings to pass to Getopt::Long::Configure.  A reference
 227 to a list of arguments may additionally be passed or @ARGV is used by
 228 default.
 229
 230     $getopt->parse();                       # uses @ARGV
 231     $getopt->parse(\@myargs);
 232     $getopt->parse(qw(auto_abbrev debug));  # uses @ARGV
 233     $getopt->parse(qw(debug), \@myargs);
 234
 235 See Getopt::Long for details of the configuartion options available.
 236
 237 A Getopt::Long specification string is constructed for each variable
 238 defined in the AppConfig::State.  This consists of the name, any aliases
 239 and the ARGS value for the variable.
 240
 241 These specification string are then passed to Getopt::Long, the arguments
 242 are parsed and the values in the AppConfig::State updated.
 243
 244 See AppConfig for information about using the AppConfig::Getopt
 245 module via the getopt() method.
 246
 247 =head1 AUTHOR
 248
 249 Andy Wardley, E<lt>abw@wardley.orgE<gt>
 250
 251 =head1 COPYRIGHT
 252
 253 Copyright (C) 1997-2007 Andy Wardley.  All Rights Reserved.
 254
 255 Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
 256
 257 This module is free software; you can redistribute it and/or modify it
 258 under the same terms as Perl itself.
 259
 260 =head1 ACKNOWLEDGMENTS
 261
 262 Many thanks are due to Johan Vromans for the Getopt::Long module.  He was
 263 kind enough to offer assistance and access to early releases of his code to
 264 enable this module to be written.
 265
 266 =head1 SEE ALSO
 267
 268 AppConfig, AppConfig::State, AppConfig::Args, Getopt::Long
 269
 270 =cut