cpan/Pod-Perldoc/lib/Pod/Perldoc/GetOptsOO.pm

   1 package Pod::Perldoc::GetOptsOO;
   2 use strict;
   3
   4 use vars qw($VERSION);
   5 $VERSION = '3.19';
   6
   7 BEGIN { # Make a DEBUG constant ASAP
   8   *DEBUG = defined( &Pod::Perldoc::DEBUG )
   9    ? \&Pod::Perldoc::DEBUG
  10    : sub(){10};
  11 }
  12
  13
  14 sub 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
  93 1;
  94
  95 __END__
  96
  97 =head1 NAME
  98
  99 Pod::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
 111 Implements a customized option parser used for
 112 L<Pod::Perldoc>.
 113
 114 Rather 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
 134 The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors,
 135 otherwise it's false.
 136
 137 =head1 SEE ALSO
 138
 139 L<Pod::Perldoc>
 140
 141 =head1 COPYRIGHT AND DISCLAIMERS
 142
 143 Copyright (c) 2002-2007 Sean M. Burke.
 144
 145 This library is free software; you can redistribute it and/or modify it
 146 under the same terms as Perl itself.
 147
 148 This program is distributed in the hope that it will be useful, but
 149 without any warranty; without even the implied warranty of
 150 merchantability or fitness for a particular purpose.
 151
 152 =head1 AUTHOR
 153
 154 Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
 155
 156 Past contributions from:
 157 brian d foy C<< <bdfoy@cpan.org> >>
 158 Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
 159 Sean M. Burke C<< <sburke@cpan.org> >>
 160
 161 =cut