#! /usr/bin/perl
#TODO: in parse, check whether str, num and int options have acutally
+been given a value and warn if not.
#TODO: implement get_type
#todo: check no. of args passed to each function
#TODO: reimplement warnings and dies so that they're optionally fatal
#TODO: mutually exclusive options?
#TODO: - and -- not enforced in parse (or anywhere else). need a consi
+stent approach
package getopt_dev;
use strict;
use warnings;
use Carp;
use Data::Dumper;
my $debug=0;
if($debug==1){
$Carp::Verbose=1;
}
# constructor
sub new
{
my $self = [{},""];
bless($self);
return $self;
}
# create new valid options
sub add_option
{
check_args(4,@_);
my $class=shift;
my $self=shift;
my $name=shift;
my $type=shift;
my @types=qw(str bool int num);
my @found=();
my %opt;
$name=~s/^--?//;
@found=grep(/^$type$/, @types);
croak "$type not a valid type" if ($#found == -1);
$opt{ "opt_name" }=$name;
$opt{ "desc" }="";
$opt{ "opt_type" }=$type;
$opt{ "long or short" }=(length($opt{ "opt_name" })==1)?("short"):
+("long");
$opt{ "value" }={
"str" => "",
"bool" => 0,
"int" => "",
"num" => "",
};
$opt{ "valid" } = 1;
print Dumper( $self->[0], ${$self->[0]}{ "d" }->{ "desc" });
${$self->[0]}{ $name }=\%opt;
print Dumper @$self if($debug==1);
return keys (%{$self->[0]});
}
sub make_options_available
{
check_args(4,@_);
my $class=shift;
my $self=shift;
my $opt_available=shift;
my $type_available=shift;
my $num_opt;
croak "available option and available type arrays need to match up
+!" if ($#$opt_available != $#$type_available);
for(my $i=0;defined $opt_available->[$i];$i++){
my $opt= $opt_available->[$i];
my $type= $type_available->[$i];
$num_opt=getopt_dev->add_option($self,$opt,$type);
}
}
# print options
sub print_usage
{
check_args(2,@_);
my $class=shift;
my $self=shift;
my $i=0;
my $prefix;
print "\nUsage: ".$self->[1]."\n\n";
print "Options:\n";
for($i=0;$i<2;$i++){
foreach my $opt (sort(keys %{$self->[0]})){
next if(getopt_dev->is_option($self,$opt) == 0);
$prefix=(${$self->[0]}{ $opt }->{ "long or short" } eq "sh
+ort")?("-"):("--");
next if ($prefix eq "--" && $i==0);
next if ($prefix eq "-" && $i==1);
print $prefix.$opt."\t";
print ${$self->[0]}{ $opt }->{ "desc" }."\n";
}
}
}
sub print_options
{
check_args(2,@_);
my $class=shift;
my $self=shift;
my $value;
my $i=0;
print "\nOptions currently set:\n\n";
for($i=0;$i<2;$i++){
foreach my $opt (sort(keys %{$self->[0]})){
next if(getopt_dev->is_option($self,$opt) == 0);
$value=getopt_dev->get_option($self,$opt);
next if(! defined $value );
my $prefix=(${$self->[0]}{ $opt }->{ "long or short" } eq
+"short")?("-"):("--");
next if ($prefix eq "--" && $i==0);
next if ($prefix eq "-" && $i==1);
print $prefix.$opt."\t";
print $value."\n";
}
}
}
# parse and set options
sub parse_options
{
my $class=shift;
my $self=shift;
my @temp=@_;
my @args;
my $found=0;
my $last_found;
my $last_arg="";
my @left_args;
if(ref($temp[0]) eq "ARRAY"){
@args=@{$temp[0]};
}
elsif(ref($temp[0]) eq ''){
@args=@temp;
}
else{
croak "@ARGV must be passed to function parse_options";
}
#what about combining short options into 1??
foreach my $arg (@args){
$last_found=$found;
$found=getopt_dev->is_option($self,$arg);
$found=0 if $arg !~ /^--?/;
if($last_found==0 && $found==0){ #previous value wasn't an opt
+ion, and neither is this one
push @left_args, $arg;
}
elsif($last_found== 1 && $found==0 && getopt_dev->get_type($se
+lf,$last_arg) eq "bool"){ #previous value was and 'on or off' flag, a
+nd this is not an option
push @left_args, $arg;
}
elsif( $last_found==1 && $found==0 ){ #previous value was an o
+ption, try to set the value of this option
getopt_dev->set_option($self,$last_arg,$arg);
}
if($found==1 && getopt_dev->get_type($self,$arg) eq "bool"){
getopt_dev->set_option($self,$arg,1);
}
$last_arg=$arg;
}
return (\@left_args);
}
sub set_option
{
check_args(4,@_);
my $class=shift;
my $self=shift;
my $opt_name=shift;
my $value=shift;
my $found=getopt_dev->is_option($self,$opt_name);
croak "$opt_name is not a valid option" if($found==0);
$opt_name=~s/^--?//;
my $type=getopt_dev->get_type($self,$opt_name);
if ($type eq "bool"){
${$self->[0]}{ $opt_name }->{ "value" }->{ "bool" }=1;
}
elsif ($type eq "int"){
croak "Integer required for option $opt_name. Value $value is
+not an integer.\n" if (getopt_dev->is_int($value)==0);
${$self->[0]}{ $opt_name }->{ "value" }->{ "int" }=$value;
}
elsif ($type eq "num"){
croak "Number required for option $opt_name. Value $value is n
+ot a number.\n" if (getopt_dev->is_number($value)==0);
${$self->[0]}{ $opt_name }->{ "value" }->{ "num" }=$value;
}
elsif ($type eq "str"){
${$self->[0]}{ $opt_name }->{ "value" }->{ "str" }=$value;
}
else{
carp "Type $type not recognised. Treating option as though it
+were a string option";
${$self->[0]}{ $opt_name }->{ "value" }->{ "str" }=$value;
}
}
sub set_desc
{
check_args(4,@_);
my $class=shift;
my $self=shift;
my $opt_name=shift;
my $desc=shift;
my $found=-1;
my $i;
$opt_name=~s/^--?//;
$found=getopt_dev->is_option($self,$opt_name);
my $prefix=length($opt_name)==1?("-"):("--");
if ($found == 0){
croak "$prefix$opt_name not a valid option";
}
else{
${$self->[0]}{ $opt_name }->{ "desc" }=$desc;
if($debug==1){
print "Description of $prefix$opt_name set to:\n\t";
print $desc."\n";
}
}
}
sub set_usage
{
check_args(3,@_);
my $class=shift;
my $self=shift;
my $usage=shift;
$self->[1]=$usage;
}
# get option values
sub get_option
{
check_args(3,@_);
my $class=shift;
my $self=shift;
my $opt_name=shift;
my $value=0;
my $type;
$opt_name=~s/^--?//;
$type=getopt_dev->get_type($self,$opt_name);
if ($type eq "bool"){
$value=(${$self->[0]}{ $opt_name }->{ "value" }->{ "bool" }==1
+)?(1):(undef);
}
elsif ($type eq "int"){
$value=(${$self->[0]}{ $opt_name }->{ "value" }->{ "int" }eq""
+)?(undef):(${$self->[0]}{ $opt_name }->{ "value" }->{ "int" });
}
elsif ($type eq "num"){
$value=(${$self->[0]}{ $opt_name }->{ "value" }->{ "num" }eq""
+)?(undef):(${$self->[0]}{ $opt_name }->{ "value" }->{ "num" });
}
elsif ($type eq "str"){
$value=(${$self->[0]}{ $opt_name }->{ "value" }->{ "str" }eq""
+)?(undef):(${$self->[0]}{ $opt_name }->{ "value" }->{ "str" });
}
else{
carp "Type $type not recognised. Treating option as though it
+were a string option";
$value=(${$self->[0]}{ $opt_name }->{ "value" }->{ "str" }eq""
+)?(undef):(${$self->[0]}{ $opt_name }->{ "value" }->{ "str" });
}
return $value;
}
sub get_type
{
check_args(3,@_);
my $class=shift;
my $self=shift;
my $opt_name=shift;
my $found=0;
my $type="";
$opt_name=~s/^--?//;
$found=getopt_dev->is_option($self, $opt_name);
croak "$opt_name not a valid option\n" if($found==0);
$type=${$self->[0]}{ $opt_name }->{ "opt_type" };
return $type;
}
#checking properties of options
sub is_option
{
check_args(3,@_);
my $class=shift;
my $self=shift;
my $opt_name=shift;
my $found=-1;
$opt_name=~s/^--?//;
if(exists ${$self->[0]}{ $opt_name } &&
${$self->[0]}{ $opt_name }->{ "valid" }==1){
return 1;
}
return 0;
}
sub is_number
{
check_args(2,@_);
my $class=shift;
my $value=shift;
if ($value !~ /^\-?\d+(?:\.\d+)?(?:[Ee][+-]?\d{1,3})?$/){
return 0;
} else {
return 1;
}
}
sub is_int
{
check_args(2,@_);
my $class=shift;
my $value=shift;
if(getopt_dev->is_number($value)==0){
return 0;
}
elsif (int($value) == $value){
return 1;
}
else{
return 0;
}
return 0;
}
# debug
sub check_args
{
my $number=shift;
croak "Wrong number of arguments to method" if $#_ != ($number
+-1);
}
1;
|