File Coverage

blib/lib/Getopt/Long/Descriptive/Opts.pm
Criterion Covered Total %
statement 55 58 94.8
branch 2 4 50.0
condition n/a
subroutine 9 10 90.0
pod n/a
total 66 72 91.6


line stmt bran cond sub pod time code
1 2     2   15 use strict;
  2         6  
  2         64  
2 2     2   1625 use warnings;
  2         8  
  2         98  
3             package Getopt::Long::Descriptive::Opts 0.110;
4             # ABSTRACT: object representing command line switches
5              
6 2     2   11 use Scalar::Util qw(blessed weaken);
  2         5  
  2         984  
7              
8             #pod =head1 DESCRIPTION
9             #pod
10             #pod This class is the base class of all C<$opt> objects returned by
11             #pod L. In general, you do not want to think about this
12             #pod class, look at it, or alter it. Seriously, it's pretty dumb.
13             #pod
14             #pod Every call to C will return a object of a new subclass of
15             #pod this class. It will have a method for the canonical name of each option
16             #pod possible given the option specifications.
17             #pod
18             #pod Method names beginning with an single underscore are public, and are named that
19             #pod way to avoid conflict with automatically generated methods. Methods with
20             #pod multiple underscores (in case you're reading the source) are private.
21             #pod
22             #pod =head1 METHODS
23             #pod
24             #pod B All methods beginning with an underscore are experimental as of
25             #pod today, 2009-12-12. They are likely to be formally made permanent soon.
26             #pod
27             #pod =head2 _specified
28             #pod
29             #pod This method returns true if the given name was specified on the command line.
30             #pod
31             #pod For example, if C<@ARGS> was "C<< --foo --bar 10 >>" and C is defined by a
32             #pod default, C<_specified> will return true for foo and bar, and false for baz.
33             #pod
34             #pod =cut
35              
36             my %_CREATED_OPTS;
37             my $SERIAL_NUMBER = 1;
38              
39             sub _specified {
40 0     0   0 my ($self, $name) = @_;
41 0         0 my $meta = $_CREATED_OPTS{ blessed $self }{meta};
42 0         0 return $meta->{given}{ $name };
43             }
44              
45             #pod =head2 _specified_opts
46             #pod
47             #pod This method returns an opt object in which only explicitly specified values are
48             #pod defined. Values which were set by defaults will appear undef.
49             #pod
50             #pod =cut
51              
52             sub _specified_opts {
53 1     1   10 my ($self) = @_;
54              
55 1         5 my $class = blessed $self;
56 1         4 my $meta = $_CREATED_OPTS{ $class }{meta};
57              
58 1 50       5 return $meta->{specified_opts} if $meta->{specified_opts};
59              
60 1         2 my @keys = grep { $meta->{given}{ $_ } } (keys %{ $meta->{given} });
  2         6  
  1         3  
61              
62 1         2 my %opts;
63 1         7 @opts{ @keys } = @$self{ @keys };
64              
65 1         3 $meta->{specified_opts} = \%opts;
66              
67 1         3 bless $meta->{specified_opts} => $class;
68 1         4 weaken $meta->{specified_opts};
69              
70 1         3 $meta->{specified_opts};
71             }
72              
73             #pod =head2 _complete_opts
74             #pod
75             #pod This method returns the opts object with all values, including those set by
76             #pod defaults. It is probably not going to be very often-used.
77             #pod
78             #pod =cut
79              
80             sub _complete_opts {
81 1     1   8 my ($self) = @_;
82              
83 1         4 my $class = blessed $self;
84 1         2 my $meta = $_CREATED_OPTS{ $class }{meta};
85 1         3 return $meta->{complete_opts};
86             }
87              
88             sub ___class_for_opt {
89 26     26   50 my ($class, $arg) = @_;
90              
91 26         41 my $values = $arg->{values};
92 26         56 my @bad = grep { $_ !~ /^[a-z_]\w*$/ } keys %$values;
  83         318  
93 26 50       64 Carp::confess("perverse option names given: @bad") if @bad;
94              
95 26         82 my $new_class = "$class\::__OPT__::" . $SERIAL_NUMBER++;
96 26         82 $_CREATED_OPTS{ $new_class } = { meta => $arg };
97              
98             {
99 2     2   18 no strict 'refs';
  2         4  
  2         612  
  26         49  
100 26         127 ${"$new_class\::VERSION"} = $class->VERSION;
  26         210  
101 26         68 *{"$new_class\::ISA"} = [ 'Getopt::Long::Descriptive::Opts' ];
  26         291  
102 26         89 for my $opt (keys %$values) {
103 83     32   295 *{"$new_class\::$opt"} = sub { $_[0]->{ $opt } };
  83         383  
  32         9484  
104             }
105             }
106              
107 26         73 return $new_class;
108             }
109              
110             sub ___new_opt_obj {
111 26     26   61 my ($class, $arg) = @_;
112              
113 26         43 my $copy = { %{ $arg->{values} } };
  26         84  
114              
115 26         77 my $new_class = $class->___class_for_opt($arg);
116              
117             # This is stupid, but the traditional behavior was that if --foo was not
118             # given, there is no $opt->{foo}; it started to show up when we "needed" all
119             # the keys to generate a class, but was undef; this wasn't a problem, but
120             # broke tests of things that were relying on not-exists like tests of %$opt
121             # contents or MooseX::Getopt which wanted to use things as args for new --
122             # undef would not pass an Int TC. Easier to just do this. -- rjbs,
123             # 2009-11-27
124 26         75 delete $copy->{$_} for grep { ! defined $copy->{$_} } keys %$copy;
  83         220  
125              
126 26         94 my $self = bless $copy => $new_class;
127              
128 26         58 $_CREATED_OPTS{ $new_class }{meta}{complete_opts} = $self;
129             # weaken $_CREATED_OPTS{ $new_class }{meta}{complete_opts};
130              
131 26         75 return $self;
132             }
133              
134             1;
135              
136             __END__