File Coverage

blib/lib/Test/Smoke/App/AppOption.pm
Criterion Covered Total %
statement 62 63 98.4
branch 30 30 100.0
condition 14 14 100.0
subroutine 8 10 80.0
pod 4 4 100.0
total 118 121 97.5


line stmt bran cond sub pod time code
1             package Test::Smoke::App::AppOption;
2 10     10   333360 use warnings;
  10         55  
  10         366  
3 10     10   54 use strict;
  10         20  
  10         202  
4 10     10   46 use Carp;
  10         20  
  10         656  
5              
6             our $VERSION = '0.002';
7              
8 10     10   61 use base 'Test::Smoke::ObjectBase';
  10         28  
  10         7241  
9              
10             our $HTFMT = "%-30s - %s\n";
11              
12             =head1 NAME
13              
14             Test::Smoke::App::AppOption - Object that represents an Application Option.
15              
16             =head1 SYNOPSIS
17              
18             use Test::Smoke::App::AppOption;
19             my $o = Test::Smoke::App::AppOption->new(
20             );
21             printf "%s\n", $o->gol_option;
22             print $o->show_helptext;
23              
24             =head1 DESCRIPTION
25              
26             =head2 Test::Smoke::App::AppOption->new(%arguments)
27              
28             =head3 Arguments
29              
30             Named:
31              
32             =over
33              
34             =item name => $basic_option_name [required]
35              
36             =item option => $option_extention (see L)
37              
38             =item allow => $arrary_ref_with alternatives
39              
40             =item default => $default_value
41              
42             =item helptext => $text_to_show_with help
43              
44             =back
45              
46             =head3 Returns
47              
48             An instance.
49              
50             =head3 Exceptions
51              
52             croak()s when:
53              
54             =over
55              
56             =item B
57              
58             =item B
59              
60             =back
61              
62             =cut
63              
64             sub new {
65 746     746 1 4403 my $class = shift;
66 746         3633 my %args = @_;
67              
68             my $struct = {
69             _name => undef,
70             _option => "",
71             _allow => undef,
72             _default => undef,
73             _helptext => "",
74             _configtext => "",
75             _configtype => "prompt",
76 0     0   0 _configalt => sub { [] },
77       0     _configdft => sub { },
78 746         6822 _configfnex => 0,
79             _configord => 0,
80             };
81 746         2079 $struct->{_had_default} = exists $args{default};
82 746         2992 for my $known (keys %$struct) {
83 8952         22982 (my $key = $known) =~ s/^_//;
84 8952 100       22722 $struct->{$known} = delete $args{$key} if exists $args{$key};
85             }
86 746 100 100     3184 if (!defined($struct->{_name}) || !length($struct->{_name})) {
87 2         320 croak("Required option 'name' not given.");
88             }
89 744 100 100     2564 if ( defined($struct->{_allow})
90             and (ref($struct->{_allow}) !~ /^(?:ARRAY|Regexp|CODE)$/))
91             {
92 1         111 croak("Option 'allow' must be an ArrayRef|CodeRef|RegExp when set");
93             }
94             # had_default(): order == code < configfile < commandline
95              
96 743         6582 return bless $struct, $class;
97             }
98              
99             =head2 $option->allowed($value[, $allow])
100              
101             Checks if a value is in a set of allowed values.
102              
103             =head3 Arguments
104              
105             Positional.
106              
107             =over
108              
109             =item $value (the value to check)
110              
111             =item $allow [optional]
112              
113             C<$allow> can be:
114              
115             =over 8
116              
117             =item * ArrayRef => a list of allowed() items
118              
119             =item * Regex => a regex to test C<$value> against.
120              
121             =item * CodeRef => a coderef that is executed with C<$value>
122              
123             =item * other_value => $value eq $other_value (checks for definedness)
124              
125             =back
126              
127             =back
128              
129             =head3 Returns
130              
131             (perl) True of False.
132              
133             =cut
134              
135             sub allowed {
136 773     773 1 2209 my $self = shift;
137 773 100       2396 return 1 if !defined $self->allow;
138              
139 443         956 my ($value, $allow) = @_;
140 443 100       1484 $allow = $self->allow if @_ == 1;
141             GIVEN: {
142 443         654 local $_ = ref($allow);
  443         818  
143              
144 443 100       1061 /^ARRAY$/ && do {
145 112         433 return scalar grep $self->allowed($value, $_), @$allow;
146             };
147 331 100       734 /^Regexp$/ && do {
148 46   100     683 return ($value || '') =~ $allow;
149             };
150 285 100       610 /^CODE$/ && do {
151 13         132 return $allow->($value);
152             };
153             # default
154 272         394 do {
155 272 100       487 if (!defined $value) {
156 1         6 return !defined $allow;
157             }
158 271 100       522 return 0 if !defined $allow;
159 244         843 return $value eq $allow;
160             };
161             }
162             }
163              
164             =head2 $opt->gol_option
165              
166             Getopt::Long compatible option string.
167              
168             =cut
169              
170             sub gol_option {
171 14674     14674 1 21679 my $self = shift;
172              
173 14674         42482 my $gol = $self->name;
174 14674 100       45828 if ($self->option !~ /^(=|!|\||$)/) {
175 2098         3510 $gol .= "|";
176             }
177 14674         48557 $gol .= $self->option;
178 14674         37140 return $gol;
179             }
180              
181             =head2 $opt->show_helptext()
182              
183             sprintf "%-30s - %s", $option_with_allowd, $self->helptext
184              
185             =cut
186              
187             sub show_helptext {
188 631     631 1 1450 my $self = shift;
189              
190 631         988 my $prefix = '--';
191 631 100       2034 if ($self->option =~ /!$/) {
192 74         158 $prefix .= '[no]';
193             }
194 631         1362 my @option = ($prefix . $self->gol_option);
195              
196 631 100 100     2326 if ( defined($self->allow)
      100        
197 131         545 && ref($self->allow) eq 'ARRAY' && @{$self->allow})
198             {
199             my @values = sort {
200 307         983 lc($a) cmp lc($b)
201             } map
202             defined($_) ? $_ : "'undef'"
203 130 100       249 , @{$self->allow};
  130         487  
204 130         434 my $allowed = join('|', @values);
205 130         396 push @option, "<$allowed>";
206             }
207              
208 631         1516 my $text = join(" ", @option);
209              
210 631 100       2159 return $text if !$self->helptext;
211 630         2274 return sprintf($HTFMT, $text, $self->helptext);
212             }
213              
214             1;
215              
216             =head1 COPYRIGHT
217              
218             (c) 2002-2013, Abe Timmerman All rights reserved.
219              
220             With contributions from Jarkko Hietaniemi, Merijn Brand, Campo
221             Weijerman, Alan Burlison, Allen Smith, Alain Barbet, Dominic Dunlop,
222             Rich Rauenzahn, David Cantrell.
223              
224             This library is free software; you can redistribute it and/or modify
225             it under the same terms as Perl itself.
226              
227             See:
228              
229             =over 4
230              
231             =item * L
232              
233             =item * L
234              
235             =back
236              
237             This program is distributed in the hope that it will be useful,
238             but WITHOUT ANY WARRANTY; without even the implied warranty of
239             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
240              
241             =cut