File Coverage

blib/lib/Getopt/EX/Long.pm
Criterion Covered Total %
statement 84 94 89.3
branch 11 20 55.0
condition 3 9 33.3
subroutine 22 25 88.0
pod 1 6 16.6
total 121 154 78.5


line stmt bran cond sub pod time code
1             package Getopt::EX::Long;
2 4     4   239569 use version; our $VERSION = version->declare("2.1.4");
  4         6083  
  4         21  
3              
4 4     4   430 use v5.14;
  4         23  
5 4     4   27 use warnings;
  4         6  
  4         103  
6 4     4   19 use Carp;
  4         5  
  4         615  
7              
8             *REQUIRE_ORDER = \$Getopt::Long::REQUIRE_ORDER;
9             *PERMUTE = \$Getopt::Long::PERMUTE;
10             *RETURN_IN_ORDER = \$Getopt::Long::RETURN_IN_ORDER;
11              
12             *Configure = \&Getopt::Long::Configure;
13             *HelpMessage = \&Getopt::Long::HelpMessage;
14             *VersionMessage = \&Getopt::Long::VersionMessage;
15              
16 4     4   35 use Exporter 'import';
  4         6  
  4         343  
17             our @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
18             our @EXPORT_OK = ( '&GetOptionsFromArray',
19             # '&GetOptionsFromString',
20             '&Configure',
21             '&HelpMessage',
22             '&VersionMessage',
23             '&ExConfigure',
24             );
25             our @ISA = qw(Getopt::Long);
26              
27 4     4   25 use Data::Dumper;
  4         8  
  4         255  
28 4     4   3495 use Getopt::Long();
  4         50012  
  4         136  
29 4     4   1389 use Getopt::EX::Loader;
  4         11  
  4         192  
30 4     4   27 use Getopt::EX::Func qw(parse_func);
  4         12  
  4         1202  
