Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

why_bird's scratchpad

by why_bird (Pilgrim)
on Mar 07, 2008 at 11:37 UTC ( [id://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
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others perusing the Monastery: (4)
As of 2024-03-29 11:08 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found