File Coverage

blib/lib/Venus/Opts.pm
Criterion Covered Total %
statement 78 85 91.7
branch 27 36 75.0
condition 3 4 75.0
subroutine 16 18 88.8
pod 9 12 75.0
total 133 155 85.8


line stmt bran cond sub pod time code
1             package Venus::Opts;
2              
3 3     3   70 use 5.018;
  3         10  
4              
5 3     3   26 use strict;
  3         14  
  3         87  
6 3     3   15 use warnings;
  3         16  
  3         98  
7              
8 3     3   16 use Venus::Class 'attr', 'base', 'with';
  3         6  
  3         16  
9              
10             base 'Venus::Kind::Utility';
11              
12             with 'Venus::Role::Valuable';
13             with 'Venus::Role::Buildable';
14             with 'Venus::Role::Accessible';
15             with 'Venus::Role::Proxyable';
16              
17             # ATTRIBUTES
18              
19             attr 'named';
20             attr 'parsed';
21             attr 'specs';
22             attr 'warns';
23             attr 'unused';
24              
25             # BUILDERS
26              
27             sub build_arg {
28 0     0 0 0 my ($self, $data) = @_;
29              
30             return {
31 0         0 value => $data,
32             };
33             }
34              
35             sub build_self {
36 52     52 0 98 my ($self, $data) = @_;
37              
38 52 100       132 $self->named({}) if !$self->named;
39 52 50       149 $self->parsed({}) if !$self->parsed;
40 52 50       144 $self->specs([]) if !$self->specs;
41 52 50       202 $self->warns([]) if !$self->warns;
42 52 50       148 $self->unused([]) if !$self->unused;
43              
44 52         142 return $self->parse;
45             }
46              
47             sub build_proxy {
48 2     2 0 8 my ($self, $package, $method, $value) = @_;
49              
50 2         5 my $has_value = exists $_[3];
51              
52             return sub {
53 2 50   2   14 return $self->get($method) if !$has_value; # no value
54 0         0 return $self->set($method, $value);
55 2         13 };
56             }
57              
58             # METHODS
59              
60             sub assertion {
61 0     0 1 0 my ($self) = @_;
62              
63 0         0 my $assert = $self->SUPER::assertion;
64              
65 0         0 $assert->clear->expression('arrayref');
66              
67 0         0 return $assert;
68             }
69              
70             sub default {
71 1     1 1 5 my ($self) = @_;
72              
73 1         5 return [@ARGV];
74             }
75              
76             sub exists {
77 3     3 1 9 my ($self, $name) = @_;
78              
79 3 50       9 return if not defined $name;
80              
81 3         8 my $pos = $self->name($name);
82              
83 3 100       17 return if not defined $pos;
84              
85 2         6 return CORE::exists $self->parsed->{$pos};
86             }
87              
88             sub get {
89 21     21 1 74 my ($self, $name) = @_;
90              
91 21 50       53 return if not defined $name;
92              
93 21         69 my $pos = $self->name($name);
94              
95 21 100       67 return if not defined $pos;
96              
97 15         39 return $self->parsed->{$pos};
98             }
99              
100             sub parse {
101 56     56 1 100 my ($self, $extras) = @_;
102              
103 56 100       71 return $self if %{$self->parsed};
  56         181  
104              
105 54         132 my $value = $self->value;
106 54         119 my $specs = $self->specs;
107              
108 54         109 my $parsed = {};
109 54         122 my @configs = qw(default no_auto_abbrev no_ignore_case);
110              
111 54 100       111 $extras = [] if !$extras;
112              
113 54         3004 require Getopt::Long;
114 54         35729 require Text::ParseWords;
115              
116 54         4388 my $warns = [];
117             local $SIG{__WARN__} = sub {
118 10     10   3506 push @$warns, map s/\n+$//gr, @_;
119 10         47 return;
120 54         448 };
121              
122             # configure parser
123 54         238 Getopt::Long::Configure(Getopt::Long::Configure(@configs, @$extras));
124              
125             # parse args using spec
126 54         4821 my ($returned, $unused) = Getopt::Long::GetOptionsFromString(
127             join(' ', Text::ParseWords::shellwords(map quotemeta, @$value)),
128             $parsed,
129             @$specs
130             );
131              
132 54         21317 $self->unused($unused);
133 54         173 $self->parsed($parsed);
134 54         162 $self->warns($warns);
135              
136 54         450 return $self;
137             }
138              
139             sub name {
140 30     30 1 56 my ($self, $name) = @_;
141              
142 30 100       72 if (defined $self->named->{$name}) {
143 5         13 return $self->named->{$name};
144             }
145              
146 25 100       72 if (defined $self->parsed->{$name}) {
147 16         65 return $name;
148             }
149              
150 9         50 return undef;
151             }
152              
153             sub reparse {
154 2     2 1 10 my ($self, $specs, $extras) = @_;
155              
156 2         6 $self->parsed({});
157 2 50 50     35 $self->specs($specs || []) if defined $specs;
158              
159 2   100     18 return $self->parse($extras || []);
160             }
161              
162             sub set {
163 3     3 1 12 my ($self, $name, $data) = @_;
164              
165 3 50       9 return if not defined $name;
166              
167 3         8 my $pos = $self->name($name);
168              
169 3 100       20 return if not defined $pos;
170              
171 2         10 return $self->parsed->{$pos} = $data;
172             }
173              
174             sub unnamed {
175 1     1 1 7 my ($self) = @_;
176              
177 1         3 my $list = [];
178              
179 1         3 my $opts = $self->parsed;
180 1         6 my $data = +{reverse %{$self->named}};
  1         5  
181              
182 1         8 for my $index (sort keys %$opts) {
183 2 100       8 unless (exists $data->{$index}) {
184 1         5 push @$list, $opts->{$index};
185             }
186             }
187              
188 1         6 return $list;
189             }
190              
191             1;
192              
193              
194              
195             =head1 NAME
196              
197             Venus::Opts - Opts Class
198              
199             =cut
200              
201             =head1 ABSTRACT
202              
203             Opts Class for Perl 5
204              
205             =cut
206              
207             =head1 SYNOPSIS
208              
209             package main;
210              
211             use Venus::Opts;
212              
213             my $opts = Venus::Opts->new(
214             value => ['--resource', 'users', '--help'],
215             specs => ['resource|r=s', 'help|h'],
216             named => { method => 'resource' } # optional
217             );
218              
219             # $opts->method; # $resource
220             # $opts->get('resource'); # $resource
221              
222             # $opts->help; # $help
223             # $opts->get('help'); # $help
224              
225             =cut
226              
227             =head1 DESCRIPTION
228              
229             This package provides methods for handling command-line arguments.
230              
231             =cut
232              
233             =head1 ATTRIBUTES
234              
235             This package has the following attributes:
236              
237             =cut
238              
239             =head2 named
240              
241             named(HashRef)
242              
243             This attribute is read-write, accepts C<(HashRef)> values, is optional, and defaults to C<{}>.
244              
245             =cut
246              
247             =head2 parsed
248              
249             parsed(HashRef)
250              
251             This attribute is read-write, accepts C<(HashRef)> values, is optional, and defaults to C<{}>.
252              
253             =cut
254              
255             =head2 specs
256              
257             specs(ArrayRef)
258              
259             This attribute is read-write, accepts C<(ArrayRef)> values, is optional, and defaults to C<[]>.
260              
261             =cut
262              
263             =head2 warns
264              
265             warns(ArrayRef)
266              
267             This attribute is read-write, accepts C<(ArrayRef)> values, is optional, and defaults to C<[]>.
268              
269             =cut
270              
271             =head2 unused
272              
273             unused(ArrayRef)
274              
275             This attribute is read-write, accepts C<(ArrayRef)> values, is optional, and defaults to C<[]>.
276              
277             =cut
278              
279             =head1 INHERITS
280              
281             This package inherits behaviors from:
282              
283             L
284              
285             =cut
286              
287             =head1 INTEGRATES
288              
289             This package integrates behaviors from:
290              
291             L
292              
293             L
294              
295             L
296              
297             L
298              
299             =cut
300              
301             =head1 METHODS
302              
303             This package provides the following methods:
304              
305             =cut
306              
307             =head2 default
308              
309             default() (arrayref)
310              
311             The default method returns the default value, i.e. C<[@ARGV]>.
312              
313             I>
314              
315             =over 4
316              
317             =item default example 1
318              
319             # given: synopsis;
320              
321             my $default = $opts->default;
322              
323             # []
324              
325             =back
326              
327             =cut
328              
329             =head2 exists
330              
331             exists(string $key) (boolean)
332              
333             The exists method takes a name or index and returns truthy if an associated
334             value exists.
335              
336             I>
337              
338             =over 4
339              
340             =item exists example 1
341              
342             # given: synopsis;
343              
344             my $exists = $opts->exists('resource');
345              
346             # 1
347              
348             =back
349              
350             =over 4
351              
352             =item exists example 2
353              
354             # given: synopsis;
355              
356             my $exists = $opts->exists('method');
357              
358             # 1
359              
360             =back
361              
362             =over 4
363              
364             =item exists example 3
365              
366             # given: synopsis;
367              
368             my $exists = $opts->exists('resources');
369              
370             # undef
371              
372             =back
373              
374             =cut
375              
376             =head2 get
377              
378             get(string $key) (any)
379              
380             The get method takes a name or index and returns the associated value.
381              
382             I>
383              
384             =over 4
385              
386             =item get example 1
387              
388             # given: synopsis;
389              
390             my $get = $opts->get('resource');
391              
392             # "users"
393              
394             =back
395              
396             =over 4
397              
398             =item get example 2
399              
400             # given: synopsis;
401              
402             my $get = $opts->get('method');
403              
404             # "users"
405              
406             =back
407              
408             =over 4
409              
410             =item get example 3
411              
412             # given: synopsis;
413              
414             my $get = $opts->get('resources');
415              
416             # undef
417              
418             =back
419              
420             =cut
421              
422             =head2 name
423              
424             name(string $key) (string | undef)
425              
426             The name method takes a name or index and returns index if the the associated
427             value exists.
428              
429             I>
430              
431             =over 4
432              
433             =item name example 1
434              
435             # given: synopsis;
436              
437             my $name = $opts->name('resource');
438              
439             # "resource"
440              
441             =back
442              
443             =over 4
444              
445             =item name example 2
446              
447             # given: synopsis;
448              
449             my $name = $opts->name('method');
450              
451             # "resource"
452              
453             =back
454              
455             =over 4
456              
457             =item name example 3
458              
459             # given: synopsis;
460              
461             my $name = $opts->name('resources');
462              
463             # undef
464              
465             =back
466              
467             =cut
468              
469             =head2 parse
470              
471             parse(arrayref $args) (Venus::Opts)
472              
473             The parse method optionally takes additional L parser
474             configuration options and retuns the options found based on the object C
475             and C values.
476              
477             I>
478              
479             =over 4
480              
481             =item parse example 1
482              
483             # given: synopsis;
484              
485             my $parse = $opts->parse;
486              
487             # bless({...}, 'Venus::Opts')
488              
489             =back
490              
491             =over 4
492              
493             =item parse example 2
494              
495             # given: synopsis;
496              
497             my $parse = $opts->parse(['bundling']);
498              
499             # bless({...}, 'Venus::Opts')
500              
501             =back
502              
503             =cut
504              
505             =head2 reparse
506              
507             reparse(arrayref $specs, arrayref $args) (Venus::Opts)
508              
509             The reparse method resets the parser, calls the L method and returns
510             the result.
511              
512             I>
513              
514             =over 4
515              
516             =item reparse example 1
517              
518             # given: synopsis;
519              
520             my $reparse = $opts->reparse(['resource|r=s']);
521              
522             # bless({...}, 'Venus::Opts')
523              
524             =back
525              
526             =over 4
527              
528             =item reparse example 2
529              
530             # given: synopsis;
531              
532             my $reparse = $opts->reparse(['resource|r=s'], ['bundling']);
533              
534             # bless({...}, 'Venus::Opts')
535              
536             =back
537              
538             =cut
539              
540             =head2 set
541              
542             set(string $key, any $data) (any)
543              
544             The set method takes a name or index and sets the value provided if the
545             associated argument exists.
546              
547             I>
548              
549             =over 4
550              
551             =item set example 1
552              
553             # given: synopsis;
554              
555             my $set = $opts->set('method', 'people');
556              
557             # "people"
558              
559             =back
560              
561             =over 4
562              
563             =item set example 2
564              
565             # given: synopsis;
566              
567             my $set = $opts->set('resource', 'people');
568              
569             # "people"
570              
571             =back
572              
573             =over 4
574              
575             =item set example 3
576              
577             # given: synopsis;
578              
579             my $set = $opts->set('resources', 'people');
580              
581             # undef
582              
583             =back
584              
585             =cut
586              
587             =head2 unnamed
588              
589             unnamed() (arrayref)
590              
591             The unnamed method returns an arrayref of values which have not been named
592             using the C attribute.
593              
594             I>
595              
596             =over 4
597              
598             =item unnamed example 1
599              
600             # given: synopsis;
601              
602             my $unnamed = $opts->unnamed;
603              
604             # [1]
605              
606             =back
607              
608             =cut
609              
610             =head1 AUTHORS
611              
612             Awncorp, C
613              
614             =cut
615              
616             =head1 LICENSE
617              
618             Copyright (C) 2000, Awncorp, C.
619              
620             This program is free software, you can redistribute it and/or modify it under
621             the terms of the Apache license version 2.0.
622              
623             =cut