Initial Commit

database/perl/vendor/lib/AppConfig/Getopt.pm

@@ -0,0 +1,271 @@
+#============================================================================
+#
+# AppConfig::Getopt.pm
+#
+# Perl5 module to interface AppConfig::* to Johan Vromans' Getopt::Long
+# module.  Getopt::Long implements the POSIX standard for command line
+# options, with GNU extensions, and also traditional one-letter options.
+# AppConfig::Getopt constructs the necessary Getopt:::Long configuration
+# from the internal AppConfig::State and delegates the parsing of command
+# line arguments to it.  Internal variable values are updated by callback
+# from GetOptions().
+# 
+# Written by Andy Wardley <abw@wardley.org>
+#
+# Copyright (C) 1997-2007 Andy Wardley.  All Rights Reserved.
+# Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
+#
+#============================================================================
+
+package AppConfig::Getopt;
+use 5.006;
+use strict;
+use warnings;
+use AppConfig::State;
+use Getopt::Long 2.17;
+our $VERSION = '1.71';
+
+
+#------------------------------------------------------------------------
+# new($state, \@args)
+#
+# Module constructor.  The first, mandatory parameter should be a 
+# reference to an AppConfig::State object to which all actions should 
+# be applied.  The second parameter may be a reference to a list of 
+# command line arguments.  This list reference is passed to parse() for
+# processing.
+#
+# Returns a reference to a newly created AppConfig::Getopt object.
+#------------------------------------------------------------------------
+
+sub new {
+    my $class = shift;
+    my $state = shift;
+    my $self = {
+        STATE => $state,
+   };
+
+    bless $self, $class;
+
+    # call parse() to parse any arg list passed 
+    $self->parse(@_)
+        if @_;
+
+    return $self;
+}
+
+
+#------------------------------------------------------------------------
+# parse(@$config, \@args)
+#
+# Constructs the appropriate configuration information and then delegates
+# the task of processing command line options to Getopt::Long.
+#
+# Returns 1 on success or 0 if one or more warnings were raised.
+#------------------------------------------------------------------------
+
+sub parse {
+    my $self  = shift;
+    my $state = $self->{ STATE };
+    my (@config, $args, $getopt);
+
+    local $" = ', ';
+
+    # we trap $SIG{__WARN__} errors and patch them into AppConfig::State
+    local $SIG{__WARN__} = sub {
+        my $msg = shift;
+
+        # AppConfig::State doesn't expect CR terminated error messages
+        # and it uses printf, so we protect any embedded '%' chars 
+        chomp($msg);
+        $state->_error("%s", $msg);
+    };
+
+    # slurp all config items into @config
+    push(@config, shift) while defined $_[0] && ! ref($_[0]);   
+
+    # add debug status if appropriate (hmm...can't decide about this)
+#    push(@config, 'debug') if $state->_debug();
+
+    # next parameter may be a reference to a list of args
+    $args = shift;
+
+    # copy any args explicitly specified into @ARGV
+    @ARGV = @$args if defined $args;
+
+    # we enclose in an eval block because constructor may die()
+    eval {
+        # configure Getopt::Long
+        Getopt::Long::Configure(@config);
+
+        # construct options list from AppConfig::State variables
+        my @opts = $self->{ STATE   }->_getopt_state();
+
+        # DEBUG
+        if ($state->_debug()) {
+            print STDERR "Calling GetOptions(@opts)\n";
+            print STDERR "\@ARGV = (@ARGV)\n";
+        };
+
+        # call GetOptions() with specifications constructed from the state
+        $getopt = GetOptions(@opts);
+    };
+    if ($@) {
+        chomp($@);
+        $state->_error("%s", $@);
+        return 0;
+    }
+
+    # udpdate any args reference passed to include only that which is left 
+    # in @ARGV
+    @$args = @ARGV if defined $args;
+
+    return $getopt;
+}
+
+
+#========================================================================
+# AppConfig::State
+#========================================================================
+
+package AppConfig::State;
+
+#------------------------------------------------------------------------
+# _getopt_state()
+#
+# Constructs option specs in the Getopt::Long format for each variable 
+# definition.
+#
+# Returns a list of specification strings.
+#------------------------------------------------------------------------
+
+sub _getopt_state {
+    my $self = shift;
+    my ($var, $spec, $args, $argcount, @specs);
+
+    my $linkage = sub { $self->set(@_) };
+
+    foreach $var (keys %{ $self->{ VARIABLE } }) {
+        $spec  = join('|', $var, @{ $self->{ ALIASES }->{ $var } || [ ] });
+
+        # an ARGS value is used, if specified
+        unless (defined ($args = $self->{ ARGS }->{ $var })) {
+            # otherwise, construct a basic one from ARGCOUNT
+            ARGCOUNT: {
+                last ARGCOUNT unless 
+                    defined ($argcount = $self->{ ARGCOUNT }->{ $var });
+
+                $args = "=s",  last ARGCOUNT if $argcount eq ARGCOUNT_ONE;
+                $args = "=s@", last ARGCOUNT if $argcount eq ARGCOUNT_LIST;
+                $args = "=s%", last ARGCOUNT if $argcount eq ARGCOUNT_HASH;
+                $args = "!";
+            }
+        }
+        $spec .= $args if defined $args;
+
+        push(@specs, $spec, $linkage);
+    }
+
+    return @specs;
+}
+
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+AppConfig::Getopt - Perl5 module for processing command line arguments via delegation to Getopt::Long.
+
+=head1 SYNOPSIS
+
+    use AppConfig::Getopt;
+
+    my $state  = AppConfig::State->new(\%cfg);
+    my $getopt = AppConfig::Getopt->new($state);
+
+    $getopt->parse(\@args);            # read args
+
+=head1 OVERVIEW
+
+AppConfig::Getopt is a Perl5 module which delegates to Johan Vroman's
+Getopt::Long module to parse command line arguments and update values 
+in an AppConfig::State object accordingly.
+
+AppConfig::Getopt is distributed as part of the AppConfig bundle.
+
+=head1 DESCRIPTION
+
+=head2 USING THE AppConfig::Getopt MODULE
+
+To import and use the AppConfig::Getopt module the following line should appear
+in your Perl script:
+
+    use AppConfig::Getopt;
+
+AppConfig::Getopt is used automatically if you use the AppConfig module 
+and create an AppConfig::Getopt object through the getopt() method.
+
+AppConfig::Getopt is implemented using object-oriented methods.  A new 
+AppConfig::Getopt object is created and initialised using the new() method.
+This returns a reference to a new AppConfig::Getopt object.  A reference to
+an AppConfig::State object should be passed in as the first parameter:
+
+    my $state  = AppConfig::State->new();
+    my $getopt = AppConfig::Getopt->new($state);
+
+This will create and return a reference to a new AppConfig::Getopt object. 
+
+=head2 PARSING COMMAND LINE ARGUMENTS
+
+The C<parse()> method is used to read a list of command line arguments and 
+update the state accordingly.  
+
+The first (non-list reference) parameters may contain a number of 
+configuration strings to pass to Getopt::Long::Configure.  A reference 
+to a list of arguments may additionally be passed or @ARGV is used by 
+default.
+
+    $getopt->parse();                       # uses @ARGV
+    $getopt->parse(\@myargs);
+    $getopt->parse(qw(auto_abbrev debug));  # uses @ARGV
+    $getopt->parse(qw(debug), \@myargs);
+
+See Getopt::Long for details of the configuartion options available.
+
+A Getopt::Long specification string is constructed for each variable 
+defined in the AppConfig::State.  This consists of the name, any aliases
+and the ARGS value for the variable.
+
+These specification string are then passed to Getopt::Long, the arguments
+are parsed and the values in the AppConfig::State updated.
+
+See AppConfig for information about using the AppConfig::Getopt
+module via the getopt() method.
+
+=head1 AUTHOR
+
+Andy Wardley, E<lt>abw@wardley.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (C) 1997-2007 Andy Wardley.  All Rights Reserved.
+
+Copyright (C) 1997,1998 Canon Research Centre Europe Ltd.
+
+This module is free software; you can redistribute it and/or modify it 
+under the same terms as Perl itself.
+
+=head1 ACKNOWLEDGMENTS
+
+Many thanks are due to Johan Vromans for the Getopt::Long module.  He was 
+kind enough to offer assistance and access to early releases of his code to 
+enable this module to be written.
+
+=head1 SEE ALSO
+
+AppConfig, AppConfig::State, AppConfig::Args, Getopt::Long
+
+=cut