| Filename | /usr/share/perl/5.18/Pod/Perldoc/GetOptsOO.pm |
| Statements | Executed 7 statements in 428µs |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 10µs | 21µs | Pod::Perldoc::GetOptsOO::BEGIN@2 |
| 1 | 1 | 1 | 7µs | 23µs | Pod::Perldoc::GetOptsOO::BEGIN@4 |
| 1 | 1 | 1 | 4µs | 4µs | Pod::Perldoc::GetOptsOO::BEGIN@7 |
| 0 | 0 | 0 | 0s | 0s | Pod::Perldoc::GetOptsOO::getopts |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Pod::Perldoc::GetOptsOO; | ||||
| 2 | 2 | 28µs | 2 | 31µs | # spent 21µs (10+11) within Pod::Perldoc::GetOptsOO::BEGIN@2 which was called:
# once (10µs+11µs) by Pod::Perldoc::BEGIN@30 at line 2 # spent 21µs making 1 call to Pod::Perldoc::GetOptsOO::BEGIN@2
# spent 11µs making 1 call to strict::import |
| 3 | |||||
| 4 | 2 | 50µs | 2 | 39µs | # spent 23µs (7+16) within Pod::Perldoc::GetOptsOO::BEGIN@4 which was called:
# once (7µs+16µs) by Pod::Perldoc::BEGIN@30 at line 4 # spent 23µs making 1 call to Pod::Perldoc::GetOptsOO::BEGIN@4
# spent 16µs making 1 call to vars::import |
| 5 | 1 | 700ns | $VERSION = '3.19'; | ||
| 6 | |||||
| 7 | # spent 4µs within Pod::Perldoc::GetOptsOO::BEGIN@7 which was called:
# once (4µs+0s) by Pod::Perldoc::BEGIN@30 at line 11 | ||||
| 8 | *DEBUG = defined( &Pod::Perldoc::DEBUG ) | ||||
| 9 | ? \&Pod::Perldoc::DEBUG | ||||
| 10 | 1 | 4µs | : sub(){10}; | ||
| 11 | 1 | 343µs | 1 | 4µs | } # spent 4µs making 1 call to Pod::Perldoc::GetOptsOO::BEGIN@7 |
| 12 | |||||
| 13 | |||||
| 14 | sub getopts { | ||||
| 15 | my($target, $args, $truth) = @_; | ||||
| 16 | |||||
| 17 | $args ||= \@ARGV; | ||||
| 18 | |||||
| 19 | $target->aside( | ||||
| 20 | "Starting switch processing. Scanning arguments [@$args]\n" | ||||
| 21 | ) if $target->can('aside'); | ||||
| 22 | |||||
| 23 | return unless @$args; | ||||
| 24 | |||||
| 25 | $truth = 1 unless @_ > 2; | ||||
| 26 | |||||
| 27 | DEBUG > 3 and print " Truth is $truth\n"; | ||||
| 28 | |||||
| 29 | |||||
| 30 | my $error_count = 0; | ||||
| 31 | |||||
| 32 | while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) { | ||||
| 33 | my($first,$rest) = ($1,$2); | ||||
| 34 | if ($_ eq '--') { # early exit if "--" | ||||
| 35 | shift @$args; | ||||
| 36 | last; | ||||
| 37 | } | ||||
| 38 | if ($first eq '-' and $rest) { # GNU style long param names | ||||
| 39 | ($first, $rest) = split '=', $rest, 2; | ||||
| 40 | } | ||||
| 41 | my $method = "opt_${first}_with"; | ||||
| 42 | if( $target->can($method) ) { # it's argumental | ||||
| 43 | if($rest eq '') { # like -f bar | ||||
| 44 | shift @$args; | ||||
| 45 | $target->warn( "Option $first needs a following argument!\n" ) unless @$args; | ||||
| 46 | $rest = shift @$args; | ||||
| 47 | } else { # like -fbar (== -f bar) | ||||
| 48 | shift @$args; | ||||
| 49 | } | ||||
| 50 | |||||
| 51 | DEBUG > 3 and print " $method => $rest\n"; | ||||
| 52 | $target->$method( $rest ); | ||||
| 53 | |||||
| 54 | # Otherwise, it's not argumental... | ||||
| 55 | } else { | ||||
| 56 | |||||
| 57 | if( $target->can( $method = "opt_$first" ) ) { | ||||
| 58 | DEBUG > 3 and print " $method is true ($truth)\n"; | ||||
| 59 | $target->$method( $truth ); | ||||
| 60 | |||||
| 61 | # Otherwise it's an unknown option... | ||||
| 62 | |||||
| 63 | } elsif( $target->can('handle_unknown_option') ) { | ||||
| 64 | DEBUG > 3 | ||||
| 65 | and print " calling handle_unknown_option('$first')\n"; | ||||
| 66 | |||||
| 67 | $error_count += ( | ||||
| 68 | $target->handle_unknown_option( $first ) || 0 | ||||
| 69 | ); | ||||
| 70 | |||||
| 71 | } else { | ||||
| 72 | ++$error_count; | ||||
| 73 | $target->warn( "Unknown option: $first\n" ); | ||||
| 74 | } | ||||
| 75 | |||||
| 76 | if($rest eq '') { # like -f | ||||
| 77 | shift @$args | ||||
| 78 | } else { # like -fbar (== -f -bar ) | ||||
| 79 | DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n"; | ||||
| 80 | $args->[0] = "-$rest"; | ||||
| 81 | } | ||||
| 82 | } | ||||
| 83 | } | ||||
| 84 | |||||
| 85 | |||||
| 86 | $target->aside( | ||||
| 87 | "Ending switch processing. Args are [@$args] with $error_count errors.\n" | ||||
| 88 | ) if $target->can('aside'); | ||||
| 89 | |||||
| 90 | $error_count == 0; | ||||
| 91 | } | ||||
| 92 | |||||
| 93 | 1 | 2µs | 1; | ||
| 94 | |||||
| 95 | __END__ |