File Coverage

blib/lib/Getopt/EX/LabeledParam.pm
Criterion Covered Total %
statement 69 99 69.7
branch 19 32 59.3
condition 1 3 33.3
subroutine 13 18 72.2
pod 4 10 40.0
total 106 162 65.4


line stmt bran cond sub pod time code
1             package Getopt::EX::LabeledParam;
2 10     10   4823 use version; our $VERSION = version->declare("2.1.3");
  10         23  
  10         50  
3              
4 10     10   870 use v5.14;
  10         38  
5 10     10   53 use warnings;
  10         37  
  10         355  
6 10     10   56 use Carp;
  10         30  
  10         734  
7              
8 10     10   82 use Exporter 'import';
  10         29  
  10         865  
9             our @EXPORT = qw();
10             our @EXPORT_OK = qw();
11             our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
12              
13 10     10   67 use Data::Dumper;
  10         28  
  10         480  
14 10     10   2473 use Getopt::EX::Module;
  10         37  
  10         446  
15 10     10   60 use Getopt::EX::Func qw(parse_func);
  10         35  
  10         11646  
16              
17             sub new {
18 2     2 1 5 my $class = shift;
19              
20 2         14 my $obj = bless {
21             NEWLABEL => 0,
22             CONCAT => "",
23             HASH => {},
24             LIST => [],
25             }, $class;
26              
27 2 50       8 $obj->configure(@_) if @_;
28              
29 2         7 $obj;
30             }
31              
32             sub configure {
33 2     2 1 4 my $obj = shift;
34 2         9 while (@_ >= 2) {
35 4         14 my($k, $v) = splice @_, 0, 2;
36 4 50 33     28 if ($k =~ /^\w/ and exists $obj->{$k}) {
37 4         14 $obj->{$k} = $v;
38             }
39             }
40 2         6 $obj;
41             }
42              
43 1     1 0 16 sub get_hash { shift->{HASH} }
44              
45             sub set_hash {
46 0     0 0 0 my $obj = shift;
47 0         0 %{ $obj->{HASH} } = @_;
  0         0  
48 0         0 $obj;
49             }
50              
51 0     0 0 0 sub list { @{ shift->{LIST} } }
  0         0  