31              
32             my %ConfigOption = ( AUTO_DEFAULT => 1 );
33             my @ValidOptions = ('AUTO_DEFAULT' , @Getopt::EX::Loader::OPTIONS);
34              
35             my $loader;
36              
37             sub GetOptions {
38 2     2 1 10530 unshift @_, \@ARGV;
39 2         13 goto &GetOptionsFromArray;
40             }
41              
42             sub GetOptionsFromArray {
43 2     2 0 7 my $argv = $_[0];
44              
45 2 50       11 set_default() if $ConfigOption{AUTO_DEFAULT};
46              
47 2   33     17 $loader //= Getopt::EX::Loader->new(do {
48             map {
49 2 100       10 exists $ConfigOption{$_} ? ( $_ => $ConfigOption{$_} ) : ()
  12         47  
50             } @Getopt::EX::Loader::OPTIONS
51             });
52              
53 2         13 $loader->deal_with($argv);
54              
55 2         7 my @builtins = do {
56 2 100       14 if (ref $_[1] eq 'HASH') {
57 1         7 $loader->hashed_builtins($_[1]);
58             } else {
59 1         8 $loader->builtins;
60             }
61             };
62 2         8 push @_, @builtins;
63              
64 2         13 goto &Getopt::Long::GetOptionsFromArray;
65             }
66              
67             sub GetOptionsFromString {
68 0     0 0 0 die "GetOptionsFromString is not supported, yet.\n";
69             }
70              
71             sub ExConfigure {
72 0     0 0 0 my %opt = @_;
73 0         0 for my $name (@ValidOptions) {
74 0 0       0 if (exists $opt{$name}) {
75 0         0 $ConfigOption{$name} = delete $opt{$name};
76             }
77             }
78 0 0       0 warn "Unknown option: ", Dumper \%opt if %opt;
79             }
80              
81             sub set_default {
82 4     4   28 use List::Util qw(pairmap);
  4         8  
  4         904  
83 3   33 3 0 29 pairmap { $ConfigOption{$a} //= $b } get_default();
  2     2   16  
84             }
85              
86             sub get_default {
87 3     3 0 6 my @list;
88              
89 3 50       37 my $prog = ($0 =~ /([^\/]+)$/) ? $1 : return ();
90              
91 3 50       14 if (defined (my $home = $ENV{HOME})) {
92 3 100       101 if (-f (my $rc = "$home/.${prog}rc")) {
93 1         6 push @list, RCFILE => $rc;
94             }
95             }
96              
97 3         18 push @list, BASECLASS => "App::$prog";
98              
99 3         45 @list;
100             }
101              
102             1;
103              
104             ############################################################
105              
106             package Getopt::EX::Long::Parser;
107              
108 4     4   38 use strict;
  4         8  
  4         158  
109 4     4   34 use warnings;
  4         7  
  4         201  
110              
111 4     4   23 use List::Util qw(first);
  4         28  
  4         300  
112 4     4   28 use Data::Dumper;
  4         5  
  4         218  
113              
114 4     4   24 use Getopt::EX::Loader;
  4         33  
  4         1621  
115              
116             our @ISA = qw(Getopt::Long::Parser);
117              
118             sub new {
119 1     1   209 my $class = shift;
120              
121 1         3 my @exconfig;
122 1     0   23 while (defined (my $i = first { $_[$_] eq 'exconfig' } 0 .. $#_)) {
  0         0  
123 0         0 push @exconfig, @{ (splice @_, $i, 2)[1] };
  0         0  
124             }
125 1 50 33     11 if (@exconfig == 0 and $ConfigOption{AUTO_DEFAULT}) {
126 1         7 @exconfig = Getopt::EX::Long::get_default();
127             }
128              
129 1         13 my $obj = $class->SUPER::new(@_);
130              
131 1         32 my $loader = $obj->{exloader} = Getopt::EX::Loader->new(@exconfig);
132              
133 1         5 $obj;
134             }
135              
136             sub getoptionsfromarray {
137 1     1   18 my $obj = shift;
138 1         3 my $argv = $_[0];
139 1         2 my $loader = $obj->{exloader};
140              
141 1         5 $loader->deal_with($argv);
142              
143 1         12 my @builtins = do {
144 1 50       6 if (ref $_[1] eq 'HASH') {
145 1         4 $loader->hashed_builtins($_[1]);
146             } else {
147 0         0 $loader->builtins;
148             }
149             };
150 1         5 push @_, @builtins;
151              
152 1         8 $obj->SUPER::getoptionsfromarray(@_);
153             }
154              
155             1;
156              
157             =head1 NAME
158              
159             Getopt::EX::Long - Getopt::Long compatible glue module
160              
161             =head1 SYNOPSIS
162              
163             use Getopt::EX::Long;
164             GetOptions(...);
165              
166             or
167              
168             require Getopt::EX::Long;
169             my $parser = Getopt::EX::Long::Parser->new(
170             config => [ Getopt::Long option ... ],
171             exconfig => [ Getopt::EX::Long option ...],
172             );
173              
174             =head1 DESCRIPTION
175              
176             L is almost compatible to L and you
177             can just replace module declaration and it should work just same as
178             before (See L section).
179              
180             Besides working same, user can define their own option aliases and
181             write dynamically loaded extension module. If the command name is
182             I,
183              
184             ~/.examplerc
185              
186             file is loaded by default. In this rc file, user can define their own
187             option with macro processing. This is useful when the command takes
188             complicated arguments.
189              
190             Also, special command option preceded by B<-M> is taken and
191             corresponding perl module is loaded. Module is assumed under the
192             specific base class. For example,
193              
194             % example -Mfoo
195              
196             will load C module, by default.
197              
198             This module is normal perl module, so user can write any kind of
199             program. If the module is specified with initial function call, it is
200             called at the beginning of command execution. Suppose that the
201             module I is specified like this:
202              
203             % example -Mfoo::bar(buz=100) ...
204              
205             Then, after the module B is loaded, function I is called
206             with the parameter I which has value 100.
207              
208             If the module includes C<__DATA__> section, it is interpreted just
209             same as rc file. So you can define arbitrary option there. Combined
210             with startup function call described above, it is possible to control
211             module behavior by user defined option.
212              
213             As for start-up file and Module specification, read
214             L document for detail.
215              
216             =head1 CONFIG OPTIONS
217              
218             Config options are set by B or B
219             parameter for B method.
220              
221             =over 4
222              
223             =item AUTO_DEFAULT
224              
225             Config option B and B are automatically set based
226             on the name of command executable. If you don't want this behavior,
227             set B to 0.
228              
229             =back
230              
231             Other options including B and B are passed to
232             B. Read its document for detail.
233              
234             =head1 INCOMPATIBILITY
235              
236             Subroutine B is not supported.
237              
238             =head1 SEE ALSO
239              
240             L,
241             L,
242             L