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


line stmt bran cond sub pod time code
1             package Getopt::EX::Module;
2 11     11   296 use version; our $VERSION = version->declare("2.1.2");
  10         18  
  10         59  
3              
4 11     11   879 use v5.14;
  11         53  
5 11     10   72 use warnings;
  10         36  
  10         352  
6 10     10   84 use Carp;
  10         46  
  10         655  
7              
8 10     10   61 use Exporter 'import';
  10         28  
  10         737  
9             our @EXPORT = qw();
10             our %EXPORT_TAGS = ( );
11             our @EXPORT_OK = qw();
12              
13 10     10   75 use Data::Dumper;
  10         26  
  10         536  
14 10     10   5140 use Text::ParseWords qw(shellwords);
  10         14967  
  10         630  
15 10     10   72 use List::Util qw(first pairmap);
  10         59  
  10         697  
16              
17 10     10   4288 use Getopt::EX::Func qw(parse_func);
  10         25  
  10         6307  
18              
19             sub new {
20 22     22 1 43 my $class = shift;
21 22         237 my $obj = bless {
22             Module => undef,
23             Base => undef,
24             Mode => { FUNCTION => 0, WILDCARD => 0 },
25             Define => [],
26             Expand => [],
27             Option => [],
28             Builtin => [],
29             Automod => [],
30             Autoload => {},
31             Call => [],
32             Help => [],
33             }, $class;
34              
35 22 50       104 configure $obj @_ if @_;
36              
37 13         42 $obj;
38             }
39              
40             sub configure {
41 22     22 1 35 my $obj = shift;
42 22         71 my %opt = @_;
43              
44 22 50       68 if (my $base = delete $opt{BASECLASS}) {
45 22         61 $obj->{Base} = $base;
46             }
47              
48 22 100       87 if (my $file = delete $opt{FILE}) {
    50          
49 1 50       47 if (open my $fh, "<:encoding(utf8)", $file) {
50 1         11773 $obj->module($file);
51 1         5 $obj->readrc($fh);
52             }
53             }
54             elsif (my $module = delete $opt{MODULE}) {
55 21   50     93 my $pkg = $opt{PACKAGE} || 'main';
56 21         34 my @base = do {
57 21 100       61 if (ref $obj->{Base} eq 'ARRAY') {
58 2         3 @{$obj->{Base}};
  2         7  
59             } else {
60 19   50     65 ($obj->{Base} // '');
61             }
62             };
63 21         51 while (@base) {
64 24         45 my $base = shift @base;
65 24 100       90 my $mod = $base ? "$base\::$module" : $module;
66 24     6   2140 eval "package $pkg; use $mod;";
  6     5   1103  
  1     2   9  
  1     2   9  
  5     2   2232  
  5     2   1046  
  5     2   104  
  2     2   278  
  1         214  
  1         13  
  2         618  
  1         129  
  1         21  
  2         342  
  0         0  
  0         0  
  2         176  
  2         201  
  2         27  
  2         540  
  0         0  
  0         0  
  2         148  
  2         208  
  2         28  
67 24 100       111 if ($@) {
68 12         91 my $path = $mod =~ s{::}{/}gr . ".pm";
69 12 100 66     111 next if @base and $@ =~ /Can't locate \Q$path\E/;
70 9         1707 croak "$mod: $@";
71             }
72 12         67 $obj->module($mod);
73 12         41 $obj->define('__PACKAGE__' => $mod);
74 12         56 local *data = "$mod\::DATA";
75 12 50       96 if (not eof *data) {
76 12         37 my $pos = tell *data;
77 12         53 $obj->readrc(*data);
78             # recover position in case called multiple times
79 12 50 50     206 seek *data, $pos, 0 or die "seek: $!" if $pos >= 0;
80             }
81 12         56 last;
82             }
83             }
84              
85 13 50       62 if (my $builtin = delete $opt{BUILTIN}) {
86 0         0 $obj->builtin(@$builtin);
87             }
88              
89 13 50       34 warn "Unprocessed option: ", Dumper \%opt if %opt;
90              
91 13         30 $obj;
92             }
93              
94             sub readrc {
95 13     13 0 21 my $obj = shift;
96 13         39 my $fh = shift;
97 13         21 my $text = do { local $/; <$fh> };
  13         49  
  13         321  
98 13         93 for ($text) {
99 13 50       70 s/^__(?:CODE|PERL)__\s*\n(.*)//ms and do {
100             package main;
101 10     10   83 no warnings 'once';
  10         28  
  10         6333  
102 0         0 local $main::MODULE = $obj;
103 0         0 eval $1;
104 0 0       0 die if $@;
105             };
106 13         164 s/^\s*(?:#.*)?\n//mg;
107 13         52 s/\\\n//g;
108             }
109 13         56 $obj->parsetext($text);
110 13         50 $obj;
111             }
112              
113             ############################################################
114              
115             sub module {
116 51     51 1 86 my $obj = shift;
117             @_ ? $obj->{Module} = shift
118 51 100       172 : $obj->{Module};
119             }
120              
121             sub title {
122 0     0 0 0 my $obj = shift;
123 0         0 my $mod = $obj->module;
124 0 0       0 $mod =~ m{ .* [:/] (.+) }x ? $1 : $mod;
125             }
126              
127             sub define {
128 19     19 1 36 my $obj = shift;
129 19         32 my $name = shift;
130 19         37 my $list = $obj->{Define};
131 19 50       43 if (@_) {
132 19         217 my $re = qr/\Q$name/;
133 19         86 unshift(@$list, [ $name, $re, shift ]);
134             } else {
135 0     0   0 first { $_->[0] eq $name } @$list;
  0         0  
136             }
137             }
138              
139             sub expand {
140 94     94 1 130 my $obj = shift;
141 94         159 local *_ = shift;
142 94         127 for my $defent (@{$obj->{Define}}) {
  94         185  
143 100         228 my($name, $re, $string) = @$defent;
144 100         375 s/$re/$string/g;
145             }
146 94   0     221 s{ (\$ENV\{ (['"]?) \w+ \g{-1} \}) }{ eval($1) // $1 }xge;
  0         0  
147             }
148              
149             sub mode {
150 41     41 1 59 my $obj = shift;
151 41 100       152 @_ == 1 and return $obj->{Mode}->{uc shift};
152 5 50       12 die "Unexpected parameter." if @_ % 2;
153             pairmap {
154 5     5   39 $obj->{Mode}->{uc $a} = $b;
155 5         52 } @_;
156             }
157              
158 10     10   86 use constant BUILTIN => "__BUILTIN__";
  10         31  
  10         18731  
159 27     27 0 105 sub validopt { $_[0] ne BUILTIN }
160              
161             sub setlocal {
162 0     0 1 0 my $obj = shift;
163 0         0 $obj->setlist("Expand", @_);
164             }
165              
166             sub setopt {
167 94     94 1 197 my $obj = shift;
168 94         314 $obj->setlist("Option", @_);
169             }
170              
171             sub setlist {
172 94     94 0 121 my $obj = shift;
173 94         232 my $list = $obj->{+shift};
174 94         141 my $name = shift;
175 94         124 my @args = do {
176 94 50       168 if (ref $_[0] eq 'ARRAY') {
177 0         0 @{ $_[0] };
  0         0  
178             } else {
179 94         203 map { shellwords $_ } @_;
  94         276  
180             }
181             };
182              
183 94         5693 for (my $i = 0; $i < @args; $i++) {
184 94 50       221 if (my @opt = $obj->getlocal($args[$i])) {
185 0         0 splice @args, $i, 1, @opt;
186 0         0 redo;
187             }
188             }
189              
190 94         207 for (@args) {
191 94         205 $obj->expand(\$_);
192             }
193 94         294 unshift @$list, [ $name, @args ];
194             }
195              
196             sub getopt {
197 113     113 1 166 my $obj = shift;
198 113         299 my($name, %opt) = @_;
199 113 50 33     292 return () if $name eq 'default' and not $opt{DEFAULT} || $opt{ALL};
      66        
200              
201 113         168 my $list = $obj->{Option};
202             my $e = first {
203 879 100 66 879   1554 $_->[0] eq $name and $opt{ALL} || validopt($_->[1])
204 113         450 } @$list;
205 113 100       349 my @e = $e ? @$e : ();
206 113         157 shift @e;
207              
208             # check autoload
209 113 100       222 unless (@e) {
210 95         136 my $hash = $obj->{Autoload};
211 95         134 for my $mod (@{$obj->{Automod}}) {
  95         202  
212 0 0       0 if (exists $hash->{$mod}->{$name}) {
213 0         0 delete $hash->{$mod};
214 0         0 return ($mod, $name);
215             }
216             }
217             }
218              
219 113         299 @e;
220             }
221              
222             sub getlocal {
223 94     94 0 146 my $obj = shift;
224 94         161 my($name, %opt) = @_;
225              
226 94     0   352 my $e = first { $_->[0] eq $name } @{$obj->{Expand}};
  0         0  
  94         282  
227 94 50       326 my @e = $e ? @$e : ();
228 94         141 shift @e;
229 94         330 @e;
230             }
231              
232             sub expand_args {
233 18     18 0 33 my $obj = shift;
234 18         36 my @args = @_;
235              
236             ##
237             ## Expand `&function' style arguments.
238             ##
239 18 100       60 if ($obj->mode('function')) {
240             @args = map {
241 1 50       5 if (/^&(.+)/) {
  1         7  
242 1         3 my $func = parse_func $obj->module . "::$1";
243 1 50       13 $func ? $func->call : $_;
244             } else {
245 0         0 $_;
246             }
247             }
248             @args;
249             }
250              
251             ##
252             ## Expand wildcards.
253             ##
254 18 100       62 if ($obj->mode('wildcard')) {
255             @args = map {
256 4         9 my @glob = glob $_;
  4         355  
257 4 100       36 @glob ? @glob : $_;
258             } @args;
259             }
260              
261 18         65 @args;
262             }
263              
264             sub default {
265 16     16 1 29 my $obj = shift;
266 16         47 $obj->getopt('default', DEFAULT => 1);
267             }
268              
269             sub options {
270 0     0 1 0 my $obj = shift;
271 0         0 my $opt = $obj->{Option};
272 0         0 my $automod = $obj->{Automod};
273 0         0 my $auto = $obj->{Autoload};
274 0         0 my @opt = reverse map { $_->[0] } @$opt;
  0         0  
275 0         0 my @auto = map { sort keys %{$auto->{$_}} } @$automod;
  0         0  
  0         0  
276 0         0 (@opt, @auto);
277             }
278              
279             sub help {
280 0     0 1 0 my $obj = shift;
281 0         0 my $name = shift;
282 0         0 my $list = $obj->{Help};
283 0 0       0 if (@_) {
284 0         0 unshift(@$list, [ $name, shift ]);
285             } else {
286 0     0   0 my $e = first { $_->[0] eq $name } @$list;
  0         0  
287 0 0       0 $e ? $e->[1] : undef;
288             }
289             }
290              
291             sub parsetext {
292 13     13 0 33 my $obj = shift;
293 13         30 my $text = shift;
294 13         57 my $re = qr{
295             (?|
296             # HERE document
297             (.+\s) << (?\w+) \n
298             (? (?s:.*?) \n )
299             \g{mark}\n
300             |
301             (.+)\n?
302             )
303             }x;
304 13         113 while ($text =~ m/$re/g) {
305 106         168 my $line = do {
306 106 50       567 if (defined $+{here}) {
307 0         0 $1 . $+{here};
308             } else {
309 106         302 $1;
310             }
311             };
312 106         273 $obj->parseline($line);
313             }
314 13         38 $obj;
315             }
316              
317             sub parseline {
318 106     106 0 164 my $obj = shift;
319 106         144 my $line = shift;
320 106         294 my @arg = split ' ', $line, 3;
321              
322 106         265 my %min_args = ( mode => 1, DEFAULT => 3 );
323 106   66     401 my $min_args = $min_args{$arg[0]} || $min_args{DEFAULT};
324 106 50       260 if (@arg < $min_args) {
325 0         0 warn sprintf("Parse error in %s: %s\n", $obj->title, $line);
326 0         0 return;
327             }
328              
329             ##
330             ## in-line help document after //
331             ##
332 106   50     245 my $optname = $arg[1] // '';
333 106 100       240 if ($arg[0] eq "builtin") {
334 28         59 for ($optname) {
335 28         109 s/[^\w\-].*//; # remove alternative names after `|'.
336 28 50       119 s/^(?=([\w\-]+))/length($1) == 1 ? '-' : '--'/e;
  28         141  
337             }
338             }
339 106 50 66     392 if ($arg[2] and $arg[2] =~ s{ (?:^|\s+) // \s+ (?.*) }{}x) {
340 0         0 $obj->help($optname, $+{message});
341             }
342              
343             ##
344             ## Commands
345             ##
346 106 100       324 if ($arg[0] eq "define") {
    100          
    50          
    50          
    100          
    50          
    50          
    0          
347 7         32 $obj->define($arg[1], $arg[2]);
348             }
349             elsif ($arg[0] eq "option") {
350 66         165 $obj->setopt($arg[1], $arg[2]);
351             }
352             elsif ($arg[0] eq "expand") {
353 0         0 $obj->setlocal($arg[1], $arg[2]);
354             }
355             elsif ($arg[0] eq "defopt") {
356 0         0 $obj->define($arg[1], $arg[2]);
357 0         0 $obj->setopt($arg[1], $arg[1]);
358             }
359             elsif ($arg[0] eq "builtin") {
360 28         78 $obj->setopt($optname, BUILTIN);
361 28 50       145 if ($arg[2] =~ /^\\?(?[\$\@\%\&])(?[\w:]+)/) {
362 28         220 my($mark, $name) = @+{"mark", "name"};
363 28         93 my $mod = $obj->module;
364 28   33     220 /:/ or s/^/$mod\::/ for $name;
365 10     10   88 no strict 'refs';
  10         18  
  10         5917  
366 28         109 $obj->builtin($arg[1] => {'$' => \${$name},
367 28         79 '@' => \@{$name},
368 28         62 '%' => \%{$name},
369 28         62 '&' => \&{$name}}->{$mark});
  28         143  
370             }
371             }
372             elsif ($arg[0] eq "autoload") {
373 0         0 shift @arg;
374 0         0 $obj->autoload(@arg);
375             }
376             elsif ($arg[0] eq "mode") {
377 5         9 shift @arg;
378 5         9 for (@arg) {
379 5 50       25 if (/^(no-?)?(.*)/i) {
380 5 50       29 $obj->mode($2 => $1 ? 0 : 1);
381             }
382             }
383             }
384             elsif ($arg[0] eq "help") {
385 0         0 $obj->help($arg[1], $arg[2]);
386             }
387             else {
388 0         0 warn sprintf("Unknown operator \"%s\" in %s\n",
389             $arg[0], $obj->title);
390             }
391              
392 106         876 $obj;
393             }
394              
395             sub builtin {
396 32     32 1 54 my $obj = shift;
397 32         54 my $list = $obj->{Builtin};
398 32 100       134 @_ ? push @$list, @_
399             : @$list;
400             }
401              
402             sub autoload {
403 0     0 1 0 my $obj = shift;
404 0         0 my $module = shift;
405 0         0 my @option = map { split ' ' } @_;
  0         0  
406              
407 0   0     0 my $hash = ($obj->{Autoload}->{$module} //= {});
408 0         0 my $list = $obj->{Automod};
409 0         0 for (@option) {
410 0         0 $hash->{$_} = 1;
411 0         0 $obj->help($_, "autoload: $module");
412             }
413 0 0       0 push @$list, $module if not grep { $_ eq $module } @$list;
  0         0  
414             }
415              
416             sub call {
417 9     9 0 24 my $obj = shift;
418 9         25 my $list = $obj->{Call};
419 9 50       40 @_ ? push @$list, @_
420             : @$list;
421             }
422              
423             sub call_if_defined {
424 18     18 0 58 my($module, $name, @param) = @_;
425 18         71 my $func = "$module\::$name";
426 18 100       120 if (defined &$func) {
427 10     10   105 no strict 'refs';
  10         47  
  10         2276  
428 5         20 $func->(@param);
429             }
430             }
431              
432             sub run_inits {
433 9     9 0 19 my $obj = shift;
434 9         17 my $argv = shift;
435 9         26 my $module = $obj->module;
436 9         24 local @ARGV = ();
437              
438 9         33 call_if_defined $module, "initialize" => ($obj, $argv);
439              
440 9         52 for my $call ($obj->call) {
441 0 0       0 my $func = $call->can('call') ? $call : parse_func($call);
442 0         0 $func->call;
443             }
444              
445 9         28 call_if_defined $module, "finalize" => ($obj, $argv);
446             }
447              
448             1;
449              
450             =head1 NAME
451              
452             Getopt::EX::Module - RC/Module data container
453              
454             =head1 SYNOPSIS
455              
456             use Getopt::EX::Module;
457              
458             my $bucket = Getopt::EX::Module->new(
459             BASECLASS => $baseclass,
460             FILE => $file_name / MODULE => $module_name,
461             );
462              
463             =head1 DESCRIPTION
464              
465             This module is usually used from L, and keeps
466             all data about loaded rc file or module.
467              
468             =head2 MODULE
469              
470             After user defined module was loaded, subroutine C is
471             called if it exists in the module. At this time, container object is
472             passed to the function as the first argument and following command
473             argument pointer as the second. So you can use it to directly touch
474             the object contents through class interface.
475              
476             Following C, function defined with module option is called.
477              
478             Finally subroutine C is called if defined, to finalize start
479             up process of the module.
480              
481             =head2 FILE
482              
483             As for rc file, section after C<__PERL__> mark is executed as Perl
484             program. At this time, module object is assigned to variable
485             C<$MODULE>, and you can access module API through it.
486              
487             if (our $MODULE) {
488             $MODULE->setopt('default', '--number');
489             }
490              
491             =head1 RC FILE FORMAT
492              
493             =over 7
494              
495             =item B
496              
497             Define option I. Argument I is processed by
498             I routine defined in L module. Be sure
499             that this module sometimes requires escape backslashes.
500              
501             Any kind of string can be used for option name but it is not combined
502             with other options.
503              
504             option --fromcode --outside='(?s)\/\*.*?\*\/'
505             option --fromcomment --inside='(?s)\/\*.*?\*\/'
506              
507             If the option named B is defined, it will be used as a
508             default option.
509              
510             For the purpose to include following arguments within replaced
511             strings, two special notations can be used in option definition.
512              
513             String C<< $ >> is replaced by the Ith argument after the
514             substituted option, where I is number start from one. Because C<<
515             $<0> >> is replaced by the defined option itself, you have to care
516             about infinite loop.
517              
518             String C<< $ >> is replaced by following command line argument
519             and the argument is removed from list.
520              
521             For example, when
522              
523             option --line --le &line=$
524              
525             is defined, command
526              
527             greple --line 10,20-30,40
528              
529             will be evaluated as this:
530              
531             greple --le &line=10,20-30,40
532              
533             There are special arguments to manipulate option behavior and the rest
534             of arguments. Argument C<< $ >> moves all following arguments
535             there, C<< $ >> just removes them, and C<< $ >> copies
536             them. These does not work when included as a part of string.
537              
538             They take optional one or two parameters, those are passed to Perl
539             C function as I and I. C<< $ >> is
540             same as C<< $ >>; C<< $ >> is same as C<< $<1> >>;
541             C<< $ >> is same as C<< $ >>; C<< $ >> moves
542             the last argument; C<< $move(1,1) >> moves second argument. Next
543             example exchange following two arguments.
544              
545             option --exch $
546              
547             You can use recently introduced C<< $ >> to ignore the
548             argument. Some existing module uses C<< $ >> for the same
549             purpose, because it effectively do nothing.
550              
551             option --deprecated $
552             option --deprecated $
553              
554             =item B I I
555              
556             Define local option I. Command B is almost same as
557             command B
558             by this command is expanded in, and only in, the process of
559             definition, while option definition is expanded when command arguments
560             are processed.
561              
562             This is similar to string macro defined by following B
563             command. But macro expantion is done by simple string replacement, so
564             you have to use B to define option composed by multiple
565             arguments.
566              
567             =item B I I
568              
569             Define string macro. This is similar to B
570             not processed by I and treated just a simple text, so
571             meta-characters can be included without escape. Macro expansion is
572             done for option definition and other macro definition. Macro is not
573             evaluated in command line option. Use option directive if you want to
574             use in command line,
575              
576             define (#kana) \p{InKatakana}
577             option --kanalist --nocolor -o --join --re '(#kana)+(\n(#kana)+)*'
578             help --kanalist List up Katakana string
579              
580             Here-document can be used to define string inluding newlines.
581              
582             define __script__ <
583             {
584             ...
585             }
586             EOS
587              
588             Special macro C<__PACKAGE__> is pre-defined to module name.
589              
590             =item B I
591              
592             Define help message for option I.
593              
594             =item B I I
595              
596             Define built-in option which should be processed by option parser.
597             Defined option spec can be taken by B method, and script is
598             responsible to give them to parser.
599              
600             Arguments are assumed to be L style spec, and
601             I is string start with C<$>, C<@> or C<%>. They will be
602             replaced by a reference to the object which the string represent.
603              
604             =item B I I
605              
606             Define module which should be loaded automatically when specified
607             option is found in the command arguments.
608              
609             For example,
610              
611             autoload -Mdig --dig
612              
613             replaces option "I<--dig>" to "I<-Mdig --dig>", and I module is
614             loaded before processing I<--dig> option.
615              
616             =item B [I]I
617              
618             Set or unset mode I. Currently, B and B can
619             be used as a name. See METHODS section.
620              
621             Next is an example used in L module to
622             produce parameters on the fly.
623              
624             mode function
625             option --dyncmap &dyncmap($)
626              
627             =back
628              
629             =head1 METHODS
630              
631             =over 4
632              
633             =item B I
634              
635             Create object. Parameters are just passed to C method.
636              
637             =item B
638              
639             Configure object. Parameter is passed in hash name and value style.
640              
641             =over 4
642              
643             =item B =E I
644              
645             Set base class.
646              
647             =item B =E I
648              
649             Load file.
650              
651             =item B =E I
652              
653             Load module.
654              
655             =back
656              
657             =item B I, I
658              
659             Define macro.
660              
661             =item B I, I
662              
663             Set option.
664              
665             =item B I, I
666              
667             Set option which is effective only in the module.
668              
669             =item B I
670              
671             Get option. Takes option name and return it's definition if
672             available. It doesn't return I option, get it by I
673             method.
674              
675             =item B
676              
677             Get default option. Use C ...)> to set.
678              
679             =item B
680              
681             Get built-in options.
682              
683             =item B
684              
685             Set autoload module.
686              
687             =item B
688              
689             Set argument treatment mode. Arguments produced by option expansion
690             will be the subject of post-process. This method define the behavior
691             of it.
692              
693             =over 4
694              
695             =item B(B => 1)
696              
697             Interpret the argument start with '&' as a function, and replace it by
698             the result of the function call.
699              
700             =item B(B => 1)
701              
702             Replace wildcard argument by matched file names.
703              
704             =back
705              
706             =back