File Coverage

blib/lib/Getopt/Yagow.pm

Criterion	Covered	Total	%
statement	80	127	62.9
branch	33	44	75.0
condition	8	15	53.3
subroutine	9	17	52.9
pod	9	13	69.2
total	139	216	64.3

package Getopt::Yagow;
# -*-Perl-*-
#
# DESCRIPTION
# Loads and parses command line options. See pod doc.
#
# AUTHOR AND COPYRIGHT
# Enrique Castilla Contreras
# Copyright (C) 2004-2007 Enrique Castilla.
#
#-----------------------------------------------------------------------
# $Id: Yagow.pm,v 1.1 2004/02/10 12:58:02 ecastilla Exp $
#-----------------------------------------------------------------------

use strict;
use vars qw( $VERSION );

$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);

use Getopt::Long;
use Pod::Usage;

# Usage: same as load_options.
#
sub new
{
    my $class = shift;

    my $this = bless {}, $class;
    $this->load_options( @_ );

    return $this;
}

# Usage:
#    $opt = Getopt::Yagow->load_options;  or
#    $opt = Getopt::Yagow->load_options( 'option_spec' => default_value, ...)  or
#    $opt = Getopt::Yagow->load_options( { 'option_spec' => default_value, ... } ) or
#    $opt = Getopt::Yagow->load_options( { ... }, ['pass_through', ... ] );
#
# Sample:
#
#    $p->load_options(
#           'config=s' => '',
#           'srcdir:s' => '',
#           'tardir:s' => '',
#           # 'help' => '',             # Se añade por defecto.
#           'css:s' => 'style.css',
#           'file_icon|f_icon:s' => 'c:\Perl\site\lib\tk\file.xbm',
#           'dir_icon|d_icon:s' => 'c:\Perl\site\lib\tk\folder.xbm'
#    );
#
sub load_options
{
    my $this = shift;

    my( $options_spec, $config);
    if( @_ == 2 && ref $_[0] eq 'HASH' && ref $_[1] eq 'ARRAY' )
    {
        $options_spec = $_[0];
        $config = $_[1];
    }
    elsif( @_ == 1 && ref $_[0] eq 'HASH' )
    {
        $options_spec = $_[0];
    }
    elsif( @_ >= 1 )
    {
        # Hash
        $options_spec = { @_ } if @_ ;
    }

    if( defined $config )
    {
        $this->{configuration} = $config;
        Getopt::Long::Configure( @$config );
    }

    return $this if ! defined $options_spec;

    while( my ($opt_spec,$default) = each %$options_spec )
    {
        $this->add_option( $opt_spec,$default );
    }

    return $this;
}

sub add_option
{
    my ($this, $opt_spec, $default) = @_;

    (my $opt_name = $opt_spec) =~ s/([|=:!+]).*//;
#    croak "Can't add_option '$opt_name', already defined"
#	if exists $this->{$opt_name};

    $this->{options}->{$opt_name} = $opt_spec;

    $this->{default}->{$opt_name} = $default  if defined $default;
    if( ! defined $default )
    {
        $this->{mandatory} = [] if ! exists $this->{mandatory};
        push @{$this->{mandatory}}, $opt_name ;
    }
}

sub usage
{
    my $this = shift;
    my $usage_opts = shift;

    pod2usage( $usage_opts );
}

