require 5; package Pod::Perldoc::GetOptsOO; use strict; # Rather like Getopt::Std's getopts # Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth) # Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT ) # (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo") # Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth) # (Truth defaults to 1) # Otherwise we try calling $object->handle_unknown_option('n') # (and we increment the error count by the return value of it) # If there's no handle_unknown_option, then we just warn, and then increment # the error counter # # The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors, # otherwise it's false. # ## sburke@cpan.org 2002-10-31 BEGIN { # Make a DEBUG constant ASAP *DEBUG = defined( &Pod::Perldoc::DEBUG ) ? \&Pod::Perldoc::DEBUG : sub(){10}; } sub getopts { my($target, $args, $truth) = @_; $args ||= \@ARGV; $target->aside( "Starting switch processing. Scanning arguments [@$args]\n" ) if $target->can('aside'); return unless @$args; $truth = 1 unless @_ > 2; DEBUG > 3 and print " Truth is $truth\n"; my $error_count = 0; while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) { my($first,$rest) = ($1,$2); if ($_ eq '--') { # early exit if "--" shift @$args; last; } my $method = "opt_${first}_with"; if( $target->can($method) ) { # it's argumental if($rest eq '') { # like -f bar shift @$args; warn "Option $first needs a following argument!\n" unless @$args; $rest = shift @$args; } else { # like -fbar (== -f bar) shift @$args; } DEBUG > 3 and print " $method => $rest\n"; $target->$method( $rest ); # Otherwise, it's not argumental... } else { if( $target->can( $method = "opt_$first" ) ) { DEBUG > 3 and print " $method is true ($truth)\n"; $target->$method( $truth ); # Otherwise it's an unknown option... } elsif( $target->can('handle_unknown_option') ) { DEBUG > 3 and print " calling handle_unknown_option('$first')\n"; $error_count += ( $target->handle_unknown_option( $first ) || 0 ); } else { ++$error_count; warn "Unknown option: $first\n"; } if($rest eq '') { # like -f shift @$args } else { # like -fbar (== -f -bar ) DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n"; $args->[0] = "-$rest"; } } } $target->aside( "Ending switch processing. Args are [@$args] with $error_count errors.\n" ) if $target->can('aside'); $error_count == 0; } 1; __END__ =head1 NAME Pod::Perldoc::GetOptsOO - Customized option parser for Pod::Perldoc =head1 SYNOPSIS use Pod::Perldoc::GetOptsOO (); Pod::Perldoc::GetOptsOO::getopts( $obj, \@args, $truth ) or die "wrong usage"; =head1 DESCRIPTION Implements a customized option parser used for L. =head1 SEE ALSO Pod::Perldoc =head1 COPYRIGHT AND DISCLAIMERS Copyright (c) 2002-2007 Sean M. Burke. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. This program is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. =head1 AUTHOR Current maintainer: Adriano R. Ferreira Past contributions from: Sean M. Burke =cut