File Coverage

blib/lib/Declare/Opts.pm
Criterion Covered Total %
statement 117 118 99.1
branch 58 66 87.8
condition 26 31 83.8
subroutine 19 19 100.0
pod 6 8 75.0
total 226 242 93.3


line stmt bran cond sub pod time code
1             package Declare::Opts;
2 7     7   2178883 use strict;
  7         21  
  7         322  
3 7     7   42 use warnings;
  7         14  
  7         350  
4              
5             our $VERSION = "0.005";
6              
7 7     7   35 use Carp qw/croak/;
  7         14  
  7         413  
8              
9 7         84 use Exporter::Declare qw{
10             import
11             gen_default_export
12             default_export
13 7     7   42 };
  7         14  
14              
15             gen_default_export 'OPTS_META' => sub {
16             my ( $class, $caller ) = @_;
17             my $meta = $class->new();
18             $meta->{class} = $caller;
19 37     37   12085 return sub { $meta };
20             };
21              
22 20     20   2437522 default_export opt => sub { caller->OPTS_META->opt( @_ ) };
23 12     12   24594 default_export parse_opts => sub { caller->OPTS_META->parse( @_ ) };
24 2     2   12 default_export opt_info => sub { caller->OPTS_META->info };
25              
26 1     1 1 33 sub class { shift->{class} }
27 145     145 0 981 sub opts { shift->{opts} }
28 9     9 1 29 sub default { shift->{default} }
29              
30             sub new {
31 7     7 1 14 my $class = shift;
32 7         14 my ( %opts ) = @_;
33              
34 7         42 my $self = bless { opts => {}, default => {} } => $class;
35 7         35 $self->opt( $_, $opts{$_} ) for keys %opts;
36              
37 7         28 return $self;
38             }
39              
40             sub valid_opt_params {
41 24     24 0 532 return qr/^(alias|list|bool|default|check|transform|description)$/;
42             }
43              
44             sub opt {
45 20     20 1 136 my $self = shift;
46 20         440 my ( $name, %config ) = @_;
47              
48 20 50       120 croak "opt '$name' already defined"
49             if $self->opts->{$name};
50              
51 20         173 for my $prop ( keys %config ) {
52 24 50       98 next if $prop =~ $self->valid_opt_params;
53 0         0 croak "invalid opt property: '$prop'";
54             }
55              
56 20         182 $config{name} = $name;
57              
58 20 50 66     335 croak "'check' cannot be used with 'bool'"
59             if $config{bool} && $config{check};
60              
61 20 50 66     159 croak "'transform' cannot be used with 'bool'"
62             if $config{bool} && $config{transform};
63              
64 20 100 100     197 croak "opt properties 'list' and 'bool' are mutually exclusive"
65             if $config{list} && $config{bool};
66              
67 19 100       99 if (exists $config{default}) {
68 2 50 33     28 croak "References cannot be used in default, wrap them in a sub."
69             if ref $config{default} && ref $config{default} ne 'CODE';
70 2         8 $self->default->{$name} = $config{default};
71             }
72              
73 19 100       84 if ( exists $config{check} ) {
74 9         15 my $ref = ref $config{check};
75 9 100 100     349 croak "'$config{check}' is not a valid value for 'check'"
      100        
      100        
76             if ($ref && $ref !~ m/^(CODE|Regexp)$/)
77             || (!$ref && $config{check} !~ m/^(file|dir|number)$/);
78             }
79              
80 17 100       106 if ( exists $config{alias} ) {
81 2 100       51 my $aliases = ref $config{alias} ? $config{alias}
82             : [ $config{alias} ];
83              
84 2         6 $config{_alias} = { map { $_ => 1 } @$aliases };
  3         19  
85              
86 2         15 for my $alias ( @$aliases ) {
87 3 50       10 croak "Cannot use alias '$alias', name is already taken by another opt."
88             if $self->opts->{$alias};
89              
90 3         14 $self->opts->{$alias} = \%config;
91             }
92             }
93              
94 17         46 $self->opts->{$name} = \%config;
95             }
96              
97             sub parse {
98 12     12 1 18 my $self = shift;
99 12         76 my @opts = @_;
100              
101 12         30 my $params = [];
102 12         32 my $flags = {};
103 12         100 my $no_flags = 0;
104              
105 12         42 while ( my $opt = shift @opts ) {
106 33 100 100     381 if ( $opt eq '--' ) {
    100          
107 3         9 $no_flags++;
108             }
109             elsif ( $opt =~ m/^-+([^-=]+)(?:=(.+))?$/ && !$no_flags ) {
110 24         245 my ( $key, $value ) = ( $1, $2 );
111              
112 24         93 my $name = $self->_flag_name( $key );
113 22         128 my $values = $self->_flag_value(
114             $name,
115             $value,
116             \@opts
117             );
118              
119 17 100       60 if( $self->opts->{$name}->{list} ) {
120 5         7 push @{$flags->{$name}} => @$values;
  5         40  
121             }
122             else {
123 12         66 $flags->{$name} = $values->[0];
124             }
125             }
126             else {
127 6         27 push @$params => $opt;
128             }
129             }
130              
131             # Add defaults for opts not provided
132 5         9 for my $opt ( keys %{ $self->default } ) {
  5         16  
133 4 100       11 next if exists $flags->{$opt};
134 2         5 my $val = $self->default->{$opt};
135 2 50       14 $flags->{$opt} = ref $val ? $val->() : $val;
136             }
137              
138 5         27 return ( $params, $flags );
139             }
140              
141             sub info {
142 2     2 1 10 my $self = shift;
143             return {
144 4   100     9 map { $self->opts->{$_}->{name} => $self->opts->{$_}->{description} || "No Description" }
  2         3  
145 2         4 keys %{ $self->opts }
146             };
147             }
148              
149             sub _flag_value {
150 22     22   32 my $self = shift;
151 22         32 my ( $flag, $value, $opts ) = @_;
152              
153 22         118 my $spec = $self->opts->{$flag};
154              
155 22 100       93 if ( $spec->{bool} ) {
156 3 100       10 return [$value] if defined $value;
157 2 100       10 return [$spec->{default} ? 0 : 1];
158             }
159              
160 19 100       57 my $val = defined $value ? $value : shift @$opts;
161              
162 19 100       119 my $out = $spec->{list} ? [ split /\s*,\s*/, $val ]
163             : [ $val ];
164              
165 19         51 $self->_validate( $flag, $spec, $out );
166              
167 14 100       44 return $out unless $spec->{transform};
168 2         2 return [ map { $spec->{transform}->($_) } @$out ];
  4         14  
169             }
170              
171             sub _validate {
172 19     19   24 my $self = shift;
173 19         39 my ( $flag, $spec, $value ) = @_;
174              
175 19         32 my $check = $spec->{check};
176 19 100       47 return unless $check;
177 12   100     74 my $ref = ref $check || "";
178              
179 12         22 my @bad;
180              
181 12 100       54 if ( $ref eq 'Regexp' ) {
    100          
    100          
    100          
    50          
182 2         3 @bad = grep { $_ !~ $check } @$value;
  2         22  
183             }
184             elsif ( $ref eq 'CODE' ) {
185 2         4 @bad = grep { !$check->( $_ ) } @$value;
  2         7  
186             }
187             elsif ( $check eq 'file' ) {
188 2         6 @bad = grep { ! -f $_ } @$value;
  2         62  
189             }
190             elsif ( $check eq 'dir' ) {
191 2         3 @bad = grep { ! -d $_ } @$value;
  6         78  
192             }
193             elsif ( $check eq 'number' ) {
194 4         9 @bad = grep { m/\D/ } @$value;
  11         40  
195             }
196              
197 12 100       53 return unless @bad;
198 5   66     25 my $type = $ref || $check;
199 5         64 die "Validation Failed for '$flag=$type': " . join( ", ", @bad ) . "\n";
200             }
201              
202             sub _flag_name {
203 24     24   35 my $self = shift;
204 24         35 my ( $key ) = @_;
205              
206             # Exact match
207 24 100       256 return $self->opts->{$key}->{name}
208             if $self->opts->{$key};
209              
210 4         10 my %matches = map { $self->opts->{$_}->{name} => 1 }
  22         342  
211 4         12 grep { m/^$key/ }
212 4         6 keys %{ $self->opts };
213 4         15 my @matches = keys %matches;
214              
215 4 100       40 die "partial option '$key' is ambiguous, could be: " . join( ", " => @matches ) . "\n"
216             if @matches > 1;
217              
218 3 100       29 die "unknown option '$key'\n"
219             unless @matches;
220              
221 2         7 return $matches[0];
222             }
223              
224             1;
225              
226             __END__