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