Filename | /home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/site_perl/5.13.5/Getopt/Long/Descriptive/Opts.pm |
Statements | Executed 74 statements in 1.00ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 281µs | 326µs | ___class_for_opt | Getopt::Long::Descriptive::Opts::
1 | 1 | 1 | 63µs | 390µs | ___new_opt_obj | Getopt::Long::Descriptive::Opts::
22 | 1 | 1 | 36µs | 36µs | CORE:match (opcode) | Getopt::Long::Descriptive::Opts::
1 | 1 | 1 | 26µs | 32µs | BEGIN@1 | Getopt::Long::Descriptive::
1 | 1 | 1 | 12µs | 75µs | BEGIN@5 | Getopt::Long::Descriptive::Opts::
1 | 1 | 1 | 12µs | 36µs | BEGIN@110 | Getopt::Long::Descriptive::Opts::
1 | 1 | 1 | 11µs | 21µs | BEGIN@2 | Getopt::Long::Descriptive::
0 | 0 | 0 | 0s | 0s | __ANON__[:114] | Getopt::Long::Descriptive::Opts::
0 | 0 | 0 | 0s | 0s | _complete_opts | Getopt::Long::Descriptive::Opts::
0 | 0 | 0 | 0s | 0s | _specified | Getopt::Long::Descriptive::Opts::
0 | 0 | 0 | 0s | 0s | _specified_opts | Getopt::Long::Descriptive::Opts::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | 2 | 27µs | 2 | 37µs | # spent 32µs (26+5) within Getopt::Long::Descriptive::BEGIN@1 which was called:
# once (26µs+5µs) by Getopt::Long::Descriptive::BEGIN@12 at line 1 # spent 32µs making 1 call to Getopt::Long::Descriptive::BEGIN@1
# spent 5µs making 1 call to strict::import |
2 | 2 | 41µs | 2 | 31µs | # spent 21µs (11+10) within Getopt::Long::Descriptive::BEGIN@2 which was called:
# once (11µs+10µs) by Getopt::Long::Descriptive::BEGIN@12 at line 2 # spent 21µs making 1 call to Getopt::Long::Descriptive::BEGIN@2
# spent 10µs making 1 call to warnings::import |
3 | package Getopt::Long::Descriptive::Opts; | ||||
4 | |||||
5 | 2 | 342µs | 2 | 138µs | # spent 75µs (12+63) within Getopt::Long::Descriptive::Opts::BEGIN@5 which was called:
# once (12µs+63µs) by Getopt::Long::Descriptive::BEGIN@12 at line 5 # spent 75µs making 1 call to Getopt::Long::Descriptive::Opts::BEGIN@5
# spent 63µs making 1 call to Exporter::import |
6 | |||||
7 | =head1 NAME | ||||
8 | |||||
9 | Getopt::Long::Descriptive::Opts - object representing command line switches | ||||
10 | |||||
11 | =head1 VERSION | ||||
12 | |||||
13 | Version 0.086 | ||||
14 | |||||
15 | =cut | ||||
16 | |||||
17 | 1 | 2µs | our $VERSION = '0.086'; | ||
18 | |||||
19 | =head1 DESCRIPTION | ||||
20 | |||||
21 | This class is the base class of all C<$opt> objects returned by | ||||
22 | L<Getopt::Long::Descriptive>. In general, you do not want to think about this | ||||
23 | class, look at it, or alter it. Seriously, it's pretty dumb. | ||||
24 | |||||
25 | Every call to C<describe_options> will return a object of a new subclass of | ||||
26 | this class. It will have a method for the canonical name of each option | ||||
27 | possible given the option specifications. | ||||
28 | |||||
29 | Method names beginning with an single underscore are public, and are named that | ||||
30 | way to avoid conflict with automatically generated methods. Methods with | ||||
31 | multiple underscores (in case you're reading the source) are private. | ||||
32 | |||||
33 | =head1 METHODS | ||||
34 | |||||
35 | B<Achtung!> All methods beginning with an underscore are experimental as of | ||||
36 | today, 2009-12-12. They are likely to be formally made permanent soon. | ||||
37 | |||||
38 | =head2 _specified | ||||
39 | |||||
40 | This method returns true if the given name was specified on the command line. | ||||
41 | |||||
42 | For example, if C<@ARGS> was "C<< --foo --bar 10 >>" and C<baz> is defined by a | ||||
43 | default, C<_specified> will return true for foo and bar, and false for baz. | ||||
44 | |||||
45 | =cut | ||||
46 | |||||
47 | 1 | 1µs | my %_CREATED_OPTS; | ||
48 | 1 | 1µs | my $SERIAL_NUMBER = 1; | ||
49 | |||||
50 | sub _specified { | ||||
51 | my ($self, $name) = @_; | ||||
52 | my $meta = $_CREATED_OPTS{ blessed $self }{meta}; | ||||
53 | return $meta->{given}{ $name }; | ||||
54 | } | ||||
55 | |||||
56 | =head2 _specified_opts | ||||
57 | |||||
58 | This method returns an opt object in which only explicitly specified values are | ||||
59 | defined. Values which were set by defaults will appear undef. | ||||
60 | |||||
61 | =cut | ||||
62 | |||||
63 | sub _specified_opts { | ||||
64 | my ($self) = @_; | ||||
65 | |||||
66 | my $class = blessed $self; | ||||
67 | my $meta = $_CREATED_OPTS{ $class }{meta}; | ||||
68 | |||||
69 | return $meta->{specified_opts} if $meta->{specified_opts}; | ||||
70 | |||||
71 | my @keys = grep { $meta->{given}{ $_ } } (keys %{ $meta->{given} }); | ||||
72 | |||||
73 | my %opts; | ||||
74 | @opts{ @keys } = @$self{ @keys }; | ||||
75 | |||||
76 | $meta->{specified_opts} = \%opts; | ||||
77 | |||||
78 | bless $meta->{specified_opts} => $class; | ||||
79 | weaken $meta->{specified_opts}; | ||||
80 | |||||
81 | $meta->{specified_opts}; | ||||
82 | } | ||||
83 | |||||
84 | =head2 _complete_opts | ||||
85 | |||||
86 | This method returns the opts object with all values, including those set by | ||||
87 | defaults. It is probably not going to be very often-used. | ||||
88 | |||||
89 | =cut | ||||
90 | |||||
91 | sub _complete_opts { | ||||
92 | my ($self) = @_; | ||||
93 | |||||
94 | my $class = blessed $self; | ||||
95 | my $meta = $_CREATED_OPTS{ $class }{meta}; | ||||
96 | return $meta->{complete_opts}; | ||||
97 | } | ||||
98 | |||||
99 | # spent 326µs (281+46) within Getopt::Long::Descriptive::Opts::___class_for_opt which was called:
# once (281µs+46µs) by Getopt::Long::Descriptive::Opts::___new_opt_obj at line 126 | ||||
100 | 55 | 329µs | my ($class, $arg) = @_; | ||
101 | |||||
102 | my $values = $arg->{values}; | ||||
103 | 22 | 36µs | my @bad = grep { $_ !~ /^[a-z_]\w*$/ } keys %$values; # spent 36µs making 22 calls to Getopt::Long::Descriptive::Opts::CORE:match, avg 2µs/call | ||
104 | Carp::confess("perverse option names given: @bad") if @bad; | ||||
105 | |||||
106 | my $new_class = "$class\::__OPT__::" . $SERIAL_NUMBER++; | ||||
107 | $_CREATED_OPTS{ $new_class } = { meta => $arg }; | ||||
108 | |||||
109 | { | ||||
110 | 2 | 195µs | 2 | 60µs | # spent 36µs (12+24) within Getopt::Long::Descriptive::Opts::BEGIN@110 which was called:
# once (12µs+24µs) by Getopt::Long::Descriptive::BEGIN@12 at line 110 # spent 36µs making 1 call to Getopt::Long::Descriptive::Opts::BEGIN@110
# spent 24µs making 1 call to strict::unimport |
111 | 1 | 10µs | ${"$new_class\::VERSION"} = $class->VERSION; # spent 10µs making 1 call to UNIVERSAL::VERSION | ||
112 | *{"$new_class\::ISA"} = [ 'Getopt::Long::Descriptive::Opts' ]; | ||||
113 | for my $opt (keys %$values) { | ||||
114 | *{"$new_class\::$opt"} = sub { $_[0]->{ $opt } }; | ||||
115 | } | ||||
116 | } | ||||
117 | |||||
118 | return $new_class; | ||||
119 | } | ||||
120 | |||||
121 | # spent 390µs (63+326) within Getopt::Long::Descriptive::Opts::___new_opt_obj which was called:
# once (63µs+326µs) by Getopt::Long::Descriptive::__ANON__[/home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/site_perl/5.13.5/Getopt/Long/Descriptive.pm:430] at line 426 of Getopt/Long/Descriptive.pm | ||||
122 | 7 | 64µs | my ($class, $arg) = @_; | ||
123 | |||||
124 | my $copy = { %{ $arg->{values} } }; | ||||
125 | |||||
126 | 1 | 326µs | my $new_class = $class->___class_for_opt($arg); # spent 326µs making 1 call to Getopt::Long::Descriptive::Opts::___class_for_opt | ||
127 | |||||
128 | # This is stupid, but the traditional behavior was that if --foo was not | ||||
129 | # given, there is no $opt->{foo}; it started to show up when we "needed" all | ||||
130 | # the keys to generate a class, but was undef; this wasn't a problem, but | ||||
131 | # broke tests of things that were relying on not-exists like tests of %$opt | ||||
132 | # contents or MooseX::Getopt which wanted to use things as args for new -- | ||||
133 | # undef would not pass an Int TC. Easier to just do this. -- rjbs, | ||||
134 | # 2009-11-27 | ||||
135 | delete $copy->{$_} for grep { ! defined $copy->{$_} } keys %$copy; | ||||
136 | |||||
137 | my $self = bless $copy => $new_class; | ||||
138 | |||||
139 | $_CREATED_OPTS{ $new_class }{meta}{complete_opts} = $self; | ||||
140 | # weaken $_CREATED_OPTS{ $new_class }{meta}{complete_opts}; | ||||
141 | |||||
142 | return $self; | ||||
143 | } | ||||
144 | |||||
145 | =head1 AUTHOR | ||||
146 | |||||
147 | Hans Dieter Pearcey, C<< <hdp@cpan.org> >> | ||||
148 | |||||
149 | =head1 BUGS | ||||
150 | |||||
151 | Please report any bugs or feature requests to | ||||
152 | C<bug-getopt-long-descriptive@rt.cpan.org>, or through the web interface at | ||||
153 | L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Getopt-Long-Descriptive>. | ||||
154 | I will be notified, and then you'll automatically be notified of progress on | ||||
155 | your bug as I make changes. | ||||
156 | |||||
157 | =head1 COPYRIGHT & LICENSE | ||||
158 | |||||
159 | Copyright 2005 Hans Dieter Pearcey, all rights reserved. | ||||
160 | |||||
161 | This program is free software; you can redistribute it and/or modify it | ||||
162 | under the same terms as Perl itself. | ||||
163 | |||||
164 | =cut | ||||
165 | |||||
166 | 1 | 3µs | 1; | ||
# spent 36µs within Getopt::Long::Descriptive::Opts::CORE:match which was called 22 times, avg 2µs/call:
# 22 times (36µs+0s) by Getopt::Long::Descriptive::Opts::___class_for_opt at line 103, avg 2µs/call |