File Coverage

blib/lib/Getopt/EX/Func.pm
Criterion Covered Total %
statement 60 73 82.1
branch 11 18 61.1
condition 9 12 75.0
subroutine 14 18 77.7
pod 0 7 0.0
total 94 128 73.4


line stmt bran cond sub pod time code
1             package Getopt::EX::Func;
2 11     11   78470 use version; our $VERSION = version->declare("2.1.3");
  11         1997  
  11         74  
3              
4 11     11   1032 use v5.14;
  11         42  
5 11     11   58 use warnings;
  11         36  
  11         303  
6 11     11   65 use Carp;
  11         58  
  11         722  
7              
8 11     11   89 use Exporter 'import';
  11         23  
  11         930  
9             our @EXPORT = qw();
10             our @EXPORT_OK = qw(parse_func callable);
11             our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
12              
13 11     11   111 use Data::Dumper;
  11         21  
  11         545  
14              
15 11     11   104 use Scalar::Util qw(blessed);
  11         22  
  11         2159  
16             sub callable {
17 0     0 0 0 my $target = shift;
18 0 0       0 blessed $target and $target->can('call');
19             }
20              
21             sub new {
22 8     8 0 15 my $class = shift;
23 8         55 my $obj = bless [ @_ ], $class;
24             }
25              
26             sub append {
27 0     0 0 0 my $obj = shift;
28 0         0 push @$obj, @_;
29             }
30              
31             sub call {
32 8     8 0 153 my $obj = shift;
33 8         17 unshift @_, @$obj;
34 8         15 my $name = shift;
35              
36 11     11   76 no strict 'refs';
  11         25  
  11         1049  
37 8         73 goto &$name;
38             }
39              
40             sub closure {
41 0     0 0 0 my $name = shift;
42 0         0 my @argv = @_;
43             sub {
44             package main; # XXX
45 11     11   84 no strict 'refs';
  11         20  
  11         3713  
46 0     0   0 unshift @_, @argv;
47 0         0 goto &$name;
48             }
49 0         0 }
50              
51             ##
52             ## sub { ... }
53             ## funcname(arg1,arg2,arg3=val3)
54             ## funcname=arg1,arg2,arg3=val3
55             ##
56              
57             my $paren_re = qr/( \( (?: [^()]++ | (?-1) )*+ \) )/x;
58              
59             sub parse_func {
60 8 100   8 0 27 my $opt = ref $_[0] eq 'HASH' ? shift : {};
61 8         21 local $_ = shift;
62 8         16 my $noinline = $opt->{noinline};
63 8         14 my $pointer = $opt->{pointer};
64 8         15 my $caller = caller;
65 8   66     21 my $pkg = $opt->{PACKAGE} || $caller;
66              
67 8         12 my @func;
68              
69 8 100 66     318 if (not $noinline and /^sub\s*{/) {
    50          
70 2         154 my $sub = eval "package $pkg; $_";
71 2 50       9 if ($@) {
72 0         0 warn "Error in function -- $_ --.\n";
73 0         0 die $@;
74             }
75 2 50       7 croak "Unexpected result from eval.\n" if ref $sub ne 'CODE';
76 2         6 @func = ($sub);
77             }
78             elsif (m{^ &? (? [\w:]+ ) (? $paren_re | =.* )? $}x) {
79 11     11   5277 my $name = $+{name};
  11         4390  
  11         3424  
  6         47  
80 6   50     38 my $arg = $+{arg} // '';
81 6         15 $arg =~ s/^ (?| \( (.*) \) | = (.*) ) $/$1/x;
82 6 100       35 $name =~ s/^/$pkg\::/ unless $name =~ /::/;
83 6         34 @func = ($name, arg2kvlist($arg));
84             }
85             else {
86 0         0 return undef;
87             }
88              
89 8 50       44 __PACKAGE__->new( $pointer ? closure(@func) : @func );
90             }
91              
92             ##
93             ## convert "key1,key2,key3=val3" to (key1=>1, key2=>1, key3=>"val3")
94             ##
95             sub arg2kvlist {
96 13     13 0 107 my @kv;
97 13         48 for (@_) {
98 13         308 while (/\G \s*
99             (? [^,=]+ )
100             (?: = (? (?: [^,()]++ | ${paren_re} )*+ ) )?
101             ,*/xgc
102             ) {
103 18   100     263 push @kv, ( $+{k}, $+{v} // 1 );
104             }
105 13   100     50 my $pos = pos() // 0;
106 13 50       59 if ($pos != length) {
107 0         0 die "parse error in \"$_\".\n";
108             }
109             }
110 13         95 @kv;
111             }
112              
113             1;
114              
115             =head1 NAME
116              
117             Getopt::EX::Func - Function call interface
118              
119              
120             =head1 SYNOPSIS
121              
122             use Getopt::EX::Func qw(parse_func);
123              
124             my $func = parse_func(...);
125              
126             $func->call;
127              
128             =head1 DESCRIPTION
129              
130             This module provides the way to create function call object used in
131             L module set.
132              
133             If your script has B<--begin> option which tells the script to call
134             specific function at the beginning of execution. You can do it like
135             this:
136              
137             use Getopt::EX::Func qw(parse_func);
138              
139             GetOptions("begin:s" => $opt_begin);
140              
141             my $func = parse_func($opt_begin);
142              
143             $func->call;
144              
145             Then script can be invoked like this:
146              
147             % example -Mfoo --begin 'repeat(debug,msg=hello,count=2)'
148              
149             In this example, function C should be declared in module
150             C or in start up rc file such as F<~/.examplerc>. Actual
151             function call is done in this way:
152              
153             repeat ( debug => 1, msg => 'hello', count => '2' );
154              
155             As you can notice, arguments in the function call string is passed in
156             I =E I style. Parameter without value (C in
157             this example) is assigned value 1.
158              
159             Function itself can be implemented like this:
160              
161             our @EXPORT = qw(repeat);
162             sub repeat {
163             my %opt = @_;
164             print Dumper \%opt if $opt{debug};
165             for (1 .. $opt{count}) {
166             say $opt{msg};
167             }
168             }
169              
170             It is also possible to declare the function in-line:
171              
172             % example -Mfoo --begin 'sub{ say "wahoo!!" }'
173              
174             Function C can be used because the function is executed under
175             C context.