Commit | Line | Data |
---|---|---|
920dae64 AT |
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 |