1package Pod::Perldoc::GetOptsOO;
2use strict;
3
4use vars qw($VERSION);
5$VERSION = '3.28';
6
7BEGIN { # Make a DEBUG constant ASAP
8  *DEBUG = defined( &Pod::Perldoc::DEBUG )
9   ? \&Pod::Perldoc::DEBUG
10   : sub(){10};
11}
12
13
14sub 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
931;
94
95__END__
96
97=head1 NAME
98
99Pod::Perldoc::GetOptsOO - Customized option parser for Pod::Perldoc
100
101=head1 SYNOPSIS
102
103    use Pod::Perldoc::GetOptsOO ();
104
105    Pod::Perldoc::GetOptsOO::getopts( $obj, \@args, $truth )
106       or die "wrong usage";
107
108
109=head1 DESCRIPTION
110
111Implements a customized option parser used for
112L<Pod::Perldoc>.
113
114Rather like Getopt::Std's getopts:
115
116=over
117
118=item Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth)
119
120=item Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT )
121   (e.g., "-n foo" => $object->opt_n_with('foo').  Ditto "-nfoo")
122
123=item Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth)
124   (Truth defaults to 1)
125
126=item Otherwise we try calling $object->handle_unknown_option('n')
127   (and we increment the error count by the return value of it)
128
129=item If there's no handle_unknown_option, then we just warn, and then increment
130   the error counter
131
132=back
133
134The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors,
135otherwise it's false.
136
137=head1 SEE ALSO
138
139L<Pod::Perldoc>
140
141=head1 COPYRIGHT AND DISCLAIMERS
142
143Copyright (c) 2002-2007 Sean M. Burke.
144
145This library is free software; you can redistribute it and/or modify it
146under the same terms as Perl itself.
147
148This program is distributed in the hope that it will be useful, but
149without any warranty; without even the implied warranty of
150merchantability or fitness for a particular purpose.
151
152=head1 AUTHOR
153
154Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
155
156Past contributions from:
157brian d foy C<< <bdfoy@cpan.org> >>
158Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
159Sean M. Burke C<< <sburke@cpan.org> >>
160
161=cut
162