File Coverage

blib/lib/Getopt/EX/Func.pm

Criterion	Covered	Total	%
statement	53	65	81.5
branch	11	18	61.1
condition	9	12	75.0
subroutine	12	16	75.0
pod	0	7	0.0
total	85	118	72.0

package Getopt::EX::Func;

our $VERSION = "3.03";

use v5.14;
use warnings;
use Carp;

use Exporter 'import';
our @EXPORT      = qw();
our @EXPORT_OK   = qw(parse_func callable arg2kvlist);
our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );

use Data::Dumper;

use Scalar::Util qw(blessed);
sub callable {
    my $target = shift;
    blessed $target and $target->can('call');
}

sub new {
    my $class = shift;
    my $obj = bless [ @_ ], $class;
}

sub append {
    my $obj = shift;
    push @$obj, @_;
}

sub call {
    my $obj = shift;
    unshift @_, @$obj;
    my $name = shift;

    no strict 'refs';
    goto &$name;
}

##
## Create a closure that calls the named function with preset arguments.
## Used internally when parse_func is called with the 'pointer' option.
## The 'package main' may be unnecessary since $name is fully qualified,
## but is kept for safety in case of future changes.
##
sub closure {
    my $name = shift;
    my @argv = @_;
    sub {
	package main;
	no strict 'refs';
	unshift @_, @argv;
	goto &$name;
    }
}

##
## sub { ... }
## funcname(arg1,arg2,arg3=val3)
## funcname=arg1,arg2,arg3=val3
##

##
## Regex to match balanced parentheses, including nested ones.
## Uses recursive subpattern (?-1) to match inner parentheses.
## Possessive quantifiers (++ and *+) prevent backtracking for efficiency.
##
my $paren_re = qr/( \( (?: [^()]++ | (?-1) )*+ \) )/x;

##
## Key name pattern for function arguments.
## Should be \w+ but currently allows more characters for historical reasons.
##
my $key_re = qr/[^,=*\/]+/;

sub parse_func {
    my $opt = ref $_[0] eq 'HASH' ? shift : {};
    local $_ = shift;
    my $noinline = $opt->{noinline};
    my $pointer = $opt->{pointer};
    my $caller = caller;
    my $pkg = $opt->{PACKAGE} || $caller;

    my @func;

    if (not $noinline and /^sub\s*{/) {
	my $sub = eval "package $pkg; $_";
	if ($@) {
	    warn "Error in function -- $_ --.\n";
	    die $@;
	}
	croak "Unexpected result from eval.\n" if ref $sub ne 'CODE';
	@func = ($sub);
    }
    elsif (m{^ &? (? [\w:]+ ) (? $paren_re | =.* )? $}x) {
	my $name = $+{name};
	my $arg = $+{arg} // '';
	$arg =~ s/^ (?| \( (.*) \) | = (.*) ) $/$1/x;
	$name =~ s/^/$pkg\::/ unless $name =~ /::/;
	@func = ($name, arg2kvlist($arg));
    }
    else {
	return undef;
    }

    __PACKAGE__->new( $pointer ? closure(@func) : @func );
}

##
## convert "key1,key2,key3=val3" to (key1=>1, key2=>1, key3=>"val3")
##
## *= takes the rest of the string as a value
## e.g., "key1,key2*=a,b,c" => (key1=>1, key2=>"a,b,c")
##
## /= uses the next character as a delimiter
## e.g., "key1,key2/=/a,b,c/,next" => (key1=>1, key2=>"a,b,c", next=>1)
##
sub arg2kvlist {
    my @kv;
    for (@_) {
	while (/\G \s* (?(?>${key_re}))
	       (?: \*= (?.*)
	         | \/= (?.) (?.*?) \g{delim} (?=,|\z) ,*
	         | (?: = (? (?:[^,()]++ | ${paren_re})*+ ) )? ,* )
	       /xgcs) {
	    push @kv, ( $+{key}, $+{value} // 1 );
	}
	(pos() // 0) == length or die "parse error in \"$_\".\n";
    }
    @kv;
}

1;

=head1 NAME

Getopt::EX::Func - Function call interface


=head1 SYNOPSIS

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

  my $func = parse_func("func_name(key=value,flag)");

  $func->call;

=head1 DESCRIPTION

This module provides a way to create function call objects used in the
L module set.

For example, suppose your script has a B<--begin> option that
specifies a function to call at the beginning of execution.  You can
implement it like this:

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

    GetOptions("begin:s" => \$opt_begin);

    my $func = parse_func($opt_begin);

    $func->call;

The user can then invoke the script as:

    % example -Mfoo --begin 'repeat(debug,msg=hello,count=2)'

The function C should be declared in module C or in a
startup rc file such as F<~/.examplerc>.  It can be implemented like
this:

    our @EXPORT = qw(repeat);
    sub repeat {
        my %opt = @_;
        print Dumper \%opt if $opt{debug};
        say $opt{msg} for 1 .. $opt{count};
    }

=head1 FUNCTION SPEC

The C function accepts the following string formats.

A function name can optionally be prefixed with C<&>, and parameters
can be specified in two equivalent forms using parentheses or C<=>:

    func(key=value,key2=value2)
    func=key=value,key2=value2
    &func(key=value)

So the following two commands are equivalent:

    % example --begin 'repeat(debug,msg=hello,count=2)'
    % example --begin 'repeat=debug,msg=hello,count=2'

Both will call the function as:

    repeat( debug => 1, msg => 'hello', count => '2' );

Arguments are passed as I =E I pairs.  Parameters
without a value (C in this example) are assigned the value 1.
Key names should only contain word characters (C<\w>: alphanumeric and
underscore).  Currently, any characters except C<,>, C<=>, C<*>, and
C are accepted for historical reasons, but this may change in the
future.

Commas normally separate parameters.  If a value needs to contain
commas, there are two ways to handle this:

=over 4

=item Parentheses

Commas inside parentheses are preserved:

    func(pattern=(a,b,c),debug)

This calls:

    func( pattern => '(a,b,c)', debug => 1 );

Note that the parentheses are included in the value.

=item Asterisk-Equals

Use C<*=> instead of C<=> to capture the entire remaining string as
the value:

    func(debug,pattern*=a,b,c)

This calls:

    func( debug => 1, pattern => 'a,b,c' );

Since C<*=> consumes the rest of the string, no parameters can follow
it.

=item Slash-Equals with Delimiter

Use C followed by a delimiter character to quote a value.  The
first character after C becomes the delimiter, and the value
continues until the same delimiter appears again:

    func(debug,pattern/=/a,b,c/,verbose)

This calls:

    func( debug => 1, pattern => 'a,b,c', verbose => 1 );

The delimiter can be any character.  Choose one that does not appear
in the value:

    func(pattern/=/a,b,c/)         # / as delimiter
    func(path/=|/usr/local/bin|)   # | as delimiter for paths
    func(text/=:hello:world:)      # : as delimiter

For scripting, control characters like BEL (C<\x07>) or US (C<\x1f>,
Unit Separator) can be used as delimiters to avoid conflicts with any
printable characters:

    $delim = "\x07";   # BEL
    $delim = "\x1f";   # US (Unit Separator)
    $arg = "data/=${delim}any/chars=here,${delim}";

=back

An anonymous subroutine can also be specified inline:

    % example --begin 'sub{ say "wahoo!!" }'

The function is evaluated under C, so features like C
are available.