Commit | Line | Data |
1a67fee7 |
1 | |
2 | require 5; |
3 | package Pod::Perldoc::GetOptsOO; |
4 | use strict; |
5 | |
6 | # Rather like Getopt::Std's getopts |
7 | # Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth) |
8 | # Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT ) |
9 | # (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo") |
10 | # Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth) |
11 | # (Truth defaults to 1) |
12 | # Otherwise we try calling $object->handle_unknown_option('n') |
13 | # (and we increment the error count by the return value of it) |
14 | # If there's no handle_unknown_option, then we just warn, and then increment |
15 | # the error counter |
16 | # |
17 | # The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors, |
18 | # otherwise it's false. |
19 | # |
20 | ## sburke@cpan.org 2002-10-31 |
21 | |
22 | BEGIN { # Make a DEBUG constant ASAP |
23 | *DEBUG = defined( &Pod::Perldoc::DEBUG ) |
24 | ? \&Pod::Perldoc::DEBUG |
25 | : sub(){10}; |
26 | } |
27 | |
28 | |
29 | sub getopts { |
30 | my($target, $args, $truth) = @_; |
31 | |
32 | $args ||= \@ARGV; |
33 | |
34 | $target->aside( |
35 | "Starting switch processing. Scanning arguments [@$args]\n" |
36 | ) if $target->can('aside'); |
37 | |
38 | return unless @$args; |
39 | |
40 | $truth = 1 unless @_ > 2; |
41 | |
42 | DEBUG > 3 and print " Truth is $truth\n"; |
43 | |
44 | |
45 | my $error_count = 0; |
46 | |
47 | while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) { |
48 | my($first,$rest) = ($1,$2); |
49 | if ($_ eq '--') { # early exit if "--" |
50 | shift @$args; |
51 | last; |
52 | } |
53 | my $method = "opt_${first}_with"; |
54 | if( $target->can($method) ) { # it's argumental |
55 | if($rest eq '') { # like -f bar |
56 | shift @$args; |
57 | warn "Option $first needs a following argument!\n" unless @$args; |
58 | $rest = shift @$args; |
59 | } else { # like -fbar (== -f bar) |
60 | shift @$args; |
61 | } |
62 | |
63 | DEBUG > 3 and print " $method => $rest\n"; |
64 | $target->$method( $rest ); |
65 | |
66 | # Otherwise, it's not argumental... |
67 | } else { |
68 | |
69 | if( $target->can( $method = "opt_$first" ) ) { |
70 | DEBUG > 3 and print " $method is true ($truth)\n"; |
71 | $target->$method( $truth ); |
72 | |
73 | # Otherwise it's an unknown option... |
74 | |
75 | } elsif( $target->can('handle_unknown_option') ) { |
76 | DEBUG > 3 |
77 | and print " calling handle_unknown_option('$first')\n"; |
78 | |
79 | $error_count += ( |
80 | $target->handle_unknown_option( $first ) || 0 |
81 | ); |
82 | |
83 | } else { |
84 | ++$error_count; |
85 | warn "Unknown option: $first\n"; |
86 | } |
87 | |
88 | if($rest eq '') { # like -f |
89 | shift @$args |
90 | } else { # like -fbar (== -f -bar ) |
91 | DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n"; |
92 | $args->[0] = "-$rest"; |
93 | } |
94 | } |
95 | } |
96 | |
97 | |
98 | $target->aside( |
99 | "Ending switch processing. Args are [@$args] with $error_count errors.\n" |
100 | ) if $target->can('aside'); |
101 | |
102 | $error_count == 0; |
103 | } |
104 | |
105 | 1; |
106 | |