Options - Yet another Perl module to provide support for command-line option parsing and usage generation.

    use Options;

    $options = new Options(params => [
                                ['port',   'p', undef,       'The port to connect to.'],
                                ['host',   'h', 'localhost', 'The host to connect to.']
                           ],
                           flags =>  [
                                ['secure', 's', 'Use SSL for encryption.'],
                                ['quit',   'q', 'Quit after connecting.'],
                                ['help',   'h', 'Display this usage guide.'],
                           ]);

    # Parse the default option source (@ARGV)
    %results = $options->get_options();

    # Provide usage
    if($options->get_result('help')){
        $options->print_usage();
        exit(1);
    }

 Options 1.5.2

    $options->{'exit'} = 0;

    $options->{'error_handler'} = sub {
        # the Options instance
        $self = shift;

        # what caused the error
        $error_msg = shift;

        # Do whatever you need to do here, possibly
        # including calling print_usage()

        # Returning true would ignore all errors, and attempt
        # to parse as much as possible, whereas false will
        # exit immediately with an error code of 1
        return 0;
    };

	open(STRINGIO, '+>', \$usage_text) or die $!;
	$options->{'usage_fh'} = \*STRINGIO;
	...
	...
	...
	$options->get_options();
	@usage_lines = <$options->{'usage_fh'}>;

	# don't forget to close the handle
	close($options->{'usage_fh'});

#!/usr/bin/env perl

##################################################################
# Options.pm 1.5.2
# 
# Copyright (C) 2005-2007 by Phil Christensen
##################################################################

package Options;

use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
	
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	
);

our $VERSION = '1.5.2';

sub new{
	my $self = {};
	my $class = shift;
	bless $self, $class;
	my %passed_params = @_;
	if($passed_params{'params'}){
		$self->{'params'} = $passed_params{'params'};
	}
	else{
		$self->{'params'} = [];
	}
	
	if($passed_params{'flags'}){
		$self->{'flags'} = $passed_params{'flags'};
	}
	else{
		$self->{'flags'} = [];
	}
	$self->{'exit'} = 1;
	return $self;
}

sub get_options{
	my $self = shift;
	
	my @args = @_;
	unless(@args){
		@args = @ARGV;
	}
	
	my @unrecognized = ();
	my %results = ();
	
	for(my $i = 0; $i <= $#args; $i++){
		my $item = $args[$i];
		if($item =~ m/^(\-{1,2})(.*)$/){
			my $item_text = $2;
			my $result;
			if($1 eq '--'){
				$result = $self->_is_supported_option($item_text, 1);
			}
			elsif(length($item_text) == 1){
				$result = $self->_is_supported_option($item_text, 0);
			}
			else{
				no warnings;
				my @flags = split(undef, $item_text);
				use warnings;
				
				foreach my $flag (@flags){
					$result = $self->_is_supported_option($flag, 0);
					# if this is a valid flag, it can be grouped
					if($result){
						if(scalar(@{$result->[1]}) == 3){
							push @args, "-$flag";
						}
						else{
							my $param = $result->[1][1];
							$self->_found_error("Parameter '$param' found in grouped flags '-$item_text'.");
						}
					}
					else{
						$self->_found_error("'$flag' is not a supported flag.");
					}
				}
				next;
			}
			if($result){
				my $type = $result->[0];
				my @option = @{$result->[1]};
				if($type eq 'params'){
					if($args[$i + 1] and $args[$i + 1] !~ m/^\-{1,2}(.*)/){
						my $current = $results{$option[0]};
						my $arg = $args[++$i];
						if($current){
							if(ref($current) eq 'ARRAY'){
								my @list = @$current;
								push(@list, $arg);
								$results{$option[0]} = \@list;
							}
							elsif(ref($current) eq ''){
								$results{$option[0]} = [$current, $arg];
							}
						}
						else{
							$results{$option[0]} = $arg;
						}
					}
					else{
						$self->_found_error("Missing argument for '$option[0]' parameter.");
					}
				}
				else{
					$results{$option[0]} = 1;
				}
			}
			else{
				push(@unrecognized, $item);
			}
		}
		else{
			push(@unrecognized, $item);
		}
	}
	
	#then check and see if any required params were missing, and fill in defaults
	foreach my $item (@{$self->{'params'}}){
		my @option = @{$item};
		unless($results{$option[0]}){
			if(defined($option[2])){
				$results{$option[0]} = $option[2];
			}
		}
		unless(defined($option[2])){
			unless($results{$option[0]}){
				$self->_found_error("Missing required option '$option[0]'");
			}
		}
	}
	
	unless(@_){
		@ARGV = @unrecognized;
	}
	
	$self->{'unrecognized'} = @unrecognized;
	$self->{'results'} = \%results;
	return %results;
}

