Unnamed

# (C) Bryan Steimel 2007 and beyond

package SvD::GetOpt; 


use strict;
use warnings; 

use Carp qw(croak); 
use Exporter qw(import); 

our %EXPORT_TAGS = ( 
  constants => [ grep {/^(?:OPT_|ARG_)/} %::SvD::GetOpt:: ], 
  subs 		=>	[ qw(fsit) ] 
); 
my %exists; 
$EXPORT_TAGS{all} = [ grep {!$exists{$_}++} map {@$_} values %EXPORT_TAGS ]; 
undef %exists; 

our @EXPORT_OK = @{$EXPORT_TAGS{all}};

use constant { 
  true	=> 1, 
  false	=> 0
};

use constant { 
  OPT_OPTIONAL		=> 0x0001,
  OPT_MANDATORY		=> 0x0002,
  ARG_NONE			=> 0x0004,
  ARG_STR			=> 0x0008, 
  ARG_FLOAT			=> 0x0010,
  ARG_BOOL			=> 0x0020,
  ARG_NOTNULL		=> 0x0040,
  ARG_INT			=> 0x0080
   
};

use constant { 
  BITS_SHORTN => 0, 
  BITS_FLAGS  => 1,
  BITS_REGEX  => 2,
  BITS_DEFAULT => 3
}; 

our $REG = { 
  ARG_STR,	 	qr//,
  ARG_INT,	 	qr/^\d+$/, 
  ARG_FLOAT, 	qr/^\d+(?:\.\d+)?$/,  
  ARG_BOOL,     qr/^[01]$/,
  ARG_NOTNULL,	qr/.+/
}; 


our $OPT = {}; 

AUTOLOAD { 
  no strict 'refs';
  our $AUTOLOAD;
  my($sub) = $AUTOLOAD =~ /.*::(.*)/;
  $sub =~ y/A-Z/a-z/;
  exists $OPT->{$sub}
    or croak "Call to undefined subroutine &$AUTOLOAD";
  *$AUTOLOAD = sub { 
    return $_[0]->{ARGV}->{$sub} 
	  unless defined $_[1]; 
	$_[0]->{ARGV}->{$sub} = $_[1]
  };
  &$AUTOLOAD 
  
}



sub fsit { # thats, FORK STUCK IN TOASTER
  my($script) = $0 =~ m#.*[\\/](.*)#i; 
 print "\n"; 
  print '-' . "  " . $script . ': ' . $_ . "\n" 
    for(@_); 
  exit(1); 
} 


sub grab { 
  my $Class = ref $_[0] ? ref shift : shift; 
  my %args = @_; 
  defined($OPT = delete $args{Rules}) 
    && ref $OPT eq 'HASH' 
	  or croak 'Required argument MAP was not supplied'; 
  my $Self = bless { 
    Rules				=> $OPT, 
	Format				=> ((ref $args{Format} eq 'ARRAY' && @{$args{Format}} && delete $args{Format}) 
	                         or croak sprintf "%s->new(FORMAT, must be array reference, and not empty.", __PACKAGE__), 
	ALLOW_SHORT_OPTS	=> (scalar grep {defined $_ && $_ ne ''} map {ref $OPT->{$_}->[0] ? @{$OPT->{$_}->[0]} : $OPT->{$_}->[0]} keys %$OPT) ? true : false,
	ARGV				=> {}
  }, $Class;
  $Self->{DASH_OPT_LEN} = $Self->{ALLOW_SHORT_OPTS} ?  '1,2' : 2;
  $OPT->{$_}->[BITS_FLAGS] & OPT_MANDATORY 
    && defined $OPT->{$_}->[BITS_DEFAULT]
	  && croak 'Arguments marked as *MANDATORY* cannot be assigned a default value'
	    foreach(keys %$OPT); 
  $Self->parse;
  $Self
} 



sub parse($) { 
  my $Self = shift; 
  my($format, $argv) = ($Self->{Format}, {}); 
  argv:while(defined(local $_ = shift @ARGV)) { 
	if(s/\-{$Self->{DASH_OPT_LEN}}//) { 
      y/A-Z/a-z/;
	  my $key = $_;
	  ($key) = (exists $OPT->{$_} ? $_ : grep {grep {defined $_ && $key eq $_} ref $OPT->{$_}->[0] ? @{$OPT->{$_}->[0]} : $OPT->{$_}->[0]} keys %$OPT) 
	    or fsit 'Unknown argument: ' . $& . $_;
      my $parm = shift @ARGV 
        unless SvD::GetOpt::isarg($ARGV[0]) || $OPT->{$key}->[BITS_FLAGS] & ARG_NONE;
      fsit 'Bad data supplied for argument "' . $_ . '"'
	    unless $Self->checkparm($key, $parm);
	  $Self->{ARGV}->{$key} = $parm || $OPT->{$key}->[BITS_DEFAULT];
	  @$format = grep {$key ne $_} @$format
	} else { 
	  scalar @$format 
	    or fsit 'What am I intended to do with "' . $_ . '"?'; 
	  fsit 'Bad data supplied for argument "' .$format->[0] . '"'
        unless $Self->checkparm($format->[0], $_);
      $Self->{ARGV}->{(shift @$format)} = $_ || $OPT->{$_}->[BITS_DEFAULT]  # this should never happen 
	}
  }
  defined $Self->{ARGV}->{$_} or ($Self->{ARGV}->{$_} = $OPT->{$_}->[BITS_DEFAULT] || undef)
    foreach(@$format); # set any [leftover] defaults before checking for null.. 
  (defined $Self->{ARGV}->{$_}
    && $Self->{ARGV}->{$_} ne '') 
	  || ($OPT->{$_}->[BITS_FLAGS] & ARG_NOTNULL 
	      && fsit 'Required argument "' . $_ . '", was not supplied.')
	        for(grep {$OPT->{$_}->[BITS_FLAGS] & OPT_MANDATORY} keys %$OPT); 
  print $_ . ' => ' . (defined $Self->{ARGV}->{$_} ? $Self->{ARGV}->{$_} : '(undefined)') . "\n" foreach(keys %{ $Self->{ARGV} }); 
} 


sub isarg {
   defined $_[1] 
     && ($_[1] =~ /\-{$_[0]->{DASH_OPT_LEN}}/ 
	   ? true
	     : false
     ) || undef;
} 


sub checkparm {  
  my($Self, $bit, $data, $ok) = (@_[0..2], true); 
  exists $Self->{Rules}->{$bit}
    or fsit 'Unknown argument "'  . $bit . '"';
  my $rules = $Self->{Rules}->{$bit};   
  ($rules->[BITS_FLAGS] & $_)
    && ($ok = ($data =~ /$REG->{$_}/) 
	    ? true 
	  : false
	) for(keys %$REG);
  $ok = ($data =~ /$rules->[BITS_REGEX]/)
    if defined $rules->[BITS_REGEX];
  $ok
}


true

__END__