1
2require 5;
3package Pod::Perldoc::GetOptsOO;
4use 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
22BEGIN { # Make a DEBUG constant ASAP
23  *DEBUG = defined( &Pod::Perldoc::DEBUG )
24   ? \&Pod::Perldoc::DEBUG
25   : sub(){10};
26}
27
28
29sub 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
1051;
106
107