| Filename | /usr/local/share/perl/5.18.2/Getopt/Long/Descriptive/Usage.pm |
| Statements | Executed 20 statements in 675µs |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 2 | 1 | 1 | 13µs | 13µs | Getopt::Long::Descriptive::Usage::new |
| 1 | 1 | 1 | 12µs | 43µs | Getopt::Long::Descriptive::Usage::BEGIN@171 |
| 1 | 1 | 1 | 11µs | 42µs | Getopt::Long::Descriptive::Usage::BEGIN@6 |
| 1 | 1 | 1 | 10µs | 20µs | Getopt::Long::Descriptive::BEGIN@1.16 |
| 1 | 1 | 1 | 7µs | 10µs | Getopt::Long::Descriptive::BEGIN@2.17 |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Usage::__ANON__[:179] |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Usage::__ANON__[:180] |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Usage::_split_description |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Usage::die |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Usage::leader_text |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Usage::option_text |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Usage::text |
| 0 | 0 | 0 | 0s | 0s | Getopt::Long::Descriptive::Usage::warn |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | 2 | 21µs | 2 | 31µs | # spent 20µs (10+11) within Getopt::Long::Descriptive::BEGIN@1.16 which was called:
# once (10µs+11µs) by Getopt::Long::Descriptive::BEGIN@14 at line 1 # spent 20µs making 1 call to Getopt::Long::Descriptive::BEGIN@1.16
# spent 11µs making 1 call to strict::import |
| 2 | 2 | 40µs | 2 | 14µs | # spent 10µs (7+3) within Getopt::Long::Descriptive::BEGIN@2.17 which was called:
# once (7µs+3µs) by Getopt::Long::Descriptive::BEGIN@14 at line 2 # spent 10µs making 1 call to Getopt::Long::Descriptive::BEGIN@2.17
# spent 4µs making 1 call to warnings::import |
| 3 | package Getopt::Long::Descriptive::Usage; | ||||
| 4 | # ABSTRACT: the usage description for GLD | ||||
| 5 | 1 | 700ns | $Getopt::Long::Descriptive::Usage::VERSION = '0.097'; | ||
| 6 | 2 | 572µs | 2 | 50µs | # spent 42µs (11+31) within Getopt::Long::Descriptive::Usage::BEGIN@6 which was called:
# once (11µs+31µs) by Getopt::Long::Descriptive::BEGIN@14 at line 6 # spent 42µs making 1 call to Getopt::Long::Descriptive::Usage::BEGIN@6
# spent 8µs making 1 call to List::Util::import |
| 7 | |||||
| 8 | # =head1 SYNOPSIS | ||||
| 9 | # | ||||
| 10 | # use Getopt::Long::Descriptive; | ||||
| 11 | # my ($opt, $usage) = describe_options( ... ); | ||||
| 12 | # | ||||
| 13 | # $usage->text; # complete usage message | ||||
| 14 | # | ||||
| 15 | # $usage->die; # die with usage message | ||||
| 16 | # | ||||
| 17 | # =head1 DESCRIPTION | ||||
| 18 | # | ||||
| 19 | # This document only describes the methods of the Usage object. For information | ||||
| 20 | # on how to use L<Getopt::Long::Descriptive>, consult its documentation. | ||||
| 21 | # | ||||
| 22 | # =head1 METHODS | ||||
| 23 | # | ||||
| 24 | # =head2 new | ||||
| 25 | # | ||||
| 26 | # my $usage = Getopt::Long::Descriptive::Usage->new(\%arg); | ||||
| 27 | # | ||||
| 28 | # You B<really> don't need to call this. GLD will do it for you. | ||||
| 29 | # | ||||
| 30 | # Valid arguments are: | ||||
| 31 | # | ||||
| 32 | # options - an arrayref of options | ||||
| 33 | # leader_text - the text that leads the usage; this may go away! | ||||
| 34 | # | ||||
| 35 | # =cut | ||||
| 36 | |||||
| 37 | # spent 13µs within Getopt::Long::Descriptive::Usage::new which was called 2 times, avg 7µs/call:
# 2 times (13µs+0s) by Getopt::Long::Descriptive::__ANON__[/usr/local/share/perl/5.18.2/Getopt/Long/Descriptive.pm:470] at line 421 of Getopt/Long/Descriptive.pm, avg 7µs/call | ||||
| 38 | 2 | 900ns | my ($class, $arg) = @_; | ||
| 39 | |||||
| 40 | 2 | 2µs | my @to_copy = qw(options leader_text show_defaults); | ||
| 41 | |||||
| 42 | 2 | 300ns | my %copy; | ||
| 43 | 2 | 5µs | @copy{ @to_copy } = @$arg{ @to_copy }; | ||
| 44 | |||||
| 45 | 2 | 9µs | bless \%copy => $class; | ||
| 46 | } | ||||
| 47 | |||||
| 48 | # =head2 text | ||||
| 49 | # | ||||
| 50 | # This returns the full text of the usage message. | ||||
| 51 | # | ||||
| 52 | # =cut | ||||
| 53 | |||||
| 54 | sub text { | ||||
| 55 | my ($self) = @_; | ||||
| 56 | |||||
| 57 | return join qq{\n}, $self->leader_text, $self->option_text; | ||||
| 58 | } | ||||
| 59 | |||||
| 60 | # =head2 leader_text | ||||
| 61 | # | ||||
| 62 | # This returns the text that comes at the beginning of the usage message. | ||||
| 63 | # | ||||
| 64 | # =cut | ||||
| 65 | |||||
| 66 | sub leader_text { $_[0]->{leader_text} } | ||||
| 67 | |||||
| 68 | # =head2 option_text | ||||
| 69 | # | ||||
| 70 | # This returns the text describing the available options. | ||||
| 71 | # | ||||
| 72 | # =cut | ||||
| 73 | |||||
| 74 | sub option_text { | ||||
| 75 | my ($self) = @_; | ||||
| 76 | |||||
| 77 | my @options = @{ $self->{options} || [] }; | ||||
| 78 | my $string = q{}; | ||||
| 79 | |||||
| 80 | # a spec can grow up to 4 characters in usage output: | ||||
| 81 | # '-' on short option, ' ' between short and long, '--' on long | ||||
| 82 | my @specs = map { $_->{spec} } grep { $_->{desc} ne 'spacer' } @options; | ||||
| 83 | my $length = (max(map { length } @specs) || 0) + 4; | ||||
| 84 | my $spec_fmt = "\t%-${length}s"; | ||||
| 85 | |||||
| 86 | while (@options) { | ||||
| 87 | my $opt = shift @options; | ||||
| 88 | my $spec = $opt->{spec}; | ||||
| 89 | my $desc = $opt->{desc}; | ||||
| 90 | if ($desc eq 'spacer') { | ||||
| 91 | $string .= sprintf "$spec_fmt\n", $opt->{spec}; | ||||
| 92 | next; | ||||
| 93 | } | ||||
| 94 | |||||
| 95 | $spec = Getopt::Long::Descriptive->_strip_assignment($spec); | ||||
| 96 | $spec = join " ", reverse map { length > 1 ? "--$_" : "-$_" } | ||||
| 97 | split /\|/, $spec; | ||||
| 98 | |||||
| 99 | my @desc = $self->_split_description($length, $desc); | ||||
| 100 | |||||
| 101 | # add default value if it exists | ||||
| 102 | if ( $opt->{constraint}->{default} and $self->{show_defaults}) { | ||||
| 103 | my $dflt = $opt->{constraint}->{default}; | ||||
| 104 | push @desc, "(default value: $dflt)"; | ||||
| 105 | } | ||||
| 106 | |||||
| 107 | $string .= sprintf "$spec_fmt %s\n", $spec, shift @desc; | ||||
| 108 | for my $line (@desc) { | ||||
| 109 | $string .= "\t"; | ||||
| 110 | $string .= q{ } x ( $length + 2 ); | ||||
| 111 | $string .= "$line\n"; | ||||
| 112 | } | ||||
| 113 | } | ||||
| 114 | |||||
| 115 | return $string; | ||||
| 116 | } | ||||
| 117 | |||||
| 118 | sub _split_description { | ||||
| 119 | my ($self, $length, $desc) = @_; | ||||
| 120 | |||||
| 121 | # 8 for a tab, 2 for the space between option & desc; | ||||
| 122 | my $max_length = 78 - ( $length + 8 + 2 ); | ||||
| 123 | |||||
| 124 | return $desc if length $desc <= $max_length; | ||||
| 125 | |||||
| 126 | my @lines; | ||||
| 127 | while (length $desc > $max_length) { | ||||
| 128 | my $idx = rindex( substr( $desc, 0, $max_length ), q{ }, ); | ||||
| 129 | last unless $idx >= 0; | ||||
| 130 | push @lines, substr($desc, 0, $idx); | ||||
| 131 | substr($desc, 0, $idx + 1) = q{}; | ||||
| 132 | } | ||||
| 133 | push @lines, $desc; | ||||
| 134 | |||||
| 135 | return @lines; | ||||
| 136 | } | ||||
| 137 | |||||
| 138 | # =head2 warn | ||||
| 139 | # | ||||
| 140 | # This warns with the usage message. | ||||
| 141 | # | ||||
| 142 | # =cut | ||||
| 143 | |||||
| 144 | sub warn { warn shift->text } | ||||
| 145 | |||||
| 146 | # =head2 die | ||||
| 147 | # | ||||
| 148 | # This throws the usage message as an exception. | ||||
| 149 | # | ||||
| 150 | # $usage_obj->die(\%arg); | ||||
| 151 | # | ||||
| 152 | # Some arguments can be provided | ||||
| 153 | # | ||||
| 154 | # pre_text - text to be prepended to the usage message | ||||
| 155 | # post_text - text to be appended to the usage message | ||||
| 156 | # | ||||
| 157 | # The C<pre_text> and C<post_text> arguments are concatenated with the usage | ||||
| 158 | # message with no line breaks, so supply this if you need them. | ||||
| 159 | # | ||||
| 160 | # =cut | ||||
| 161 | |||||
| 162 | sub die { | ||||
| 163 | my $self = shift; | ||||
| 164 | my $arg = shift || {}; | ||||
| 165 | |||||
| 166 | die( | ||||
| 167 | join q{}, grep { defined } $arg->{pre_text}, $self->text, $arg->{post_text} | ||||
| 168 | ); | ||||
| 169 | } | ||||
| 170 | |||||
| 171 | # spent 43µs (12+31) within Getopt::Long::Descriptive::Usage::BEGIN@171 which was called:
# once (12µs+31µs) by Getopt::Long::Descriptive::BEGIN@14 at line 181 | ||||
| 172 | q{""} => "text", | ||||
| 173 | |||||
| 174 | # This is only needed because Usage used to be a blessed coderef that worked | ||||
| 175 | # this way. Later we can toss a warning in here. -- rjbs, 2009-08-19 | ||||
| 176 | '&{}' => sub { | ||||
| 177 | my ($self) = @_; | ||||
| 178 | Carp::cluck("use of __PACKAGE__ objects as a code ref is deprecated"); | ||||
| 179 | return sub { return $_[0] ? $self->text : $self->warn; }; | ||||
| 180 | } | ||||
| 181 | 2 | 23µs | 2 | 74µs | ); # spent 43µs making 1 call to Getopt::Long::Descriptive::Usage::BEGIN@171
# spent 31µs making 1 call to overload::import |
| 182 | |||||
| 183 | 1 | 2µs | 1; | ||
| 184 | |||||
| 185 | __END__ |