Move Pod::Perldoc from ext/ to dist/
[perl.git] / dist / Pod-Perldoc / lib / Pod / Perldoc / GetOptsOO.pm
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
107 __END__
108
109 =head1 NAME
110
111 Pod::Perldoc::GetOptsOO - Customized option parser for Pod::Perldoc
112
113 =head1 SYNOPSIS
114
115     use Pod::Perldoc::GetOptsOO ();
116
117     Pod::Perldoc::GetOptsOO::getopts( $obj, \@args, $truth )
118        or die "wrong usage";
119
120
121 =head1 DESCRIPTION
122
123 Implements a customized option parser used for
124 L<Pod::Perldoc>.
125
126 =head1 SEE ALSO
127
128     Pod::Perldoc
129
130 =head1 COPYRIGHT AND DISCLAIMERS
131
132 Copyright (c) 2002-2007 Sean M. Burke.
133
134 This library is free software; you can redistribute it and/or modify it
135 under the same terms as Perl itself.
136
137 This program is distributed in the hope that it will be useful, but
138 without any warranty; without even the implied warranty of
139 merchantability or fitness for a particular purpose.
140
141 =head1 AUTHOR
142
143 Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
144
145 Past contributions from:
146 Sean M. Burke <sburke@cpan.org>
147
148 =cut