Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

why_bird's scratchpad

by why_bird (Pilgrim)
on Mar 07, 2008 at 11:37 UTC ( #672741=scratchpad: print w/ replies, xml ) Need Help??

#! /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;
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (6)
As of 2015-07-08 04:35 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (94 votes), past polls