File Coverage

blib/lib/Getopt/Fancy.pm

Criterion	Covered	Total	%
statement	9	149	6.0
branch	0	68	0.0
condition	0	21	0.0
subroutine	3	12	25.0
pod	6	9	66.6
total	18	259	6.9

package Getopt::Fancy;

use strict;
use Getopt::Long;

use vars qw($VERSION);

$VERSION = "0.06";

# GT      = GetOptions spefication (=i, :s, etc)
# EX      = Example arg
# DESC    = Description of arg
# DEF     = Default value
# REQ     = Required arg
# ALLOWED = List of allowed values
# COMMAS  = Allow comma separated values for multi valued guys
# SECTION = The section the arg belongs under (when printing usage)
# REGEX   = regex that the arg has to match

Getopt::Long::Configure ("no_ignore_case");

our %config;
our %intvars;

sub new
{
  my $type = shift;
  my $class = ref($type) || $type;
  my $self = bless {}, $class;
  $intvars{$self}->{maxexlen} = 0;
  $intvars{$self}->{maxoptlen} = 0;
  return $self;
}

sub add
{
  my $self = shift;
  my $key = shift;
  my %values = @_;
  my ($aref, $val);
  my $use_yiv = 1;

  return unless $key;
  $intvars{$self}->{maxoptlen} = length ($key) if (length($key) > $intvars{$self}->{maxoptlen});
  $intvars{$self}->{maxexlen} = length ($values{EX}) if ($values{EX} && length($values{EX}) > $intvars{$self}->{maxexlen});
  if ($values{YIV}) {
    if (! ref $values{YIV}) {
      $aref = [$values{YIV}];
    } else {
      $aref = $values{YIV};
    }
    foreach $val (@{$aref}) {
      if (length($val) == 0 || $val =~ m/\$\(.*?\)/o) {
        $use_yiv = 0;
        last;
      }
    }
    $values{DEF} = $values{YIV} if $use_yiv;
  }
  $config{$self}->{$key} = \%values;
}

sub get_values
{
  my $self = shift;
  my ($key, $result, $values);
  my $spaces = " " x ($intvars{$self}->{maxoptlen} + 5);
  my $maxoptlen = $intvars{$self}->{maxoptlen};

  foreach $key (keys %{$self}) {
    if (! ref $self->{$key}) {
      $values = [$self->{$key}];
    } else {
      $values = $self->{$key};
    }
    $result .= sprintf (" %-${maxoptlen}s => %s", $key, join("\n$spaces", @{$values}));
    $result .= "\n";
  }
  return $result;
}

sub get_error
{
  my $self = shift;
  return $intvars{$self}->{error_msg};
}

