home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _56e9d55ff3104a6eed2ec609fa8075d2 < prev    next >
Encoding:
Text File  |  2004-06-01  |  2.8 KB  |  107 lines
  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.