A first attempt.. at OO perl

Hi Monks,
I've finally got round to trying some OO stuff. I realise this is not groundbreaking stuff, but I thought I'd implement a 'getopt' module as an exercise.

It works (for me) reasonably so far, though it definitely needs some tweaking. I have a few questions though:

I have very little experience coding for Windows, or even other *nixes. What things do you have to change/do to make code portable?
How does one go about making a CPAN style module out of code like this? (Obviously I'd have to write something useful first, not the 101th 'getopt' variant :P) The modules on CPAN mostly seem to have loads of files in their tarballs, and you have to run make, make install etc. Is this to do with 1.?
Have I got the right idea for OO code? What conventions have I missed? What dangerous/rubbish/useless things have I done?! I'm looking for both specific criticism on this code as well as general advice. The only real guideline I've followed is to not mess with the object directly and use methods whenever possible. Other than that I just followed my instinct..
What would be your suggestion for a good next step for me into the OO world? Some kind of project, slightly more difficult than this would be good. I'm from a mathsy-sciencey background but don't have a whole lot of experience with programming or web stuff though I'm willing to learn.

I really am a bit clueless about all this, but I'd appreciate any help people could give..

Thanks,
why_bird

#! /usr/bin/perl

#TODO: in parse, check whether str, num and int options have acutally 
+been given a value and warn if not.
#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 policy

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;
[download]

........
Those are my principles. If you don't like them I have others.
-- Groucho Marx
.......

Back to Meditations