sub get_options
{
  my $self = shift;
  my ($key, $values, $value);

  # Set the =i, =s stuff
  my @gopts = map {$_ .= $config{$self}->{$_}->{GT};} keys %{$config{$self}};

  # Get the options
  if (!GetOptions($self, @gopts)) {
    $intvars{$self}->{error_msg} = "Invalid option.\n";
    return ($intvars{$self}->{error_msg});
  }

  # Set the default values
  foreach $key (keys %{$config{$self}}) {
    next unless (defined $config{$self}->{$key}->{DEF});
    next if (defined $self->{$key});
    if ($config{$self}->{$key}->{GT} &&
        index($config{$self}->{$key}->{GT}, "@") > 0 &&
        !ref $config{$self}->{$key}->{DEF}) {
      $self->{$key} = [$config{$self}->{$key}->{DEF}];
    } else {
      $self->{$key} = $config{$self}->{$key}->{DEF};
    }
  }

  # Expand any comma separated lists
  foreach $key (keys %{$config{$self}}) {
    next unless ($config{$self}->{$key}->{GT} && index($config{$self}->{$key}->{GT}, "@") > 0);
    next unless ($config{$self}->{$key}->{COMMAS});
    next unless (defined $self->{$key});
    $values = $self->{$key};
    $self->{$key} = [];
    foreach $value (@{$values}) {
      push @{$self->{$key}}, split(/\s*,\s*/, $value);
    }
  }


  # Check for required values
  foreach $key (keys %{$config{$self}}) {
    $intvars{$self}->{error_msg} .= "$key is required, but missing\n" if ($config{$self}->{$key}->{REQ} && ! defined $self->{$key});
  }

  # Check for REGEX conformity
  foreach $key (keys %{$config{$self}}) {
    next unless defined ($config{$self}->{$key}->{REGEX});
    next unless defined ($self->{$key});
    if (! ref $self->{$key}) {
      $values = [$self->{$key}];
    } else {
      $values = $self->{$key};
    }
    foreach $value (@{$values}) {
      $intvars{$self}->{error_msg} .= "$value not a valid value for $key. Does not match regex: ".$config{$self}->{$key}->{REGEX}."\n" if ($value !~ m/$config{$self}->{$key}->{REGEX}/);
    }
  }

  # Check for allowed values
  foreach $key (keys %{$config{$self}}) {
    next unless defined ($config{$self}->{$key}->{ALLOWED});
    next unless defined ($self->{$key});
    my $allowed;
    my %a;
    if (! ref $config{$self}->{$key}->{ALLOWED}) {
      $allowed = [$config{$self}->{$key}->{ALLOWED}];
    } else {
      $allowed = $config{$self}->{$key}->{ALLOWED};
    }
    map {$a{$_} = 1;} @{$allowed};

    if (! ref $self->{$key}) {
      $values = [$self->{$key}];
    } else {
      $values = $self->{$key};
    }
    foreach $value (@{$values}) {
      $intvars{$self}->{error_msg} .= "$value not a valid value for $key. Allowed values: " . join(", ", @{$allowed}) . "\n" unless ($a{$value});
    }
  }
  return $intvars{$self}->{error_msg};
}

sub check_for
{
  my $self = shift;
  my $key = shift;
  my $value = shift;
  my $item;

  foreach $item (keys %{$config{$self}}) {
    return 1 if ($config{$self}->{$item}->{$key} == $value);
  }
  return 0;
}

sub have_required
{
  my $self = shift;
  return $self->check_for("REQ", 1);
}

sub have_optional
{
  my $self = shift;
  return $self->check_for("REQ", 0);
}


sub get_usage
{
  my $self = shift;
  my $options = shift;
#  my $req_only = shift;
  my $spaces = " " x ($intvars{$self}->{maxexlen} + $intvars{$self}->{maxoptlen} + 7);
  my $maxexlen = $intvars{$self}->{maxexlen};
  my $maxoptlen = $intvars{$self}->{maxoptlen};
  my ($result, $key, $defs, @keys);
  my $section = "";

  if (defined $options) {
    @keys = @{$options};
  } else {
    @keys = sort { $config{$self}->{$a}->{SECTION} cmp $config{$self}->{$b}->{SECTION} or $a cmp $b} keys %{$config{$self}};
  }

  foreach $key (@keys) {
    my $req = "";
#    if (defined $req_only) {
#      next if ($req_only && !$config{$self}->{$key}->{REQ});
#      next if (!$req_only && $config{$self}->{$key}->{REQ});
#    }
    if (! ref $config{$self}->{$key}->{DEF}) {
      $defs = [$config{$self}->{$key}->{DEF}];
    } else {
      $defs = $config{$self}->{$key}->{DEF};
    }
    if ($section ne $config{$self}->{$key}->{SECTION}) {
      $section = $config{$self}->{$key}->{SECTION};
      $result .= "\n [${section}]:\n";
    }

    $req = "[REQ] " if $config{$self}->{$key}->{REQ};
    $config{$self}->{$key}->{DESC} =~ s/\n/\n$spaces/og if $config{$self}->{$key}->{DESC};
    $result .= sprintf "  -%-${maxoptlen}s %-${maxexlen}s : ${req}%s", $key, $config{$self}->{$key}->{EX}, $config{$self}->{$key}->{DESC};
    $result .= "\n${spaces}Default = " . join(", ", @{$defs}) if $config{$self}->{$key}->{DEF};
    $result .= "\n${spaces}Allowed = " . join(", ", @{$config{$self}->{$key}->{ALLOWED}}) if $config{$self}->{$key}->{ALLOWED};
    $result .= "\n";
  }
  return $result;
}

1;

__END__