Re: Re: OO - problem with inheritance

Hello dmmiller2k,
you are absolutely right! This is what I wanted. And with the help of IlyaM and frag I started coding my own ParamConfig class yesterday. I have called it Parameter::Validate. If you are interested, I will publish the source code and test script here. I know, the test script is a bit small, but I have only written one or two before. So I'm not familiar with the style of test scripts.

package Parameter::Validate;
$VERSION = 0.01;
# 15.01.2002 - 0.01
#  taken from CCS::Data::Datatype::base_class, see also
#  ( http://www.perlmonks.org/index.pl?node_id=138586&lastnode_id=131 
+)
# 16.01.2002 - 0.01
#  translated some comments

use strict;
use Data::Dumper;   # used in debug method
use base 'Clone';   # inherit clone method

# predefined parameter configurations
my $names = {
    datatype => {
            mandatory  => {type    => 'boolean',
                           default => 0,
                           valid   => 0,
                          },
            min_length => {type    => 'integer',
                           min     => 0,
                           max     => undef,
                           default => 0,
                           valid   => 0,
                          },
            max_length => {type    => 'integer',
                           min     => 0,
                           max     => undef,
                           default => undef,
                           valid   => 0,
                          },
            min_number => {type    => 'integer',
                           min     => undef,
                           max     => undef,
                           default => undef,
                           valid   => 0,
                          },
            max_number => {type    => 'integer',
                           min     => undef,
                           max     => undef,
                           default => undef,
                           valid   => 0,
                          },
                },
            };

# constructor
sub new {
    my ($class, @param) = @_;
    my $self = {};
    $class = ref($class) || $class;

    # examine given parameters

    # only 1 parameter?
    if (scalar @param == 1) {

        # yes; scalar or hashref?
        my $ref = ref($param[0]);
        if (not $ref) {

            # scalar; lookup in %$names and clone this configuration
            die "no such configuration: $ref"
                unless (exists $names->{$param[0]});

            # clone configuration
            $self = Clone::clone($names->{$param[0]});
        } elsif ($ref eq 'HASH') {

            # hashref; clone it
            $self = Clone::clone($param[0]);
        } else {

            # no valid reference
            die "expected scalar or hashref, got $ref";
        }
    } else {

        # no; more than 1 parameter
        $self = {@param};
    }

    bless($self, $class);

    return $self;
}

# set valid to 1
sub enable {
    my ($self, @param) = @_;

    foreach (@param) {
        if (exists $self->{$_}) {

            # set valid to 1
            $self->{$_}->{valid} = 1;
        } else {

            # unknown parameter
            die "parameter $_ is not known";
        }
    }
    return 1;
}

# set valid to 0
sub disable {
    my ($self, @param) = @_;

    foreach (@param) {
        if (exists $self->{$_}) {

            # set valid to 0
            $self->{$_}->{valid} = 0;
        } else {

            # unknown parameter
            die "parameter $_ is not known";
        }
    }
    return 1;
}

# change parameter configuration
sub change {
    my ($self, @param) = @_;

    # 1 parameter form?
    if (scalar @param == 1) {

        # check, if it's an hashref
        die "wrong argument: $param[0]"
            if (not ref($param[0]) or ref($param[0]) ne 'HASH');

        @param = %{$param[0]};

    # 3 parameter form?
    } elsif (scalar @param == 3) {

        # check, if the first 2 are scalars
        die "wrong arguments: $param[0] : $param[1] -> $param[2]"
            if (ref($param[0]) or ref($param[1]));

        $self->_change($param[0], {$param[1], $param[2]});
        return 1;
    }

    # now we accept $key1, $hashref1, $key2, $hashref2 ...

    # even number of parameters?
    die "wrong number of arguments: ".scalar @param
        if ((scalar @param) & 1);

    # are there parameters left?
    while (scalar @param > 0) {

        # is $param[0] a scalar and $param[1] an hashref?
        die "wrong arguments: $param[0] -> $param[1]"
            if (ref($param[0]) or not ref($param[1]) or
                (ref($param[1]) ne 'HASH'));

        $self->_change(shift @param, shift @param);
    }

    return 1;
}

sub _change {
    my ($self, $param, $config) = @_;

    # is $param a known parameter name?
    die "parameter $param is not known"
        unless (exists $self->{$param});

    # is $param a valid parameter
    die "parameter $param is not valid"
        unless ($self->{$param}->{valid});

    # change configuration
    foreach my $key (keys %$config) {
        die "$param : $key does not exist"
            unless (exists $self->{$param}->{$key});

        $self->{$param}->{$key} = $config->{$key};
    }
    return 1;
}

