File Coverage

blib/lib/Getopt/EX/Long.pm

Criterion	Covered	Total	%
statement	96	112	85.7
branch	12	28	42.8
condition	3	9	33.3
subroutine	25	31	80.6
pod	3	7	42.8
total	139	187	74.3

package Getopt::EX::Long;

our $VERSION = "3.03";

use v5.14;
use warnings;
use Carp;

{
    no warnings 'once';
    *REQUIRE_ORDER   = \$Getopt::Long::REQUIRE_ORDER;
    *PERMUTE         = \$Getopt::Long::PERMUTE;
    *RETURN_IN_ORDER = \$Getopt::Long::RETURN_IN_ORDER;

    *Configure       = \&Getopt::Long::Configure;
    *HelpMessage     = \&Getopt::Long::HelpMessage;
    *VersionMessage  = \&Getopt::Long::VersionMessage;
}

use Exporter 'import';
our @EXPORT    = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
our @EXPORT_OK = ( '&GetOptionsFromArray',
		 # '&GetOptionsFromString',
		   '&Configure',
		   '&HelpMessage',
		   '&VersionMessage',
		   '&ExConfigure',
		   '&ExReset',
    );
use parent qw(Getopt::Long);

use Data::Dumper;
use Getopt::Long();
use Getopt::EX::Loader;
use Getopt::EX::Func qw(parse_func);

my %DefaultConfigOption = ( AUTO_DEFAULT => 1 );
my %ConfigOption = %DefaultConfigOption;
my @ValidOptions = ('AUTO_DEFAULT' , @Getopt::EX::Loader::OPTIONS);

my $loader;
my $loader_pid = $$;  # Set at module load time for fork detection

sub ExReset {
    undef $loader;
    %ConfigOption = %DefaultConfigOption;
    $loader_pid = $$;
}

sub GetOptions {
    unshift @_, \@ARGV;
    goto &GetOptionsFromArray;
}

sub GetOptionsFromArray {
    my $argv = $_[0];

    ExReset() if $loader_pid != $$;

    set_default() if $ConfigOption{AUTO_DEFAULT};

    $loader //= Getopt::EX::Loader->new(do {
	map {
	    exists $ConfigOption{$_} ? ( $_ => $ConfigOption{$_} ) : ()
	} @Getopt::EX::Loader::OPTIONS
    });

    $loader->deal_with($argv);

    my @builtins = do {
	if (ref $_[1] eq 'HASH') {
	    $loader->hashed_builtins($_[1]);
	} else {
	    $loader->builtins;
	}
    };
    push @_, @builtins;

    # Suppress "Duplicate specification" warnings from Getopt::Long
    local $SIG{__WARN__} = sub {
	warn @_ unless $_[0] =~ /^Duplicate specification/;
    };
    Getopt::Long::GetOptionsFromArray(@_);
}

sub GetOptionsFromString {
    die "GetOptionsFromString is not supported, yet.\n";
}

sub ExConfigure {
    ExReset() if $loader_pid != $$;
    my %opt = @_;
    for my $name (@ValidOptions) {
	if (exists $opt{$name}) {
	    $ConfigOption{$name} = delete $opt{$name};
	}
    }
    warn "Unknown option: ", Dumper \%opt if %opt;
}

sub set_default {
    use List::Util qw(pairmap);
    pairmap { $ConfigOption{$a} //= $b } get_default();
}

sub get_default {
    my @list;

    my $prog = ($0 =~ /([^\/]+)$/) ? $1 : return ();

    if (defined (my $home = $ENV{HOME})) {
	if (-f (my $rc = "$home/.${prog}rc")) {
	    push @list, RCFILE => $rc;
	}
    }

    push @list, BASECLASS => "App::$prog";

    @list;
}

1;

############################################################

package Getopt::EX::Long::Parser;

use strict;
use warnings;

use List::Util qw(first);
use Data::Dumper;

use Getopt::Long();  # Load first to make Getopt::Long::Parser available
use parent -norequire, qw(Getopt::Long::Parser);

use Getopt::EX::Loader;

sub new {
    my $class = shift;

    my @exconfig;
    while (defined (my $i = first { $_[$_] eq 'exconfig' } keys @_)) {
	push @exconfig, @{ (splice @_, $i, 2)[1] };
    }
    if (@exconfig == 0 and $ConfigOption{AUTO_DEFAULT}) {
	@exconfig = Getopt::EX::Long::get_default();
    }

    my $obj = $class->SUPER::new(@_);

    my $loader = $obj->{exloader} = Getopt::EX::Loader->new(@exconfig);

    $obj;
}

sub getoptionsfromarray {
    my $obj = shift;
    my $argv = $_[0];
    my $loader = $obj->{exloader};

    $loader->deal_with($argv);

    my @builtins = do {
	if (ref $_[1] eq 'HASH') {
	    $loader->hashed_builtins($_[1]);
	} else {
	    $loader->builtins;
	}
    };
    push @_, @builtins;

    # Suppress "Duplicate specification" warnings from Getopt::Long
    local $SIG{__WARN__} = sub {
	warn @_ unless $_[0] =~ /^Duplicate specification/;
    };
    $obj->SUPER::getoptionsfromarray(@_);
}

1;

=head1 NAME

Getopt::EX::Long - Getopt::Long compatible extended module

=head1 SYNOPSIS

  use Getopt::EX::Long;
  GetOptions("file=s" => \my $file);

or using the object-oriented interface:

  use Getopt::EX::Long;
  my $parser = Getopt::EX::Long::Parser->new(
      config   => [ qw(posix_default no_ignore_case) ],
      exconfig => [ BASECLASS => 'App::example' ],
  );
  $parser->getoptions("file=s" => \my $file);

=head1 DESCRIPTION

L is almost fully compatible with L.
You can replace the module declaration, and it should work the same as
before (see L).

In addition to standard L functionality, users can
define their own option aliases and write dynamically loaded extension
modules.  If the command name is I, the file

    ~/.examplerc

is loaded by default.  In this rc file, users can define option
aliases with macro processing.  This is useful when the command takes
complex arguments.

Special options starting with B<-M> load the corresponding Perl
module.  The module is assumed to be under a specific base class.  For
example:

    % example -Mfoo

loads the C module by default.

Since extension modules are normal Perl modules, users can write any
code they need.  If the module is specified with an initial function
call, that function is called when the module is loaded:

    % example -Mfoo::bar(buz=100)

This loads module B and calls function I with the parameter
I set to 100.

If the module includes a C<__DATA__> section, it is interpreted as an
rc file.  Combined with the startup function call, this allows module
behavior to be controlled through user-defined options.

For details about rc files and module specification, see
L.

=head1 CONFIG OPTIONS

Config options are set by B or the B
parameter for the B method.

=over 4

=item AUTO_DEFAULT

Config options B and B are automatically set based
on the name of the command executable.  If you don't want this behavior,
set B to 0.

=back

Other options including B and B are passed to
B.  Read its documentation for details.

=head1 FUNCTIONS

=over 4

=item B

Set config options.  See L.

=item B

Reset the internal loader and configuration to their default state.
This is useful when you need to reinitialize the module state, for
example after forking a child process.

Note that B and B automatically
detect forked processes and reset internally, so explicit calls to
B are usually unnecessary.

=back

=head1 INCOMPATIBILITY

The subroutine B is not supported.

=head1 SEE ALSO

L,
L,
L