[Summary view] [Print] [Text view]

   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