# return object structure
sub debug {
    return Dumper(shift);
}

# process given parameter
sub process {
    my ($self, @param) = @_;
    my %param = ();

    # create new hashref and fill it with defaults
    my $config = $self->defaults;

    # only 1 parameter?
    if (scalar @param == 1) {

        # is it an hashref?
        die "wrong argument: $param[0]"
            if (not ref($param[0]) or ref($param[0]) ne 'HASH');

        %param = %{$param[0]};
    } else {

        # copy array to hash
        %param = @param;
    }

    # examine each given parameter
    foreach my $key (keys %param) {
        my $val = $param{$key};

        # is parameter valid?
        my $error = $self->validate($key, $val);
        die "Key: $key - Value: $val - Error: $error"
            if ($error);

        $config->{$key} = $val;
    }

    return $config;
}

# return default values
sub defaults {
    my $self    = shift;
    my $default = {};

    foreach my $key (keys %$self) {
        $default->{$key} = $self->{$key}->{default}
            if (exists $self->{$key}->{default});
    }

    return $default;
}

# validate parameter and value
sub validate {
    my ($self, $param, $value) = @_;

    # does $param exist?
    return "parameter unknown"
        unless (exists $self->{$param});

    # is $param valid?
    return "parameter invalid"
        unless ($self->{$param}->{valid});

    # check type
    my $type = $self->{$param}->{type};

    # boolean
    if ($type eq 'boolean') {
        # nothing to check
    }
    # integer
    elsif ($type eq 'integer') {

        # check for integer (numbers and minus allowed)
        return "value is no integer"
            unless ($value =~ /^-?\d+$/);

        # check minimum
        if (defined $self->{$param}->{min}) {
            my $min = $self->{$param}->{min};
            return "value is less than $min"
                if ($value < $min);
        }

        # check maximum
        if (defined $self->{$param}->{max}) {
            my $max = $self->{$param}->{max};
            return "value is greater than $max"
                if ($value > $max);
        }
    }
    # string
    elsif ($type eq 'string') {

        # check minimum length
        if (defined $self->{$param}->{min}) {
            my $min = $self->{$param}->{min};
            return "value is shorter than $min chars"
                if (length($value) < $min);
        }

        # check maximum length
        if (defined $self->{$param}->{max}) {
            my $max = $self->{$param}->{max};
            return "value is longer than $max chars"
                if (length($value) > $max);
        }
    }
    # unknown type
    else {
        die "unknown type $type";
    }

    # alles okay
    return undef;
}
        

1;
[download]

And this is the test script:

#!/usr/bin/perl -w

use strict;
use Test::More 'no_plan';
use Data::Dumper;

use lib '/home/uwe/cvs/perl';
use lib '/home/uwe/cvs/perl/module';

use_ok 'Parameter::Validate';


my $debug = 1;

# generate new object
my $pv = Parameter::Validate->new('datatype');
isa_ok($pv, 'Parameter::Validate');
can_ok($pv, qw(new clone enable disable change debug process));

# clone object
my $copy = $pv->clone;
isa_ok($copy, 'Parameter::Validate');
can_ok($pv, qw(new clone enable disable change debug process));

if ($debug) {
#    print Dumper($copy);
#    print "\n$pv\n$copy\n";
}

# enable parameter
$pv->enable(qw(mandatory min_length max_length min_number max_number))
+;
#print Dumper($pv) if $debug;

# disable parameter
$pv->disable(qw(mandatory min_length max_length min_number max_number)
+);
#print Dumper($pv) if $debug;

# change parameter
$pv->enable(qw(min_length max_length));
# 3 parameter form
$pv->change('min_length', 'default', 123);
# 2 parameter form
$pv->change('max_length', {default => 25, max => 50});
#print Dumper($pv) if $debug;

$copy->enable(qw(min_length max_length max_number min_number));
# 2 parameter form extended
$copy->change('min_length', {default => 25, max => 50},
              'max_length', {default => 23, max => 99});
# 1 parameter form
$copy->change({min_number => {default => 222},
               max_number => {default => 999}});
#print Dumper($copy) if $debug;

# process parameter
$pv->enable('mandatory');
print Dumper($pv->process(mandatory => 1, min_length => 67));
[download]

I would like to hear comments to my code. Feedback is very important for me. Please feel free to criticize me!

Thank you, Uwe

Comment on Re: Re: OO - problem with inheritance Select or Download Code


laziness, impatience, and hubris
	PerlMonks