3 package Pod::Perldoc::GetOptsOO;
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
17 # The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors,
18 # otherwise it's false.
20 ## sburke@cpan.org 2002-10-31
22 BEGIN { # Make a DEBUG constant ASAP
23 *DEBUG = defined( &Pod::Perldoc::DEBUG )
24 ? \&Pod::Perldoc::DEBUG
30 my($target, $args, $truth) = @_;
35 "Starting switch processing. Scanning arguments [@$args]\n"
36 ) if $target->can('aside');
40 $truth = 1 unless @_ > 2;
42 DEBUG > 3 and print " Truth is $truth\n";
47 while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) {
48 my($first,$rest) = ($1,$2);
49 if ($_ eq '--') { # early exit if "--"
53 my $method = "opt_${first}_with";
54 if( $target->can($method) ) { # it's argumental
55 if($rest eq '') { # like -f bar
57 warn "Option $first needs a following argument!\n" unless @$args;
59 } else { # like -fbar (== -f bar)
63 DEBUG > 3 and print " $method => $rest\n";
64 $target->$method( $rest );
66 # Otherwise, it's not argumental...
69 if( $target->can( $method = "opt_$first" ) ) {
70 DEBUG > 3 and print " $method is true ($truth)\n";
71 $target->$method( $truth );
73 # Otherwise it's an unknown option...
75 } elsif( $target->can('handle_unknown_option') ) {
77 and print " calling handle_unknown_option('$first')\n";
80 $target->handle_unknown_option( $first ) || 0
85 warn "Unknown option: $first\n";
88 if($rest eq '') { # like -f
90 } else { # like -fbar (== -f -bar )
91 DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n";
92 $args->[0] = "-$rest";
99 "Ending switch processing. Args are [@$args] with $error_count errors.\n"
100 ) if $target->can('aside');