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   323665 use warnings;
  10         54  
  10         349  
3 10     10   66 use strict;
  10         19  
  10         237  
4 10     10   55 use Carp;
  10         19  
  10         692  
5              
6             our $VERSION = '0.002';
7              
8 10     10   63 use base 'Test::Smoke::ObjectBase';
  10         16  
  10         7376  
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 733     733 1 4208 my $class = shift;
66 733         3510 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 733         6520 _configfnex => 0,
79             _configord => 0,
80             };
81 733         2044 $struct->{_had_default} = exists $args{default};
82 733         2848 for my $known (keys %$struct) {
83 8796         22053 (my $key = $known) =~ s/^_//;
84 8796 100       21635 $struct->{$known} = delete $args{$key} if exists $args{$key};
85             }
86 733 100 100     3032 if (!defined($struct->{_name}) || !length($struct->{_name})) {
87 2         314 croak("Required option 'name' not given.");
88             }
89 731 100 100     2357 if ( defined($struct->{_allow})
90             and (ref($struct->{_allow}) !~ /^(?:ARRAY|Regexp|CODE)$/))
91             {
92 1         112 croak("Option 'allow' must be an ArrayRef|CodeRef|RegExp when set");
93             }
94             # had_default(): order == code < configfile < commandline
95              
96 730         6335 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 762     762 1 2122 my $self = shift;
137 762 100       2316 return 1 if !defined $self->allow;
138              
139 443         934 my ($value, $allow) = @_;
140 443 100       1110 $allow = $self->allow if @_ == 1;
141             GIVEN: {
142 443         664 local $_ = ref($allow);
  443         781  
143              
144 443 100       1025 /^ARRAY$/ && do {
145 112         406 return scalar grep $self->allowed($value, $_), @$allow;
146             };
147 331 100       685 /^Regexp$/ && do {
148 46   100     630 return ($value || '') =~ $allow;
149             };
150 285 100       549 /^CODE$/ && do {
151 13         65 return $allow->($value);
152             };
153             # default
154 272         358 do {
155 272 100       534 if (!defined $value) {
156 1         6 return !defined $allow;
157             }
158 271 100       520 return 0 if !defined $allow;
159 244         854 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 14179     14179 1 20297 my $self = shift;
172              
173 14179         40133 my $gol = $self->name;
174 14179 100       43505 if ($self->option !~ /^(=|!|\||$)/) {
175 2014         3318 $gol .= "|";
176             }
177 14179         44912 $gol .= $self->option;
178 14179         35057 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 620     620 1 1489 my $self = shift;
189              
190 620         910 my $prefix = '--';
191 620 100       2016 if ($self->option =~ /!$/) {
192 63         152 $prefix .= '[no]';
193             }
194 620         1314 my @option = ($prefix . $self->gol_option);
195              
196 620 100 100     2142 if ( defined($self->allow)
      100        
197 131         500 && ref($self->allow) eq 'ARRAY' && @{$self->allow})
198             {
199             my @values = sort {
200 307         933 lc($a) cmp lc($b)
201             } map
202             defined($_) ? $_ : "'undef'"
203 130 100       237 , @{$self->allow};
  130         448  
204 130         411 my $allowed = join('|', @values);
205 130         359 push @option, "<$allowed>";
206             }
207              
208 620         1462 my $text = join(" ", @option);
209              
210 620 100       2080 return $text if !$self->helptext;
211 619         2196 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