1*0Sstevel@tonic-gate 2*0Sstevel@tonic-gaterequire 5; 3*0Sstevel@tonic-gatepackage Pod::Perldoc::GetOptsOO; 4*0Sstevel@tonic-gateuse strict; 5*0Sstevel@tonic-gate 6*0Sstevel@tonic-gate# Rather like Getopt::Std's getopts 7*0Sstevel@tonic-gate# Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth) 8*0Sstevel@tonic-gate# Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT ) 9*0Sstevel@tonic-gate# (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo") 10*0Sstevel@tonic-gate# Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth) 11*0Sstevel@tonic-gate# (Truth defaults to 1) 12*0Sstevel@tonic-gate# Otherwise we try calling $object->handle_unknown_option('n') 13*0Sstevel@tonic-gate# (and we increment the error count by the return value of it) 14*0Sstevel@tonic-gate# If there's no handle_unknown_option, then we just warn, and then increment 15*0Sstevel@tonic-gate# the error counter 16*0Sstevel@tonic-gate# 17*0Sstevel@tonic-gate# The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors, 18*0Sstevel@tonic-gate# otherwise it's false. 19*0Sstevel@tonic-gate# 20*0Sstevel@tonic-gate## sburke@cpan.org 2002-10-31 21*0Sstevel@tonic-gate 22*0Sstevel@tonic-gateBEGIN { # Make a DEBUG constant ASAP 23*0Sstevel@tonic-gate *DEBUG = defined( &Pod::Perldoc::DEBUG ) 24*0Sstevel@tonic-gate ? \&Pod::Perldoc::DEBUG 25*0Sstevel@tonic-gate : sub(){10}; 26*0Sstevel@tonic-gate} 27*0Sstevel@tonic-gate 28*0Sstevel@tonic-gate 29*0Sstevel@tonic-gatesub getopts { 30*0Sstevel@tonic-gate my($target, $args, $truth) = @_; 31*0Sstevel@tonic-gate 32*0Sstevel@tonic-gate $args ||= \@ARGV; 33*0Sstevel@tonic-gate 34*0Sstevel@tonic-gate $target->aside( 35*0Sstevel@tonic-gate "Starting switch processing. Scanning arguments [@$args]\n" 36*0Sstevel@tonic-gate ) if $target->can('aside'); 37*0Sstevel@tonic-gate 38*0Sstevel@tonic-gate return unless @$args; 39*0Sstevel@tonic-gate 40*0Sstevel@tonic-gate $truth = 1 unless @_ > 2; 41*0Sstevel@tonic-gate 42*0Sstevel@tonic-gate DEBUG > 3 and print " Truth is $truth\n"; 43*0Sstevel@tonic-gate 44*0Sstevel@tonic-gate 45*0Sstevel@tonic-gate my $error_count = 0; 46*0Sstevel@tonic-gate 47*0Sstevel@tonic-gate while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) { 48*0Sstevel@tonic-gate my($first,$rest) = ($1,$2); 49*0Sstevel@tonic-gate if ($_ eq '--') { # early exit if "--" 50*0Sstevel@tonic-gate shift @$args; 51*0Sstevel@tonic-gate last; 52*0Sstevel@tonic-gate } 53*0Sstevel@tonic-gate my $method = "opt_${first}_with"; 54*0Sstevel@tonic-gate if( $target->can($method) ) { # it's argumental 55*0Sstevel@tonic-gate if($rest eq '') { # like -f bar 56*0Sstevel@tonic-gate shift @$args; 57*0Sstevel@tonic-gate warn "Option $first needs a following argument!\n" unless @$args; 58*0Sstevel@tonic-gate $rest = shift @$args; 59*0Sstevel@tonic-gate } else { # like -fbar (== -f bar) 60*0Sstevel@tonic-gate shift @$args; 61*0Sstevel@tonic-gate } 62*0Sstevel@tonic-gate 63*0Sstevel@tonic-gate DEBUG > 3 and print " $method => $rest\n"; 64*0Sstevel@tonic-gate $target->$method( $rest ); 65*0Sstevel@tonic-gate 66*0Sstevel@tonic-gate # Otherwise, it's not argumental... 67*0Sstevel@tonic-gate } else { 68*0Sstevel@tonic-gate 69*0Sstevel@tonic-gate if( $target->can( $method = "opt_$first" ) ) { 70*0Sstevel@tonic-gate DEBUG > 3 and print " $method is true ($truth)\n"; 71*0Sstevel@tonic-gate $target->$method( $truth ); 72*0Sstevel@tonic-gate 73*0Sstevel@tonic-gate # Otherwise it's an unknown option... 74*0Sstevel@tonic-gate 75*0Sstevel@tonic-gate } elsif( $target->can('handle_unknown_option') ) { 76*0Sstevel@tonic-gate DEBUG > 3 77*0Sstevel@tonic-gate and print " calling handle_unknown_option('$first')\n"; 78*0Sstevel@tonic-gate 79*0Sstevel@tonic-gate $error_count += ( 80*0Sstevel@tonic-gate $target->handle_unknown_option( $first ) || 0 81*0Sstevel@tonic-gate ); 82*0Sstevel@tonic-gate 83*0Sstevel@tonic-gate } else { 84*0Sstevel@tonic-gate ++$error_count; 85*0Sstevel@tonic-gate warn "Unknown option: $first\n"; 86*0Sstevel@tonic-gate } 87*0Sstevel@tonic-gate 88*0Sstevel@tonic-gate if($rest eq '') { # like -f 89*0Sstevel@tonic-gate shift @$args 90*0Sstevel@tonic-gate } else { # like -fbar (== -f -bar ) 91*0Sstevel@tonic-gate DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n"; 92*0Sstevel@tonic-gate $args->[0] = "-$rest"; 93*0Sstevel@tonic-gate } 94*0Sstevel@tonic-gate } 95*0Sstevel@tonic-gate } 96*0Sstevel@tonic-gate 97*0Sstevel@tonic-gate 98*0Sstevel@tonic-gate $target->aside( 99*0Sstevel@tonic-gate "Ending switch processing. Args are [@$args] with $error_count errors.\n" 100*0Sstevel@tonic-gate ) if $target->can('aside'); 101*0Sstevel@tonic-gate 102*0Sstevel@tonic-gate $error_count == 0; 103*0Sstevel@tonic-gate} 104*0Sstevel@tonic-gate 105*0Sstevel@tonic-gate1; 106*0Sstevel@tonic-gate 107