# Usage:
#   $opt->parse_cmd_line( '--opt1 val1', '--opt2 val2', ... );
#   $opt->parse_cmd_line( ... , '--optx valx',
#                         { -msg=>$msg_help,-verbose=>1 },
#                         { -msg=>$msg_wrong_syntax,-verbose=>0 }  );
#   $opt->parse_cmd_line( ... , '--optx valx',
#                         { -msg=>$msg_help,-verbose=>1 }          );
#   $opt->parse_cmd_line( ... , '--optx valx',
#                         undef,
#                         { -msg=>$msg_wrong_syntax,-verbose=>0 }  );
#
sub parse_cmd_line
{
    my $this = shift;

    my $default_msg = "!! Incorrect syntax. Use --h for help !!.\n";

    my ($i,$arg,$help_usage,$wrong_syntax);

    # Cases:
    # 1.-   ...  , {...}, {...}
    # 3.-   ...  , undef, undef
    # 4.-   ...  , {...}, undef
    # 5.-   ...  , undef, {...}
    # 6.-   ...  , undef
    # 7.-   ...  , {...}
    # 2.-   {...}, {...}
    # 8.-   undef, undef
    # 9.-   undef, {...}
    # 10.-  {...}, undef
    # 11.-  {...}
    # 12.-  undef
    #
    my $hash_no = 1;
    for( $i = 0; $i <  @_; $i++ )
    {
        $arg = $_[$i];
        if( (defined $arg && ref $arg eq 'HASH') || !defined $arg )
        {
            if( $hash_no == 1 )
            {
                $help_usage = $arg if defined $arg;
                $hash_no = 2;
            }

            if( $hash_no == 2 )
            {
                $wrong_syntax = $arg if defined $arg;
                $hash_no = 3;
            }

            splice @_,$i,1;  # Supress $arg from argument list.
            $i--;
        }
    }

    $wrong_syntax = {-msg=>$default_msg,-verbose=>0} if ! defined $wrong_syntax;
    $help_usage =   { -verbose => 1 } if ! defined $help_usage;

    my @args = @_ ? @_ : @ARGV;
    local (@ARGV) = @args;

    #
    # Handle command line parameters
    #
    my @options = values %{ $this->{options} };
    my %used = ();
    unless( GetOptions(\%used, 'help|h|?!', @options))
    {
        $this->usage( $wrong_syntax );
    }

    if( exists $used{help} )
    {
	$this->usage( $help_usage  );
    }

    # If execution reaches this, syntax is correct from the point of view of
    # GetOptions, but we require that options with 'undef' default value be
    # specified in command line.
    #
    foreach my $mandatory_opt ( @{$this->{mandatory}} )
    {
        if( ! exists $used{$mandatory_opt} )
        {
            warn "There is/are mandatory argument(s)";
            $this->usage( $wrong_syntax );
        }
    }
    # Also, options with default values, but used in command line, must be
    # deleted.
    foreach ( keys %{$this->{default}} )
    {
        delete $this->{default}->{$_} if exists $used{$_};
    }
    $this->{used} = \%used;

    # Debug:
    # print "# Getopt::Yagow. \@ARGV: ",join(',',@ARGV),"\n";

    $this->{unhandled_options} = [];
    push @{$this->{unhandled_options}}, @ARGV;

    return $this;
}

sub get_configuration
{
    my $this = shift;

    return ( exists $this->{configuration} ? $this->{configuration} : [] );
}

sub get_options
{
    my $this = shift;

    return $this->{options};
}

sub get_default
{
    my $this = shift;

    return $this->{default};
}

sub get_mandatory
{
    my $this = shift;

    return $this->{mandatory};
}

sub get_used
{
    my $this = shift;

    return $this->{used};
}

sub get_unhandled
{
    my $this = shift;

    return $this->{unhandled_options};
}

sub get_options_values
{
    my $this = shift;

    return { %{$this->{default}}, %{$this->{used}} };
}

sub DEBUG
{
    my $this = shift;

    print STDERR "configuration:\n";
    foreach my $key ( @{$this->{configuration}} )
    {
        print STDERR "$key\n";
    }
    print STDERR "\n";

    print STDERR "options:\n";
    while( my($key,$val) = each %{$this->{options}} )
    {
        print STDERR "$key => $val\n";
    }
    print STDERR "\n";

    print STDERR "default:\n";
    while( my($key,$val) = each %{$this->{default}} )
    {
        print STDERR "$key => $val\n";
    }
    print STDERR "\n";

    print STDERR "mandatory:\n";
    foreach my $key ( @{$this->{mandatory}} )
    {
        print STDERR "$key\n";
    }
    print STDERR "\n";

    print STDERR "used:\n";
    while( my($key,$val) = each %{$this->{used}} )
    {
        print STDERR "$key => $val\n";
    }
    print STDERR "\n";

    print STDERR "unhandled:\n";
    foreach my $key ( @{$this->{unhandled_options}} )
    {
        print STDERR "$key\n";
    }
    print STDERR "\n";

}

__END__