File Coverage

blib/lib/Getopt/EX/Module.pm

Criterion	Covered	Total	%
statement	232	299	77.5
branch	67	112	59.8
condition	16	34	47.0
subroutine	43	51	84.3
pod	14	25	56.0
total	372	521	71.4

package Getopt::EX::Module;
use version; our $VERSION = version->declare("2.1.3");

use v5.14;
use warnings;
use Carp;

use Exporter 'import';
our @EXPORT      = qw();
our %EXPORT_TAGS = ( );
our @EXPORT_OK   = qw();

use Data::Dumper;
use Text::ParseWords qw(shellwords);
use List::Util qw(first pairmap);

use Getopt::EX::Func qw(parse_func);

sub new {
    my $class = shift;
    my $obj = bless {
	Module => undef,
	Base => undef,
	Mode => { FUNCTION => 0, WILDCARD => 0 },
	Define => [],
	Expand  => [],
	Option => [],
	Builtin => [],
	Automod => [],
	Autoload => {},
	Call => [],
	Help => [],
    }, $class;

    configure $obj @_ if @_;

    $obj;
}

sub configure {
    my $obj = shift;
    my %opt = @_;

    if (my $base = delete $opt{BASECLASS}) {
	$obj->{Base} = $base;
    }

    if (my $file = delete $opt{FILE}) {
	if (open my $fh, "<:encoding(utf8)", $file) {
	    $obj->module($file);
	    $obj->readrc($fh);
	}
    }
    elsif (my $module = delete $opt{MODULE}) {
	my $pkg = $opt{PACKAGE} || 'main';
	my @base = do {
	    if (ref $obj->{Base} eq 'ARRAY') {
		@{$obj->{Base}};
	    } else {
		($obj->{Base} // '');
	    }
	};
	while (@base) {
	    my $base = shift @base;
	    my $mod = $base ? "$base\::$module" : $module;
	    eval "package $pkg; use $mod;";
	    if ($@) {
		my $path = $mod =~ s{::}{/}gr . ".pm";
		next if @base and $@ =~ /Can't locate \Q$path\E/;
		croak "$mod: $@";
	    }
	    $obj->module($mod);
	    $obj->define('__PACKAGE__' => $mod);
	    local *data = "$mod\::DATA";
	    if (not eof *data) {
		my $pos = tell *data;
		$obj->readrc(*data);
		# recover position in case called multiple times
		seek *data, $pos, 0 or die "seek: $!" if $pos >= 0;
	    }
	    last;
	}
    }

    if (my $builtin = delete $opt{BUILTIN}) {
	$obj->builtin(@$builtin);
    }

    warn "Unprocessed option: ", Dumper \%opt if %opt;

    $obj;
}

sub readrc {
    my $obj = shift;
    my $fh = shift;
    my $text = do { local $/; <$fh> };
    for ($text) {
	s/^__(?:CODE|PERL)__\s*\n(.*)//ms and do {
	    package main;
	    no warnings 'once';
	    local $main::MODULE = $obj;
	    eval $1;
	    die if $@;
	};
	s/^\s*(?:#.*)?\n//mg;
	s/\\\n//g;
    }
    $obj->parsetext($text);
    $obj;
}

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

sub module {
    my $obj = shift;
    @_  ? $obj->{Module} = shift
	: $obj->{Module};
}

sub title {
    my $obj = shift;
    my $mod = $obj->module;
    $mod =~ m{ .* [:/] (.+) }x ? $1 : $mod;
}

sub define {
    my $obj = shift;
    my $name = shift;
    my $list = $obj->{Define};
    if (@_) {
	my $re = qr/\Q$name/;
	unshift(@$list, [ $name, $re, shift ]);
    } else {
	first { $_->[0] eq $name } @$list;
    }
}

sub expand {
    my $obj = shift;
    local *_ = shift;
    for my $defent (@{$obj->{Define}}) {
	my($name, $re, $string) = @$defent;
	s/$re/$string/g;
    }
    s{ (\$ENV\{ (['"]?) \w+ \g{-1} \}) }{ eval($1) // $1 }xge;
}

sub mode {
    my $obj = shift;
    @_ == 1 and return $obj->{Mode}->{uc shift};
    die "Unexpected parameter." if @_ % 2;
    pairmap {
	$obj->{Mode}->{uc $a} = $b;
    } @_;
}

use constant BUILTIN => "__BUILTIN__";
sub validopt { $_[0] ne BUILTIN }

sub setlocal {
    my $obj = shift;
    $obj->setlist("Expand", @_);
}

sub setopt {
    my $obj = shift;
    $obj->setlist("Option", @_);
}

sub setlist {
    my $obj = shift;
    my $list = $obj->{+shift};
    my $name = shift;
    my @args = do {
	if (ref $_[0] eq 'ARRAY') {
	    @{ $_[0] };
	} else {
	    map { shellwords $_ } @_;
	}
    };

    for (my $i = 0; $i < @args; $i++) {
	if (my @opt = $obj->getlocal($args[$i])) {
	    splice @args, $i, 1, @opt;
	    redo;
	}
    }

    for (@args) {
	$obj->expand(\$_);
    }
    unshift @$list, [ $name, @args ];
}

sub getopt {
    my $obj = shift;
    my($name, %opt) = @_;
    return () if $name eq 'default' and not $opt{DEFAULT} || $opt{ALL};

    my $list = $obj->{Option};
    my $e = first {
	$_->[0] eq $name and $opt{ALL} || validopt($_->[1])
    } @$list;
    my @e = $e ? @$e : ();
    shift @e;

    # check autoload
    unless (@e) {
	my $hash = $obj->{Autoload};
	for my $mod (@{$obj->{Automod}}) {
	    if (exists $hash->{$mod}->{$name}) {
		delete $hash->{$mod};
		return ($mod, $name);
	    }
	}
    }

    @e;
}

sub getlocal {
    my $obj = shift;
    my($name, %opt) = @_;

    my $e = first { $_->[0] eq $name } @{$obj->{Expand}};
    my @e = $e ? @$e : ();
    shift @e;
    @e;
}

sub expand_args {
    my $obj = shift;
    my @args = @_;

    ##
    ## Expand `&function' style arguments.
    ##
    if ($obj->mode('function')) {
	@args = map {
	    if (/^&(.+)/) {
		my $func = parse_func $obj->module . "::$1";
		$func ? $func->call : $_;
	    } else {
		$_;
	    }
	}
	@args;
    }

    ##
    ## Expand wildcards.
    ##
    if ($obj->mode('wildcard')) {
	@args = map {
	    my @glob = glob $_;
	    @glob ? @glob : $_;
	} @args;
    }

    @args;
}

sub default {
    my $obj = shift;
    $obj->getopt('default', DEFAULT => 1);
}

sub options {
    my $obj = shift;
    my $opt = $obj->{Option};
    my $automod = $obj->{Automod};
    my $auto = $obj->{Autoload};
    my @opt = reverse map { $_->[0] } @$opt;
    my @auto = map { sort keys %{$auto->{$_}} } @$automod;
    (@opt, @auto);
}

sub help {
    my $obj = shift;
    my $name = shift;
    my $list = $obj->{Help};
    if (@_) {
	unshift(@$list, [ $name, shift ]);
    } else {
	my $e = first { $_->[0] eq $name } @$list;
	$e ? $e->[1] : undef;
    }
}

sub parsetext {
    my $obj = shift;
    my $text = shift;
    my $re = qr{
	(?|
	    # HERE document
	    (.+\s) << (?\w+) \n
	    (? (?s:.*?) \n )
	    \g{mark}\n
	|
	    (.+)\n?
	)
    }x;
    while ($text =~ m/$re/g) {
	my $line = do {
	    if (defined $+{here}) {
		$1 . $+{here};
	    } else {
		$1;
	    }
	};
	$obj->parseline($line);
    }
    $obj;
}

sub parseline {
    my $obj = shift;
    my $line = shift;
    my @arg = split ' ', $line, 3;

    my %min_args = ( mode => 1, DEFAULT => 3 );
    my $min_args = $min_args{$arg[0]} || $min_args{DEFAULT};
    if (@arg < $min_args) {
	warn sprintf("Parse error in %s: %s\n", $obj->title, $line);
	return;
    }

    ##
    ## in-line help document after //
    ##
    my $optname = $arg[1] // '';
    if ($arg[0] eq "builtin") {
	for ($optname) {
	    s/[^\w\-].*//; # remove alternative names after `|'.
	    s/^(?=([\w\-]+))/length($1) == 1 ? '-' : '--'/e;
	}
    }
    if ($arg[2] and $arg[2] =~ s{ (?:^|\s+) // \s+ (?.*) }{}x) {
	$obj->help($optname, $+{message});
    }

    ##
    ## Commands
    ##
    if ($arg[0] eq "define") {
	$obj->define($arg[1], $arg[2]);
    }
    elsif ($arg[0] eq "option") {
	$obj->setopt($arg[1], $arg[2]);
    }
    elsif ($arg[0] eq "expand") {
	$obj->setlocal($arg[1], $arg[2]);
    }
    elsif ($arg[0] eq "defopt") {
	$obj->define($arg[1], $arg[2]);
	$obj->setopt($arg[1], $arg[1]);
    }
    elsif ($arg[0] eq "builtin") {
	$obj->setopt($optname, BUILTIN);
	if ($arg[2] =~ /^\\?(?[\$\@\%\&])(?[\w:]+)/) {
	    my($mark, $name) = @+{"mark", "name"};
	    my $mod = $obj->module;
	    /:/ or s/^/$mod\::/ for $name;
	    no strict 'refs';
	    $obj->builtin($arg[1] => {'$' => \${$name},
				      '@' => \@{$name},
				      '%' => \%{$name},
				      '&' => \&{$name}}->{$mark});
	}
    }
    elsif ($arg[0] eq "autoload") {
	shift @arg;
	$obj->autoload(@arg);
    }
    elsif ($arg[0] eq "mode") {
	shift @arg;
	for (@arg) {
	    if (/^(no-?)?(.*)/i) {
		$obj->mode($2 => $1 ? 0 : 1);
	    }
	}
    }
    elsif ($arg[0] eq "help") {
	$obj->help($arg[1], $arg[2]);
    }
    else {
	warn sprintf("Unknown operator \"%s\" in %s\n",
		     $arg[0], $obj->title);
    }

    $obj;
}

sub builtin {
    my $obj = shift;
    my $list = $obj->{Builtin};
    @_  ? push @$list, @_
	: @$list;
}

sub autoload {
    my $obj = shift;
    my $module = shift;
    my @option = map { split ' ' } @_;

    my $hash = ($obj->{Autoload}->{$module} //= {});
    my $list = $obj->{Automod};
    for (@option) {
	$hash->{$_} = 1;
	$obj->help($_, "autoload: $module");
    }
    push @$list, $module if not grep { $_ eq $module } @$list;
}

sub call {
    my $obj = shift;
    my $list = $obj->{Call};
    @_  ? push @$list, @_
	: @$list;
}

sub call_if_defined {
    my($module, $name, @param) = @_;
    my $func = "$module\::$name";
    if (defined &$func) {
	no strict 'refs';
	$func->(@param);
    }
}

sub run_inits {
    my $obj = shift;
    my $argv = shift;
    my $module = $obj->module;
    local @ARGV = ();

    call_if_defined $module, "initialize" => ($obj, $argv);

    for my $call ($obj->call) {
	my $func = $call->can('call') ? $call : parse_func($call);
	$func->call;
    }

    call_if_defined $module, "finalize" => ($obj, $argv);
}

1;

=head1 NAME

Getopt::EX::Module - RC/Module data container

=head1 SYNOPSIS

  use Getopt::EX::Module;

  my $bucket = Getopt::EX::Module->new(
	BASECLASS => $baseclass,
	FILE => $file_name  /  MODULE => $module_name,
	);

=head1 DESCRIPTION

This module is usually used from L, and keeps
all data about loaded rc file or module.

=head2 MODULE

After user defined module was loaded, subroutine C is
called if it exists in the module.  At this time, container object is
passed to the function as the first argument and following command
argument pointer as the second.  So you can use it to directly touch
the object contents through class interface.

Following C, function defined with module option is called.

Finally subroutine C is called if defined, to finalize start
up process of the module.

=head2 FILE

As for rc file, section after C<__PERL__> mark is executed as Perl
program.  At this time, module object is assigned to variable
C<$MODULE>, and you can access module API through it.

    if (our $MODULE) {
        $MODULE->setopt('default', '--number');
    }

=head1 RC FILE FORMAT

=over 7

=item B I I

Define option I.  Argument I is processed by
I routine defined in L module.  Be sure
that this module sometimes requires escape backslashes.

Any kind of string can be used for option name but it is not combined
with other options.

    option --fromcode --outside='(?s)\/\*.*?\*\/'
    option --fromcomment --inside='(?s)\/\*.*?\*\/'

If the option named B is defined, it will be used as a
default option.

For the purpose to include following arguments within replaced
strings, two special notations can be used in option definition.

String C<< $ >> is replaced by the Ith argument after the
substituted option, where I is number start from one.  Because C<<
$<0> >> is replaced by the defined option itself, you have to care
about infinite loop.

String C<< $ >> is replaced by following command line argument
and the argument is removed from list.

For example, when

    option --line --le &line=$

is defined, command

    greple --line 10,20-30,40

will be evaluated as this:

    greple --le &line=10,20-30,40

There are special arguments to manipulate option behavior and the rest
of arguments.  Argument C<< $ >> moves all following arguments
there, C<< $ >> just removes them, and C<< $ >> copies
them.  These does not work when included as a part of string.

They take optional one or two parameters, those are passed to Perl
C function as I and I.  C<< $ >> is
same as C<< $ >>; C<< $ >> is same as C<< $<1> >>;
C<< $ >> is same as C<< $ >>; C<< $ >> moves
the last argument; C<< $move(1,1) >> moves second argument.  Next
example exchange following two arguments.

    option --exch $

You can use recently introduced C<< $ >> to ignore the
argument.  Some existing module uses C<< $ >> for the same
purpose, because it effectively do nothing.

    option --deprecated $
    option --deprecated $

=item B I I

Define local option I.  Command B is almost same as
command B in terms of its function.  However, option defined
by this command is expanded in, and only in, the process of
definition, while option definition is expanded when command arguments
are processed.

This is similar to string macro defined by following B
command.  But macro expantion is done by simple string replacement, so
you have to use B to define option composed by multiple
arguments.

=item B I I

Define string macro.  This is similar to B, but argument is
not processed by I and treated just a simple text, so
meta-characters can be included without escape.  Macro expansion is
done for option definition and other macro definition.  Macro is not
evaluated in command line option.  Use option directive if you want to
use in command line,

    define (#kana) \p{InKatakana}
    option --kanalist --nocolor -o --join --re '(#kana)+(\n(#kana)+)*'
    help   --kanalist List up Katakana string

Here-document can be used to define string inluding newlines.

    define __script__ <
    {
    	...
    }
    EOS

Special macro C<__PACKAGE__> is pre-defined to module name.

=item B I

Define help message for option I.

=item B I I

Define built-in option which should be processed by option parser.
Defined option spec can be taken by B method, and script is
responsible to give them to parser.

Arguments are assumed to be L style spec, and
I is string start with C<$>, C<@> or C<%>.  They will be
replaced by a reference to the object which the string represent.

=item B I I

Define module which should be loaded automatically when specified
option is found in the command arguments.

For example,

    autoload -Mdig --dig

replaces option "I<--dig>" to "I<-Mdig --dig>", and I module is
loaded before processing I<--dig> option.

=item B [I]I

Set or unset mode I.  Currently, B and B can
be used as a name.  See METHODS section.

Next is an example used in L module to
produce parameters on the fly.

    mode function
    option --dyncmap &dyncmap($)

=back

=head1 METHODS

=over 4

=item B I

Create object.  Parameters are just passed to C method.

=item B

Configure object.  Parameter is passed in hash name and value style.

=over 4

=item B =E I

Set base class.

=item B =E I

Load file.

=item B =E I

Load module.

=back

=item B I, I

Define macro.

=item B I, I

Set option.

=item B I, I

Set option which is effective only in the module.

=item B I

Get option.  Takes option name and return it's definition if
available.  It doesn't return I option, get it by I
method.

=item B

Get default option.  Use C ...)> to set.

=item B

Get built-in options.

=item B

Set autoload module.

=item B

Set argument treatment mode.  Arguments produced by option expansion
will be the subject of post-process.  This method define the behavior
of it.

=over 4

=item B(B => 1)

Interpret the argument start with '&' as a function, and replace it by
the result of the function call.

=item B(B => 1)

Replace wildcard argument by matched file names.

=back

=back