| Filename | /usr/local/share/perl/5.18.2/Getopt/Long/Descriptive/Opts.pm |
| Statements | Executed 58 statements in 646µs |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 2 | 1 | 1 | 76µs | 89µs | Getopt::Long::Descriptive::Opts::___class_for_opt |
| 2 | 1 | 1 | 24µs | 113µs | Getopt::Long::Descriptive::Opts::___new_opt_obj |
| 1 | 1 | 1 | 11µs | 22µs | Getopt::Long::Descriptive::BEGIN@1 |
| 1 | 1 | 1 | 8µs | 37µs | Getopt::Long::Descriptive::Opts::BEGIN@6 |
| 1 | 1 | 1 | 7µs | 11µs | Getopt::Long::Descriptive::BEGIN@2 |
| 1 | 1 | 1 | 7µs | 19µs | Getopt::Long::Descriptive::Opts::BEGIN@99 |
| 5 | 1 | 1 | 5µs | 5µs | Getopt::Long::Descriptive::Opts::CORE:match (opcode) |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Opts::__ANON__[:103] |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Opts::_complete_opts |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Opts::_specified |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Opts::_specified_opts |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | 2 | 21µs | 2 | 34µs | # spent 22µs (11+12) within Getopt::Long::Descriptive::BEGIN@1 which was called:
# once (11µs+12µs) by Getopt::Long::Descriptive::BEGIN@13 at line 1 # spent 22µs making 1 call to Getopt::Long::Descriptive::BEGIN@1
# spent 12µs making 1 call to strict::import |
| 2 | 2 | 37µs | 2 | 15µs | # spent 11µs (7+4) within Getopt::Long::Descriptive::BEGIN@2 which was called:
# once (7µs+4µs) by Getopt::Long::Descriptive::BEGIN@13 at line 2 # spent 11µs making 1 call to Getopt::Long::Descriptive::BEGIN@2
# spent 4µs making 1 call to warnings::import |
| 3 | package Getopt::Long::Descriptive::Opts; | ||||
| 4 | # ABSTRACT: object representing command line switches | ||||
| 5 | 1 | 400ns | $Getopt::Long::Descriptive::Opts::VERSION = '0.097'; | ||
| 6 | 2 | 294µs | 2 | 67µs | # spent 37µs (8+30) within Getopt::Long::Descriptive::Opts::BEGIN@6 which was called:
# once (8µs+30µs) by Getopt::Long::Descriptive::BEGIN@13 at line 6 # spent 37µs making 1 call to Getopt::Long::Descriptive::Opts::BEGIN@6
# spent 30µs making 1 call to Exporter::import |
| 7 | |||||
| 8 | # =head1 DESCRIPTION | ||||
| 9 | # | ||||
| 10 | # This class is the base class of all C<$opt> objects returned by | ||||
| 11 | # L<Getopt::Long::Descriptive>. In general, you do not want to think about this | ||||
| 12 | # class, look at it, or alter it. Seriously, it's pretty dumb. | ||||
| 13 | # | ||||
| 14 | # Every call to C<describe_options> will return a object of a new subclass of | ||||
| 15 | # this class. It will have a method for the canonical name of each option | ||||
| 16 | # possible given the option specifications. | ||||
| 17 | # | ||||
| 18 | # Method names beginning with an single underscore are public, and are named that | ||||
| 19 | # way to avoid conflict with automatically generated methods. Methods with | ||||
| 20 | # multiple underscores (in case you're reading the source) are private. | ||||
| 21 | # | ||||
| 22 | # =head1 METHODS | ||||
| 23 | # | ||||
| 24 | # B<Achtung!> All methods beginning with an underscore are experimental as of | ||||
| 25 | # today, 2009-12-12. They are likely to be formally made permanent soon. | ||||
| 26 | # | ||||
| 27 | # =head2 _specified | ||||
| 28 | # | ||||
| 29 | # This method returns true if the given name was specified on the command line. | ||||
| 30 | # | ||||
| 31 | # For example, if C<@ARGS> was "C<< --foo --bar 10 >>" and C<baz> is defined by a | ||||
| 32 | # default, C<_specified> will return true for foo and bar, and false for baz. | ||||
| 33 | # | ||||
| 34 | # =cut | ||||
| 35 | |||||
| 36 | 1 | 100ns | my %_CREATED_OPTS; | ||
| 37 | 1 | 200ns | my $SERIAL_NUMBER = 1; | ||
| 38 | |||||
| 39 | sub _specified { | ||||
| 40 | my ($self, $name) = @_; | ||||
| 41 | my $meta = $_CREATED_OPTS{ blessed $self }{meta}; | ||||
| 42 | return $meta->{given}{ $name }; | ||||
| 43 | } | ||||
| 44 | |||||
| 45 | # =head2 _specified_opts | ||||
| 46 | # | ||||
| 47 | # This method returns an opt object in which only explicitly specified values are | ||||
| 48 | # defined. Values which were set by defaults will appear undef. | ||||
| 49 | # | ||||
| 50 | # =cut | ||||
| 51 | |||||
| 52 | sub _specified_opts { | ||||
| 53 | my ($self) = @_; | ||||
| 54 | |||||
| 55 | my $class = blessed $self; | ||||
| 56 | my $meta = $_CREATED_OPTS{ $class }{meta}; | ||||
| 57 | |||||
| 58 | return $meta->{specified_opts} if $meta->{specified_opts}; | ||||
| 59 | |||||
| 60 | my @keys = grep { $meta->{given}{ $_ } } (keys %{ $meta->{given} }); | ||||
| 61 | |||||
| 62 | my %opts; | ||||
| 63 | @opts{ @keys } = @$self{ @keys }; | ||||
| 64 | |||||
| 65 | $meta->{specified_opts} = \%opts; | ||||
| 66 | |||||
| 67 | bless $meta->{specified_opts} => $class; | ||||
| 68 | weaken $meta->{specified_opts}; | ||||
| 69 | |||||
| 70 | $meta->{specified_opts}; | ||||
| 71 | } | ||||
| 72 | |||||
| 73 | # =head2 _complete_opts | ||||
| 74 | # | ||||
| 75 | # This method returns the opts object with all values, including those set by | ||||
| 76 | # defaults. It is probably not going to be very often-used. | ||||
| 77 | # | ||||
| 78 | # =cut | ||||
| 79 | |||||
| 80 | sub _complete_opts { | ||||
| 81 | my ($self) = @_; | ||||
| 82 | |||||
| 83 | my $class = blessed $self; | ||||
| 84 | my $meta = $_CREATED_OPTS{ $class }{meta}; | ||||
| 85 | return $meta->{complete_opts}; | ||||
| 86 | } | ||||
| 87 | |||||
| 88 | # spent 89µs (76+12) within Getopt::Long::Descriptive::Opts::___class_for_opt which was called 2 times, avg 44µs/call:
# 2 times (76µs+12µs) by Getopt::Long::Descriptive::Opts::___new_opt_obj at line 115, avg 44µs/call | ||||
| 89 | 2 | 600ns | my ($class, $arg) = @_; | ||
| 90 | |||||
| 91 | 2 | 800ns | my $values = $arg->{values}; | ||
| 92 | 7 | 20µs | 5 | 5µs | my @bad = grep { $_ !~ /^[a-z_]\w*$/ } keys %$values; # spent 5µs making 5 calls to Getopt::Long::Descriptive::Opts::CORE:match, avg 1µs/call |
| 93 | 2 | 800ns | Carp::confess("perverse option names given: @bad") if @bad; | ||
| 94 | |||||
| 95 | 2 | 3µs | my $new_class = "$class\::__OPT__::" . $SERIAL_NUMBER++; | ||
| 96 | 2 | 2µs | $_CREATED_OPTS{ $new_class } = { meta => $arg }; | ||
| 97 | |||||
| 98 | { | ||||
| 99 | 4 | 175µs | 2 | 31µs | # spent 19µs (7+12) within Getopt::Long::Descriptive::Opts::BEGIN@99 which was called:
# once (7µs+12µs) by Getopt::Long::Descriptive::BEGIN@13 at line 99 # spent 19µs making 1 call to Getopt::Long::Descriptive::Opts::BEGIN@99
# spent 12µs making 1 call to strict::unimport |
| 100 | 2 | 24µs | 2 | 7µs | ${"$new_class\::VERSION"} = $class->VERSION; # spent 7µs making 2 calls to UNIVERSAL::VERSION, avg 4µs/call |
| 101 | 2 | 14µs | *{"$new_class\::ISA"} = [ 'Getopt::Long::Descriptive::Opts' ]; | ||
| 102 | 2 | 3µs | for my $opt (keys %$values) { | ||
| 103 | 5 | 17µs | *{"$new_class\::$opt"} = sub { $_[0]->{ $opt } }; | ||
| 104 | } | ||||
| 105 | } | ||||
| 106 | |||||
| 107 | 2 | 6µs | return $new_class; | ||
| 108 | } | ||||
| 109 | |||||
| 110 | # spent 113µs (24+89) within Getopt::Long::Descriptive::Opts::___new_opt_obj which was called 2 times, avg 56µs/call:
# 2 times (24µs+89µs) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 466 of Getopt/Long/Descriptive.pm, avg 56µs/call | ||||
| 111 | 2 | 800ns | my ($class, $arg) = @_; | ||
| 112 | |||||
| 113 | 2 | 3µs | my $copy = { %{ $arg->{values} } }; | ||
| 114 | |||||
| 115 | 2 | 4µs | 2 | 89µs | my $new_class = $class->___class_for_opt($arg); # spent 89µs making 2 calls to Getopt::Long::Descriptive::Opts::___class_for_opt, avg 44µs/call |
| 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 | 2 | 7µs | delete $copy->{$_} for grep { ! defined $copy->{$_} } keys %$copy; | ||
| 125 | |||||
| 126 | 2 | 3µs | my $self = bless $copy => $new_class; | ||
| 127 | |||||
| 128 | 2 | 2µs | $_CREATED_OPTS{ $new_class }{meta}{complete_opts} = $self; | ||
| 129 | # weaken $_CREATED_OPTS{ $new_class }{meta}{complete_opts}; | ||||
| 130 | |||||
| 131 | 2 | 6µs | return $self; | ||
| 132 | } | ||||
| 133 | |||||
| 134 | 1 | 3µs | 1; | ||
| 135 | |||||
| 136 | __END__ | ||||
# spent 5µs within Getopt::Long::Descriptive::Opts::CORE:match which was called 5 times, avg 1µs/call:
# 5 times (5µs+0s) by Getopt::Long::Descriptive::Opts::___class_for_opt at line 92, avg 1µs/call |