52              
53             sub push_list {
54 0     0 0 0 my $obj = shift;
55 0         0 push @{ $obj->{LIST} }, @_;
  0         0  
56 0         0 $obj;
57             }
58              
59             sub set_list {
60 0     0 0 0 my $obj = shift;
61 0         0 @{ $obj->{LIST} } = @_;
  0         0  
62 0         0 $obj;
63             }
64              
65             sub append {
66 0     0 1 0 my $obj = shift;
67 0         0 for my $item (@_) {
68 0 0       0 if (ref $item eq 'ARRAY') {
    0          
69 0         0 push @{$obj->{LIST}}, @$item;
  0         0  
70             }
71             elsif (ref $item eq 'HASH') {
72 0         0 while (my($k, $v) = each %$item) {
73 0         0 $obj->{HASH}->{$k} = $v;
74             }
75             }
76             else {
77 0         0 push @{$obj->{LIST}}, $item;
  0         0  
78             }
79             }
80             }
81              
82             sub load_params {
83 6     6 1 3747 my $obj = shift;
84              
85 6         23 my $re_field = qr/[\w\*\?]+/;
86             map {
87 11         27 my $spec = pop @$_;
88 11         14 my @spec;
89 11         45 while ($spec =~ s/\&([:\w]+ (?: \( [^)]* \) )? ) ;?//x) { # &func
90 5         22 push @spec, parse_func({ PACKAGE => 'main' }, $1);
91             }
92 11 100       33 if ($spec =~ s/\b(sub\s*{.*)//) { # sub { ... }
93 2         11 push @spec, parse_func({ PACKAGE => 'main' }, $1);
94             }
95 11 100       32 push @spec, $spec if $spec ne '';
96 11 50       36 my $c = @spec > 1 ? [ @spec ] : @spec == 1 ? $spec[0] : "";
    100          
97 11 50       24 if (@$_ == 0) {
98 0         0 $obj->push_list($c);
99             }
100             else {
101             map {
102 22 100       73 if ($c =~ /^\++(.*)/) { # LABEL=+ATTR
    100          
103 9         29 $obj->{HASH}->{$_} .= $obj->{CONCAT} . "$1";
104             }
105             elsif ($c =~ /^\-+(.*)$/i) { # LABEL=-ATTR
106 2         7 my $chars = $1 =~ s/(?=\W)/\\/gr;
107 2         20 $obj->{HASH}->{$_} =~ s/[$chars]+//g;
108             }
109             else {
110 11         52 $obj->{HASH}->{$_} = $c;
111             }
112             }
113             map {
114             # plain label
115 11 100       22 if (not /\W/) {
  11         32  
116 5 50       12 if (exists $obj->{HASH}->{$_}) {
117 5         16 $_;
118             } else {
119 0 0       0 if ($obj->{NEWLABEL}) {
120 0         0 $_;
121             } else {
122 0         0 warn "$_: Unknown label\n";
123 0         0 ();
124             }
125             }
126             }
127             # wild card
128             else {
129 6         11 my @labels = match_glob($_, keys %{$obj->{HASH}});
  6         21  
130 6 50       17 if (@labels == 0) {
131 0         0 warn "$_: Unmatched label\n";
132             }
133 6         18 @labels;
134             }
135             }
136             @$_;
137             }
138             }
139             map {
140 11 50       192 if (my @field = /\G($re_field)=/gp) {
141 11         52 [ @field, ${^POSTMATCH} ];
142             } else {
143 0         0 [ $_ ];
144             }
145             }
146             map {
147 6         17 m/( (?: $re_field= )*
  11         381  
148             (?: .* \b sub \s* \{ .*
149             | (?: \([^)]*\) | [^,\s] )+
150             )
151             )/gx;
152             }
153             @_;
154              
155 6         29 $obj;
156             }
157              
158             sub match_glob {
159 6     6 0 10 local $_ = shift;
160 6         12 s/\?/./g;
161 6         13 s/\*/.*/g;
162 6         67 my $regex = qr/^$_$/;
163 6         15 grep { $_ =~ $regex } @_;
  36         128  
164             }
165              
166             1;
167              
168             =head1 NAME
169              
170             Getopt::EX::LabeledParam - Labeled parameter handling
171              
172              
173             =head1 SYNOPSIS
174              
175             GetOptions('colormap|cm:s' => @opt_colormap);
176              
177             # default values
178             my %colormap = ( FILE => 'DR', LINE => 'Y', TEXT => '' );
179             my @colors = qw( /544 /545 /445 /455 /545 /554 );
180              
181             require Getopt::EX::LabeledParam;
182             my $cmap = Getopt::EX::LabeledParam
183             ->new( NEWLABEL => 0,
184             HASH => \%colormap,
185             LIST => \@colors )
186             ->load_params(@opt_colormap);
187              
188              
189             =head1 DESCRIPTION
190              
191             This module implements super class of L.
192              
193             Parameters can be given in two ways: one in labeled table, and one in
194             indexed list.
195              
196             Handler maintains hash and list objects, and labeled values are stored
197             in hash, non-label values are in list automatically. User can mix
198             both specifications.
199              
200             When the value field has a special form of function call,
201             L object is created and stored for that entry. See
202             L section in L for more detail.
203              
204             =head2 HASH
205              
206             Basically, labeled parameter is defined by B
207              
208             FILE=R
209              
210             Definition can be connected by comma (C<,>):
211              
212             FILE=R,LINE=G
213              
214             Multiple labels can be set for same value:
215              
216             FILE=LINE=TEXT=R
217              
218             Wildcard C<*> and C can be used in label name, and they matches
219             existing hash key name. If labels C and C exists
220             in hash,
221              
222             *FILE=R
223              
224             and
225              
226             OLD_FILE=NEW_FILE=R
227              
228             produces same result.
229              
230             If B part start with plus (C<+>) character, it is appended to
231             current value. At this time, C string is inserted before
232             additional string. Default C strings is empty, so use
233             configure method to set. If B part start with minus (C<->)
234             character, following characters are deleted from the current value.
235              
236             =head2 LIST
237              
238             If B
239             stored in list object. For example,
240              
241             R,G,B,C,M,Y
242              
243             makes six entries in the list. The list object is accessed by index,
244             rather than label.
245              
246             =head1 METHODS
247              
248             =over 4
249              
250             =item B
251              
252             =item B
253              
254             =over 4
255              
256             =item B =E I
257              
258             =item B =E I
259              
260             B and B reference can be set by B or B
261             method. You can provide default setting of hash and list, and it is
262             usually easier to access those values directly, rather than through
263             class methods.
264              
265             =item B =E 0/1
266              
267             By default, B does not create new entry in hash table,
268             and absent label is ignored. Setting parameter true makes
269             it possible create a new hash entry.
270              
271             =item B =E I
272              
273             Set concatenation string inserted before appending string.
274              
275             =back
276              
277             =item B I
278              
279             Load option list into the object.
280              
281             =item B HASHREF or LIST
282              
283             Provide simple interface to append colormap hash or color list. If a
284             hash reference is given, all entry of the hash is appended to the
285             colormap. Otherwise, they are appended anonymous color list.
286              
287             =back
288              
289             =head1 SEE ALSO
290              
291             L
292              
293             # LocalWords: CONCAT hashref listref NEWLABEL HASHREF colormap