Getopt::Auto - Option framework for command-line applications
#! /usr/bin/perl
#===============================================================================
#
# FILE: Auto.pm
#
# USAGE: use Getopt::Auto
#
# DESCRIPTION: Processes the command line when your Perl script is executed,
# looking for the options you define in your POD.
#
# OPTIONS: --- None
# REQUIREMENTS: --- See Build.PL
# BUGS: --- Hah!
# AUTHOR: Geoffrey Leach (), geoff@hughes.net
# VERSION: 1.9.1
# REVISION: ---
#===============================================================================
# Copyright (C) 2003-2009, Simon Cozens
# Copyright (C) 2010, Geoffrey Leach
package Getopt::Auto;
use 5.006;
use strict;
use warnings;
use Carp;
use File::Basename;
use File::Spec::Functions;
use Readonly;
Readonly::Scalar my $SPACE => q{ };
Readonly::Scalar my $EMPTY => q{};
Readonly::Scalar my $DASH => q{-};
Readonly::Scalar my $DDASH => q{--};
Readonly::Scalar my $BARE => 0;
Readonly::Scalar my $SHORT => 1;
Readonly::Scalar my $LONG => 2;
Readonly::Array my @TYPES => qw( bare short long );
Readonly::Array my @PREFIXES => ( $EMPTY, $DASH, $DDASH );
our $VERSION = '1.9.1';
# Perlcritic complains about print to STDOUT. As this is merely for
# diagnostic purposes, it seems futile to fix them.
## no critic (RequireCheckedSyscalls)
# Initialized by import(), used throughout
# Successive calls to import add to it, allowing code to work off
# of a particular script or module
# Each element is a list of
# 0: [package, file], as returned by caller() in import()
# 1: The package's options hash, or main::options
# 2: Hash of controls as given in call of Getopt::Auto
# nobare, noshort, nolong, trace, init, findsub
my @callers;
# $caller is the current value of @callers when iterating and is
# used by subroutines that do not have a way to get it via a parameter
our $caller; ## no critic (ProhibitPackageVars)
# User-requested global behaviors
# 'test' is intentionally undocumented
# It is used to avoid exiting on errors for test purposes
my %config = (
'trace' => undef,
'noshort' => undef,
'nolong' => undef,
'nobare' => undef,
'nobundle' => undef,
'oknotreg' => undef,
'okerror' => undef,
'findsub' => undef,
'init' => undef,
'test' => undef,
);
my $errors = 0;
# CHECK is a specially-named block, that is executed by Perl at the _completion_ of compillation.
# This is critical, because _parse_pod() depends (indirectly, see Getopt::Auto::PodExtract)
# on the existence of subroutines to process the options. It's only executed _once_, however
# many times "use Getopt::Auto" has appeared. We've accumulated those packages; now we'll
# process them.
CHECK {
#$DB::single = 2; ## no critic (ProhibitPackageVars)
if ($errors) {
if ( not defined $config{'test'} ) { exit 1; }
}
_parse_pod();
}
# INIT is a specially-named block that is executed immediatly preceding the
# start of the program.
INIT {
#$DB::single = 2; ## no critic (ProhibitPackageVars)
_parse_args();
if ($errors) {
if ( ( not defined $config{'okerror'} )
&& ( not defined $config{'test'} ) )
{
exit 1;
}
}
}
# Executed when the Perl program is about to exit
# Retained for compabilility with V 1.0; I've no idea what it does
END {
if ( exists &main::default ) { main::default() }
}
# Please note: subroutine names that begin with an underscore are internal.
# Calling sequence and/or existence is not guaranteed for future versions.
my $their_version;
sub _set_their_version {
$their_version = shift;
return;
}
sub _get_their_version {
return $their_version;
}
# Carries the content of Getopt::Auto(...)
our @spec; ## no critic (ProhibitPackageVars)
Readonly::Scalar my $SPEC_NAME => 0;
Readonly::Scalar my $SPEC_SHORT => 1;
Readonly::Scalar my $SPEC_LONG => 2;
Readonly::Scalar my $SPEC_CODE => 3;
Readonly::Scalar my $SPEC_SIZE => 4;
sub _get_spec_ref {
return \@spec;
}
# Allows user to say what style to prefer
# Values are 'short', 'long', 'bare', default 'long' or 'undef' meaning use the POD;
my $help_p = $LONG;
my %options;
sub _test_option {
my $query = shift;
return exists $options{$query} && !_restricted($query);
}
sub _get_options_ref {
return \%options;
}
sub _trace {
if ( not defined $config{'trace'} ) {
return;
}
my $arg = shift;
chomp $arg;
print "$arg\n";
return;
}
sub _trace_spec {
if ( not defined $config{'trace'} ) {
return;
}
my $spec = shift;
print "Spec for $spec->[$SPEC_NAME]: ";
print length $spec->[$SPEC_SHORT]
? "$spec->[$SPEC_SHORT], "
: "no short help, ";
print defined $spec->[$SPEC_LONG]
? "$spec->[$SPEC_LONG], "
: "no long help, ";
print defined $spec->[$SPEC_CODE]
? "$spec->[$SPEC_CODE]"
: "no code";
print "\n";
return;
}
sub _trace_argv {
if ( not defined $config{'trace'} ) {
return;
}
_trace( 'ARGV now: (' . join( ', ', @ARGV ) . ')' );
return;
}
sub get_errors {
return $errors;
}
sub _error {
my $msg = shift;
print {*STDERR} 'Getopt::Auto: ', $msg, "\n";
$errors++;
return;
}
# Modifies $name to make it an acceptable subrotine name.
sub _clean_func {
my $func = shift;
$func =~ s{\A-+}{}smx;
$func =~ s{-}{_}smgx;
return $func;
}
# Checks $pkg to see if there's a subroutine $name.
# Return it if so.
sub _check_func {
my ( $name, $pkg ) = @_;
if ( not defined $caller ) {
return;
}
if ( not defined $pkg ) {
$pkg = qq{$caller->[0][0]::};
}
my $func = _clean_func($name);
if ( exists &{"$pkg$func"} ) {
_trace("For $name code is $func()");
_trace("$pkg$func exists");
no strict 'refs'; ## no critic (ProhibitNoStrict)
return *{"$pkg$func"}{'CODE'};
}
else {
_trace("There is no $pkg$func");
return;
}
return;
}
# Look in all packages for a sub $name. If so, return it
# and store it in %options for future use. Note that
# 'registered' is not set, do the option does not become.
sub _check_all_sub {
my $name = shift;
_trace("Checking for sub $name");
if ( ( exists $options{$name} )
and ( exists $options{$name}{'code'} ) )
{
return $options{$name}{'code'};
}
# Check in all packages
foreach my $caller_local (@callers) {
my $sub = _check_func( $name, qq{$caller_local->[0][0]::} );
if ( defined $sub ) {
$options{$name}{'code'} = $sub;
return $sub;
}
}
return;
}
sub _restricted {
my $arg = shift;
my $arg_type = _option_type($arg);
if (( ( $arg_type == $BARE ) && ( defined $config{'nobare'} ) )
|| ( ( $arg_type == $SHORT )
&& ( defined $config{'noshort'} ) )
|| ( ( $arg_type == $LONG )
&& ( defined $config{'nolong'} ) )
)
{
return 1;
}
return 0;
}
# The specs parameter is assumed to be a ref to a 4-element array
sub _load_options {
my ( $specs, $caller_local ) = @_;
foreach my $spec ( @{$specs} ) {
my $name = $spec->[$SPEC_NAME];
$options{$name}{'shorthelp'} = $spec->[$SPEC_SHORT];
$options{$name}{'longhelp'} = $spec->[$SPEC_LONG];
$options{$name}{'package'} = $caller_local->[0][0];
$options{$name}{'options'} = $caller_local->[1];
$options{$name}{'registered'} = 1;
# Avoid creating a code reference that's undefined
if ( defined $spec->[$SPEC_CODE] ) {
$options{$name}{'code'} = $spec->[$SPEC_CODE];
}
_trace_spec($spec);
}
return;
}
# Check a spec that's been given us by the user.
sub _check_spec {
my ( $spec_ref, $caller_local ) = @_;
foreach my $spec ( @{$spec_ref} ) {
# Each spec has the following members:
# The option name: we need to check it for consistency.
# The short help phrase, from the POD =item or =head
# The long help message, from the POD paragraph that follows
# The code (sub reference) to be called for the option
if ( not( ref $spec eq 'ARRAY' ) ) {
_error(qq{Option specification $spec must be a reference});
return;
}
if ( @{$spec} != $SPEC_SIZE ) {
_error(qq{Option list is incompletly specified});
return;
}
push @spec, $spec;
}
_load_options( \@spec, $caller_local );
return 1;
}
# Called by Perl at the time of processing 'use' but _not_ of processing 'require'
sub import {
my $class = shift; # Getopt::Auto
#$DB::single = 2; ## no critic (ProhibitPackageVars)
my @caller = caller;
pop @caller;
my $opt = "$caller[0]::options";
if ( not defined $opt ) {
# Which may not exist either, but that's OK.
$opt = q{main::options};
}
# So it's easy to turn off the trace from the environment
if ( exists $ENV{'GETOPT_AUTO_TRACE'} ) {
$config{'trace'} = $ENV{'GETOPT_AUTO_TRACE'} == 1 ? 1 : undef;
}
my $ctls;
while ( my $arg = shift ) {
if ( ref $arg eq 'HASH' ) {
foreach my $opt ( keys %{$arg} ) {
if ( exists $config{$opt} ) { $config{$opt} = 1; }
else {
_error(qq{Option '$opt' is unknown});
}
}
$ctls = $arg;
}
elsif ( ref $arg eq 'ARRAY' ) {
$ctls = {};
_check_spec( $arg, [ \@caller, $opt, $ctls ] );
}
else {
_error(
qq{Must be use-d with: no args, an HASH ref or an ARRAY ref}
);
return;
}
}
#$config{'trace'} = 1; # debugging
push @callers, [ \@caller, $opt, $ctls ];
_trace("Tracing ...");
_trace("Package: $callers[-1][0][0], File: $callers[-1][0][1]");
return;
}
sub _option_type {
my $option = shift;
return $LONG if not defined $option;
$option =~ m{\A$DDASH}smx and return $LONG;
$option =~ m{\A$DASH}smx and return $SHORT;
$option =~ m{\A\w}smx and return $BARE;
return $LONG;
}
sub _parse_pod {
foreach my $caller_local (@callers) {
# We're doing magic!
# Do the parsing. The -want_nonPODs causes Pod::Parser (the base) to
# call the preprocess_line sub with all input, so we can scan for
# an assignment to $VERSION. Overhead is negligable.
# The $caller global is used indirectly by PodExtract,
# via _check_func()
$caller = $caller_local;
my $pod = Getopt::Auto::PodExtract->new( -want_nonPODs => 1 );
my $filename
= File::Spec::Functions::rel2abs( $caller_local->[0][1] );
my ( $name, $path, $suffix )
= fileparse( $filename, qw( .t .pm .pl ) );
my @filenames = $filename;
# Add a possible POD extra file
push @filenames, "$path$name.pod";
foreach my $file (@filenames) {
_trace("Processing POD in: $file");
if ( not -r $file ) {
_trace("$file not readable");
next;
}
# Pod::Parser method that does the work,
# calling the functions that fill 'funcs'
$pod->parse_from_file( $file, '/dev/null' );
last if defined $pod->{'funcs'};
_trace("No POD in $file");
}
if ( not defined $pod->{'funcs'} ) {
# Strangely, this is OK. _parse_args checks for would-be option subs
_trace( "No POD in " . join $SPACE, @filenames );
return;
}
# Now move what the POD processing found into a useful format.
# Correction 1.9.0 => 1.9.1 courtesy of Bruce Gray
my @this_spec;
foreach my $n ( sort keys %{ $pod->{'funcs'} } ) {
my $spec = $pod->{'funcs'}{$n};
if ( exists $spec->{'longhelp'} ) {
$spec->{'longhelp'} =~ s{\n+\z}{\n}smx;
}
push @this_spec,
[
$n, $spec->{'shorthelp'},
$spec->{'longhelp'}, $spec->{'code'}
];
}
_load_options( \@this_spec, $caller_local );
# Global list '@spec' is assigned here
push @spec, @this_spec;
}
return;
}
sub _set_option {
my ( $arg, $caller_local ) = @_;
my ( $opt, $pkg );
# This is sort of backwards.
# If the arg is known to be a registered option,
# then we don't need the caller.
# Otherwise, $caller_local is used to determine options and package.
if ( defined $caller_local ) {
$opt = qq{$caller_local->[1]};
}
else {
$opt = $options{$arg}{'options'};
}
# This is true for our --help and --version
if ( not defined $opt ) { return 0; }
# Warning -- if opption_type is BARE, this should only be called if the
# op -- arg is registered.
_trace("Bumping $opt for $arg");
no strict 'refs'; ## no critic (ProhibitNoStrict)
${$opt}{$arg}++;
return 1;
}
sub _split_arg {
my ( $arg, $args ) = @_;
if ( defined $config{'nobundle'} ) {
$args->{$arg} = 1;
return $arg;
}
# This applies only to SHORT options
if ( _option_type($arg) != $SHORT ) { return $arg; }
if ( length $arg == 2 ) { return $arg; }
# Builtin help/version meets this criteria
if ( ( exists $options{$arg} )
and ( exists $options{$arg}{'registered'} ) )
{
return $arg;
}
_trace("Splitting $arg into its components");
my @args;
foreach my $char ( split m{}smx, substr $arg, 1 ) {
$char = "-$char";
push @args, $char;
$args->{$char}++;
$args->{$arg}++;
}
return @args;
}
sub _is_registered {
my $arg = shift;
return ( exists $options{$arg} )
and ( exists $options{$arg}{'registered'} );
}
sub _notreg {
my $text = shift;
if ( defined $config{'oknotreg'} ) { return; }
_error(qq{$text is not a registered option});
return;
}
sub _do_option_action {
my ( $arg, $arg_eq ) = @_;
if ( defined $options{$arg} ) {
# Registered option
# Check for sub to execute
if ( exists $options{$arg}{'code'} ) {
_trace("Running code $options{$arg}{'code'}");
no strict 'refs'; ## no critic (ProhibitNoStrict)
$options{$arg}{'code'}->();
return 1;
}
# No sub, registered option, so assign %options
# unless it's an assignment-type option, which must have a sub
if ( defined $arg_eq ) { return 0; }
_set_option($arg);
return 1;
}
}
sub _check_help {
my @perfs;
foreach my $op ( keys %options ) {
if ( exists $options{$op}{'restrict'} ) { next; }
$perfs[ _option_type($op) ]++;
}
$help_p = $LONG;
my $max_p = 0;
foreach my $i ( $BARE .. $LONG ) {
if ( ( defined $perfs[$i] ) && ( $perfs[$i] > $max_p ) ) {
$help_p = $i;
}
}
my $help = "$PREFIXES[$help_p]help";
my $vers = "$PREFIXES[$help_p]version";
if ( not exists $options{$help} ) {
$options{$help}{'code'} = \&_help;
$options{$help}{'registered'} = 1;
$options{$help}{'shorthelp'} = 'This text';
}
if ( not exists $options{$vers} ) {
$options{$vers}{'code'} = \&_version;
$options{$vers}{'registered'} = 1;
$options{$vers}{'shorthelp'} = 'Prints the version number';
}
return;
}
my @not_option;
sub _not_option {
my ( $arg, $eq ) = @_;
# The param $eq indicates that we're undoing an arg of the
# form -foo=22. The 22 is in @ARGV, but there was no sub
# to consume it, so we move it off.
if ( defined $eq ) { $arg .= qq{=$eq}; shift @ARGV; }
push @not_option, $arg;
return;
}
sub _parse_args { ## no critic (ProhibitExcessComplexity)
@not_option = ();
_trace_argv();
# Check that builtin help is defined according to the option type
_check_help();
# Check each script/module for init sub to execute
foreach my $caller_local (@callers) {
my $init_sub = $caller_local->[2]{'init'};
if ( defined $init_sub ) {
_trace("Executing code for init_sub");
no strict 'refs'; ## no critic (ProhibitNoStrict)
$init_sub->();
}
}
while ( my $argv = shift @ARGV ) {
my $op_type = _option_type($argv);
_trace("Considering $argv, option type is $TYPES[$op_type]");
_trace_argv();
# Check cease and desist
if ( $argv =~ m{\A-{1,2}\z}smx ) {
_trace("Option end $argv, scanning ends");
# Marker is not replaced
last;
}
# Check restricted option
if ( _restricted($argv) ) {
_trace("Option $argv is restricted, skipping");
_not_option($argv);
next;
}
# Check --foo=bar syntax use
my $arg_eq;
if ( $argv =~ m{=}smx ) {
# Assign-type option: --foo=bar
( $argv, $arg_eq ) = split m{=}smx, $argv;
unshift @ARGV, $arg_eq;
_trace("Option $argv has assignment");
_trace_argv();
}
# Process $argv as directed by %options, or push it back onto @ARGV
if ( _is_registered($argv) ) {
# Registered option, the simple case
if ( _do_option_action( $argv, $arg_eq ) ) { next; }
# _do_option_action returns 0 iff $arg_eq and no sub
_error(qq{To use $argv with "=", a subroutine must be provided});
_not_option( $argv, $arg_eq );
next;
}
_trace("$argv is not registered");
# Well, what we have in $argv is not registered
if ( defined $config{'findsub'} ) {
my $sub = _check_all_sub($argv);
if ( defined $sub ) {
_trace("Running code $sub");
no strict 'refs'; ## no critic (ProhibitNoStrict)
$sub->();
next;
}
if ( _do_option_action( $argv, $arg_eq ) ) { next; }
}
# $argv is not registered.
# Perhaps its a concatiation of single-letter SHORTs?
if ( ( $op_type == $SHORT ) && ( length $argv > 2 ) ) {
my %args;
my @args = _split_arg( $argv, \%args );
foreach my $arg (@args) {
if ( _is_registered($arg) ) {
_do_option_action($arg);
$args{$arg}--;
$args{$argv}--;
}
else {
_trace("$arg is not registered");
}
}
# Generate error messages for unregistered arg(s)
# $argv is not registered iff _none_ of its components are registered
# We know this because none of the components caused a decrement above
if ( $args{$argv} == @args ) {
_notreg($argv);
_trace("$argv is not an option");
_not_option( $argv, $arg_eq );
next;
}
# Report all components of $argv that are not registered
foreach my $arg (@args) {
if ( $args{$arg} == 0 ) { next; }
_notreg(qq{$arg (from $argv)});
_trace("$arg is not an option");
_not_option($arg);
}
next;
}
# Provide a warning for non-bare options
if ( $op_type != $BARE ) { _notreg($argv); }
# Save an element of @ARGV that did not meet the criteria for an option
_trace("$argv is not an option");
_not_option( $argv, $arg_eq );
}
# Give the user what's left
unshift @ARGV, @not_option;
_trace("Scanning ends");
_trace_argv();
return;
}
sub _sort_sub {
my ( $A, $B ) = ( $a, $b );
$A =~ s{\A-*}{}smx;
$B =~ s{\A-*}{}smx;
return $A cmp $B;
}
sub _version {
print "This is $callers[0][0][1]";
if ( defined $their_version and length $their_version ) {
print " version $their_version";
}
else {
print " (no version is specified)";
}
print "\n\n";
return;
}
sub _help {
_version();
# Are we being asked for *specific* help?
if ( my @help = grep { exists $options{$_} } @ARGV ) {
my $what = shift @ARGV;
if ( exists $options{$what}{'shorthelp'} ) {
print
"$callers[0][0][1] $what - $options{$what}{'shorthelp'}\n\n";
if ( defined $options{$what}{'longhelp'} ) {
print $options{$what}{'longhelp'}, "\n";
}
}
else {
print "No help available for $what\n";
}
}
else {
my $and_there_s_more = 0;
foreach ( sort _sort_sub keys %options ) {
print "$callers[0][0][1] $_";
if ( defined $options{$_}{'shorthelp'}
and ( $options{$_}{'shorthelp'} =~ m{\S}smx ) )
{
print " - $options{$_}{'shorthelp'}";
}
if ( defined $options{$_}{'longhelp'}
and ( $options{$_}{'longhelp'} =~ m{\S}smx ) )
{
$and_there_s_more++;
print q{ [*]};
}
print "\n";
}
if ($and_there_s_more) {
print <<"EOF";
More help is available on the topics marked with [*]
Try $callers[0][0][1] $PREFIXES[$help_p]help $PREFIXES[$help_p]foo
EOF
}
}
print qq{This is the built-in help, exiting\n};
if ( not defined $config{'test'} ) { exit 0; }
return;
}
1;
# This package exists to provide replacement for the subs provided by Pod::Parser
# The way it works is that they are called at appropriate times to extract the
# information we need to support the options.
# The sub names are determined by Pod::Parser, so don't meddle.
## no critic (ProhibitMultiplePackages)
package Getopt::Auto::PodExtract;
use base 'Pod::Parser';
## no critic (ProtectPrivateSubs)
# Called when Pod::Parser finds '^=...'
sub command {
my ( $self, $command, $text, $line_num ) = @_;
# Cancel text grabs; whatever we've got, we've got.
$self->{'copying'} = 0;
# Process only "=item" and "=head2, =head3 and =head4"
if ( $command eq 'item' || $command =~ m{^head(?:2|3|4)}smx ) {
# Sometimes more han one newline, which I don't understand
while ( chomp $text ) { }
Getopt::Auto::_trace("Parsing =$command $text");
my $shorthelp;
$text =~ s{\s+-+\s+(.*)}{}smx;
if ( defined $1 ) {
$shorthelp = $1;
}
# No qualifying dash, or no space after dash
# The RE fails, leaving $t unchanged
if ( not defined $shorthelp ) {
Getopt::Auto::_trace('No shorthelp, not an option');
return;
}
Getopt::Auto::_trace("Shorthelp is: $shorthelp");
# This suports options of the form "-f, --foo"
my $sub;
my @nosub;
my @opts = split m{,\s*}smx, $text;
foreach my $name (@opts) {
$name =~ s{\A(\w<)?([\w_-]+)>?}{$2}smx;
if ( $name =~ m{\s}smx ) {
Getopt::Auto::_trace("$name dropped, has spaces");
next;
}
Getopt::Auto::_trace("Option is $name");
$self->{'funcs'}{$name} = { 'shorthelp' => $shorthelp, };
$self->{'copying'} = 1;
$self->{'latest'} = $name;
my $sub_found = Getopt::Auto::_check_func($name);
if ( defined $sub_found ) {
$self->{'funcs'}{$name}{'code'} = $sub_found;
$sub = $sub_found;
}
else {
push @nosub, $name;
}
}
# Options that had no defined sub get the last-defined sub
foreach my $name (@nosub) {
$self->{'funcs'}{$name}{'code'} = $sub;
}
}
return;
}
# Called when text that begins with spaces (or tabs) is discovered inside POD text.
# As implied by the name, verbatum text is taken 'as is'.
# We save it only if we're inside of =item or =head ($self->{copying})
sub verbatim {
my ( $self, $paragraph, $line_num ) = @_;
if ( $self->{'copying'} ) {
$self->{'funcs'}{ $self->{'latest'} }{'longhelp'} .= $paragraph;
Getopt::Auto::_trace("verbatim - longhelp is: $paragraph");
}
return;
}
# Called when text that does not begin with spaces (or tabs) is discovered inside POD text.
# The semantics of text blocks require that 'interior sequences' (e.g.: B<foo>) be expanded.
# That's what the Pod::Parser sub interpolate() does.
# We save it only if we're inside of =item or =head ($self->{copying})
sub textblock {
my ( $self, $paragraph, $line_num ) = @_;
if ( $self->{'copying'} ) {
$self->{'funcs'}{ $self->{'latest'} }{'longhelp'}
.= $self->interpolate( $paragraph, $line_num );
Getopt::Auto::_trace("textblock - longhelp is: $paragraph");
}
return;
}
sub preprocess_line {
my ( $self, $text, $line_num ) = @_;
defined Getopt::Auto::_get_their_version() and return $text;
if ( $text =~ m{\$VERSION}smx ) {
my ($tv) = $text =~ m{([\d\.]+)}smx;
Getopt::Auto::_set_their_version($tv);
Getopt::Auto::_trace("Extracted version $tv from $text");
}
return $text;
}
1;
__END__