sub get_result{
	my $self = shift;
	my $option = shift;
	my %results = %{$self->{'results'}};
	my $result = $results{$option};
	if(ref($result) eq 'ARRAY'){
		my @result = @$result;
		return @result;
	}
	else{
		return (wantarray ? ($result) : $result);
	}
}

sub print_usage{
	my $self = shift;
	my $reason = shift;
	unless(defined($reason)){
		$reason = '';
	}
	
	my $usage_fh;
	if($self->{'usage_fh'}){
		$usage_fh = $self->{'usage_fh'};
	}
	else{
		$usage_fh = \*STDERR;
	}
	
	my $app = $self->{'last_args'}[0];
	unless(defined($app)){
		$app = $0;
	}
	
	print $usage_fh "$reason\n\n";
	print $usage_fh "Usage: $app [options]\n";
	print $usage_fh "Options:\n";
	
	my $item;
	my @rows = ();
	my $max_width = 0;
	
	my $flags = $self->{'flags'};
	foreach $item (@$flags){
		my @parts = @$item;
		my $first_col = "  -$parts[1], --$parts[0]";
		if(length($first_col) > $max_width){
			$max_width = length($first_col);
		}
		my $row = [$first_col, $parts[2]];
		push(@rows, $row);
	}
	
	my $params = $self->{'params'};
	foreach $item (@$params){
		my @parts = @$item;
		my $first_col = "  -$parts[1], --$parts[0]";
		if(length($first_col) > $max_width){
			$max_width = length($first_col);
		}
		my $default = (defined($parts[2]) && $parts[2] ne '' ? "[default: $parts[2]]" : "");
		my $required = (defined($parts[2]) ? "" : "[required]");
		my $row = [$first_col, "$parts[3] $default   $required"];
		push(@rows, $row);
	}
	
	foreach $item (@rows){
		my @row = @$item;
		print $usage_fh _pad($row[0], $max_width + 2), $row[1], "\n";
	}
}

# A private internal function that checks to see if a specified
# option will be sought on the command line (i.e., whether this
# instance was constructed with a given option)
sub _is_supported_option{
	my $self = shift;
	my $option = shift;
	my $is_long = shift;
	foreach my $key('params', 'flags'){
		my $options = $self->{$key};
		foreach my $item (@$options){
			my @parts = @$item;
			if($is_long){
				if($parts[0] eq $option){
					return [$key, $item];
				}
			}
			else{
				no warnings;
				my @letters = split(undef, $option);
				use warnings;
				foreach my $letter (@letters){
					if($parts[1] eq $letter){
						return [$key, $item];
					}
				}
			}
		}
	}
	return 0;
}


#
# A private internal function to assist in making the
# usage guide come out all pretty-looking.
#
sub _pad{
	my $text = shift;
	my $length = shift;
	if($length > length($text)){
		return $text . (" " x ($length - length($text)));
	}
	return $text;
}

sub _found_error{
	my $self = shift;
	my $reason = shift;
	
	my $error_handler = $self->{'error_handler'};
	my $result;
	if(defined($error_handler)){
		$result = $error_handler->($self, $reason);
	}
	else{
		$self->print_usage($reason);
		$result = 0;
	}
	
	unless($result){
		if($self->{'exit'}){
			exit(1);
		}
		die($reason);
	}
}

1;