File Coverage

blib/lib/Getopt/Alt/Option.pm
Criterion Covered Total %
statement 104 104 100.0
branch 78 78 100.0
condition 44 48 91.6
subroutine 9 9 100.0
pod 2 2 100.0
total 237 241 98.3


line stmt bran cond sub pod time code
1             package Getopt::Alt::Option;
2              
3             # Created on: 2009-07-17 14:52:26
4             # Create by: Ivan Wills
5             # $Id$
6             # $Revision$, $HeadURL$, $Date$
7             # $Revision$, $Source$, $Date$
8              
9 11     11   293898 use strict;
  11         41  
  11         336  
10 11     11   61 use warnings;
  11         22  
  11         276  
11 11     11   1990 use version;
  11         7946  
  11         67  
12 11     11   6144 use Moose::Role;
  11         1976717  
  11         50  
13 11     11   63433 use Carp;
  11         27  
  11         770  
14 11     11   2818 use English qw/ -no_match_vars /;
  11         15673  
  11         65  
15 11     11   9230 use Getopt::Alt::Exception;
  11         44  
  11         20958  
16              
17             Moose::Exporter->setup_import_methods(
18             as_is => [qw/build_option/],
19             #with_meta => ['operation'],
20             );
21              
22             our $VERSION = version->new('0.5.4');
23              
24             Moose::Util::meta_attribute_alias('Getopt::Alt::Option');
25              
26             has opt => (
27             is => 'ro',
28             required => 1,
29             );
30             has name => (
31             is => 'rw',
32             isa => 'Str',
33             required => 1,
34             );
35             has names => (
36             is => 'rw',
37             isa => 'ArrayRef[Str]',
38             required => 1,
39             );
40             has increment => (
41             is => 'rw',
42             isa => 'Bool',
43             );
44             has number => (
45             is => 'rw',
46             isa => 'Bool',
47             );
48             has negatable => (
49             is => 'rw',
50             isa => 'Bool',
51             );
52             has nullable => (
53             is => 'rw',
54             isa => 'Bool',
55             );
56             has config => (
57             is => 'ro',
58             isa => 'Bool',
59             );
60             has project => (
61             is => 'ro',
62             isa => 'Bool',
63             );
64             has ref => (
65             is => 'ro',
66             isa => 'Str',
67             );
68             has type => (
69             is => 'ro',
70             isa => 'Str',
71             );
72             has value => (
73             is => 'rw',
74             isa => 'Any',
75             predicate => 'has_value',
76             );
77             has values => (
78             is => 'rw',
79             isa => 'ArrayRef',
80             predicate => 'has_values',
81             );
82              
83             my $r_name = qr/ [^|\s=+!?@%-][^|\s=+!?@%]* /xms;
84             my $r_alt_name = qr/ $r_name | \\d /xms;
85             my $r_names = qr/ $r_name (?: [|] $r_alt_name)* /xms;
86             my $r_type = qr/ [nifsd] /xms;
87             my $r_ref = qr/ [%@] /xms;
88             my $r_sub_val = qr/ [\w-]+ /xms;
89             my $r_values = qr/ \[ $r_sub_val (?: [|] $r_sub_val )* \] /xms;
90             my $r_type_ref = qr/ = (?: $r_type $r_ref? | $r_values ) /xms;
91             my $r_inc = qr/ [+] /xms;
92             my $r_number = qr/ [+][+] /xms;
93             my $r_neg = qr/ [!] /xms;
94             my $r_null = qr/ [?] /xms;
95             my $r_spec = qr/^ ( $r_names ) ( $r_inc | $r_number | $r_neg | $r_type_ref )? ( $r_null )? $/xms;
96              
97             # calling new => ->new( 'test|t' )
98             # ->new( name => 'text', names => [qw/test tes te t/], ... )
99             # ->new({ name => 'text', names => [qw/test tes te t/], ... )
100             sub build_option {
101 547     547 1 136663 my ($class, @params) = @_;
102              
103 547 100 100     3459 if (@params == 1 && ref $params[0]) {
104             @params =
105 5         16 ref $params[0] eq 'ARRAY' ? @{ $params[0] }
106 7 100       241 : ref $params[0] eq 'HASH' ? %{ $params[0] }
  1 100       6  
107             : confess "Can't supply a " . (ref $params[0]) . " ref to new!";
108             }
109              
110             # construct attribute params string if one element
111 546 100       1498 if (@params == 1) {
112 543         1110 my $spec = pop @params;
113 543         1253 push @params, (opt => $spec);
114              
115 543 100       6529 confess "$spec doesn't match the specification definition! (qr/$r_spec/)" if $spec !~ /$r_spec/xms;
116              
117 540         3875 my ($names, $options, $null) = $spec =~ /$r_spec/xms;
118 540         2396 my @names = split /\|/xms, $names;
119 540         1490 push @params, 'names', \@names;
120 540         1188 push @params, 'name', $names[0];
121              
122 540 100       1299 if ($null) {
123 2         6 push @params, 'nullable' => 1;
124             }
125              
126 540 100       1628 if ($options) {
127 285         583 my ($type, $extra);
128 285         818 my ($option) = substr $options, 0, 1;
129              
130 285 100       1050 if ($option eq '=') {
    100          
    100          
131 243         868 ($type, $extra) = split /;/xms, $options;
132             }
133             elsif ($options eq '++') {
134 2         7 push @params, 'increment' => 1;
135 2         6 push @params, 'number' => 1;
136 2         6 push @params, 'type' => 'Int';
137             }
138             elsif ($option eq '+') {
139 4         12 push @params, 'increment' => 1;
140             }
141             else {
142             # $option == !
143 36         106 push @params, 'negatable' => 1;
144             }
145              
146 285 100       845 if ($type) {
147 243         495 my ($text, $ref);
148 243         1094 $type =~ s/^=//xms;
149              
150 243 100       876 if ( length $type == 1 ) {
    100          
151 192         1609 ($text) = $type =~ /^ ($r_type) $/xms;
152             }
153             elsif ( length $type == 2 ) {
154 48         538 ($text, $ref) = $type =~ /^ ($r_type) ($r_ref) $/xms;
155 48 100       308 push @params, ref => $ref eq '%' ? 'HashRef' : 'ArrayRef';
156             }
157             else {
158 3         21 $type =~ s/(?: ^\[ | \]$ )//gxms;
159 3         14 my @values = split /[|]/, $type;
160 3         9 $text = 's';
161 3         13 push @params, values => \@values;
162             }
163              
164 243 100       1653 push @params,
    100          
    100          
    100          
165             type =>
166             $text eq 'd' ? 'Int'
167             : $text eq 'i' ? 'Int'
168             : $text eq 'f' ? 'Num'
169             : $text eq 'n' ? 'Num'
170             : 'Str';
171             }
172             }
173             }
174              
175 543         2250 my %params = @params;
176 543         1488 $params{traits} = ['Getopt::Alt::Option'];
177              
178             my $type
179             = $params{type} && $params{ref} ? "$params{ref}\[$params{type}\]"
180             : $params{type} ? $params{type}
181 543 100 100     2886 : 'Str';
    100          
182              
183 543 100       1531 if ( $params{nullable} ) {
184 2         9 $type = "Maybe[$type]";
185             }
186              
187             $class->add_attribute(
188             $params{name},
189 543         3109 is => 'rw',
190             isa => $type,
191             %params,
192             );
193              
194 542         893451 return $class->get_attribute( $params{name} );
195             }
196              
197             sub process {
198 91     91 1 21014 my ($self, $long, $short, $arg_data, $args) = @_;
199              
200 91 100       296 my $name = $long ? "--$long" : "-$short";
201 91         137 my $value;
202 91         137 my $used = 0;
203 91 100       2622 if ($self->type) {
    100          
    100          
204 67         114 $used = 1;
205 67 100 100     1106 if ( !defined $arg_data || length $arg_data == 0 ) {
    100 100        
206 37 100 100     587 if (
      100        
      66        
      66        
      66        
207             ( ! defined $args->[0] && !$self->nullable )
208             || (
209             $args->[0]
210             && $args->[0] =~ /^-/xms
211             && !( $self->type eq 'Int' || $self->type eq 'Num' )
212             )
213             ) {
214 3         90 die [
215             Getopt::Alt::Exception->new(
216             message => "The option '$name' requires an " . $self->type . " argument\n",
217             option => $name,
218             type => $self->type
219             )
220             ];
221             }
222              
223 34         204 $arg_data = shift @$args;
224             }
225             elsif ( $arg_data && !$self->nullable ) {
226 24         50 $arg_data =~ s/^=//xms;
227             }
228              
229 64         97 my $key;
230 64 100 100     1765 if ($self->ref && $self->ref eq 'HashRef') {
231 4         17 ($key, $arg_data) = split /=/xms, $arg_data, 2;
232             }
233              
234 64         146 $DB::single = 1;
235 64         118 $value = $arg_data;
236              
237 64 100 66     1760 if ( $self->nullable && ( ! defined $arg_data || $arg_data eq '' ) ) {
    100 100        
    100          
    100          
238 2         5 $value = undef;
239             }
240             elsif ( $self->type eq 'Int' ) {
241 29 100       544 confess "$name '$arg_data' is not an integer!" if $arg_data !~ /^ -? \d+ $/xms;
242             }
243             elsif ( $self->type eq 'Num' ) {
244 11 100       165 confess "$name '$arg_data' is not a number!" if $arg_data !~ /^ -? (?: \d* (?: [.]\d+ )? | \d+ ) $/xms;
245             }
246             elsif ( $self->type ne 'Str' ) {
247 1         29 confess "Unknown type '".$self->type."'\n";
248             }
249              
250 60 100 100     1695 if ($self->values && !grep { $value eq $_ } @{ $self->values }) {
  12         39  
  4         173  
251             die [ Getopt::Alt::Exception->new(
252 1         6 message => "The option '$name' must be one of " . ( join ', ', @{ $self->values } ) . "\n",
  1         35  
253             option => $name,
254             type => $self->type
255             ) ]
256             }
257              
258 59 100       1552 if ($self->ref) {
259 10         16 my $old;
260 10 100       277 if ($self->ref eq 'ArrayRef') {
261 6   100     164 $old = $self->value || [];
262 6         18 push @$old, $value;
263             }
264             else {
265 4   100     111 $old = $self->value || {};
266 4         19 $old->{$key} = $value;
267             }
268 10         22 $value = $old;
269             }
270             }
271             elsif ($self->increment) {
272 8   100     217 $value = ($self->value || 0) + 1;
273             }
274             elsif ($self->negatable) {
275 8 100 100     46 $value = $long && $long =~ /^no-/xms ? 0 : 1;
276             }
277             else {
278 8         30 $value = 1;
279             }
280              
281 83         2360 $self->value($value);
282              
283 83         2238 return ( $self->value, $used );
284             }
285              
286             1;
287              
288             __END__
289              
290             =head1 NAME
291              
292             Getopt::Alt::Option - Sets up a particular command line option
293              
294             =head1 VERSION
295              
296             This documentation refers to Getopt::Alt::Option version 0.5.4.
297              
298             =head1 SYNOPSIS
299              
300             use Getopt::Alt::Option;
301              
302             # Brief but working code example(s) here showing the most common usage(s)
303             # This section will be as far as many users bother reading, so make it as
304             # educational and exemplary as possible.
305              
306             =head1 DESCRIPTION
307              
308             =head1 SUBROUTINES/METHODS
309              
310             =head2 C<build_option ( $class, @params )>
311              
312             This is a helper function to create an C<Getopt::Alt::Option> attribute on the
313             supplied C<$class> object.
314              
315             =head2 C<process ($long, $short, $arg_data, $args)>
316              
317             Processes the option against the supplied $arg_data or $args->[0] if no $arg_data is set
318              
319             =head1 DIAGNOSTICS
320              
321             =head1 CONFIGURATION AND ENVIRONMENT
322              
323             =head1 DEPENDENCIES
324              
325             =head1 INCOMPATIBILITIES
326              
327             =head1 BUGS AND LIMITATIONS
328              
329             There are no known bugs in this module.
330              
331             Please report problems to Ivan Wills (ivan.wills@gmail.com).
332              
333             Patches are welcome.
334              
335             =head1 AUTHOR
336              
337             Ivan Wills - (ivan.wills@gmail.com)
338              
339             =head1 LICENSE AND COPYRIGHT
340              
341             Copyright (c) 2009 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
342             All rights reserved.
343              
344             This module is free software; you can redistribute it and/or modify it under
345             the same terms as Perl itself. See L<perlartistic>. This program is
346             distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
347             without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
348             PARTICULAR PURPOSE.
349              
350             =cut