Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

Re: Re: OO - problem with inheritance

by uwevoelker (Pilgrim)
on Jan 16, 2002 at 22:20 UTC ( #139266=note: print w/replies, xml ) Need Help??


in reply to Re: OO - problem with inheritance
in thread 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;
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));
I would like to hear comments to my code. Feedback is very important for me. Please feel free to criticize me!

Thank you, Uwe

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://139266]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (5)
As of 2022-05-18 14:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Do you prefer to work remotely?



    Results (71 votes). Check out past polls.

    Notices?