in reply to OO - problem with inheritance

After reading all of the posts herein, it struck me that you want a separate instance of %parameter_config per derived class, yet shared among all objects of the derived class type.

For clarification, assuming you had three classes derived from the base, e.g., Int, String and Float. There would be exactly three instances of %parameter_config (kept somewhere -- read on), regardless of how many Int, String or Float objects you create.

Each of the %parameter_config things has in common some basic info, plus some class-specific extra stuff added by each subclass.

If this describes your problem, then perhaps I have a solution.

Create a class, say, ParamConfig.pm, which consists basically of a blessed hash (%parameter_config ) containing the basic info required by all types. Add one more hash element: parent_type.

In the constructor (new method) of this class, accept a parameter, parent_type, which is used to initialize the parent_type hash element.

Now, in your base class (from which you will derive Int, String, Float, etc.), you would have code like this:

package BaseType;

...

BEGIN {
  my $parameter_config = undef;

  # accessor - turns the ParamConfig object into a closure
  sub parameter_config {
    $parameter_config = $_[0] if @_;
    return $parameter_config;
  }
}

sub new {
  my $class = shift;      # the usual prolog
  my $type = ref $class || $class;

  my $self = bless {}, $type;
  return $self;
}

...

[download]
In your derived class (say, Int), you would have something like the following code: 
package Int;
use base qw( BaseType );

use ParamConfig;

BEGIN {
  # create only one of these, at compile time
  my $pkg_name = __PACKAGE__;
  my $parameter_config = parameter_config( new ParamConfig( $pkg_name 
+) );

  @{$parameter_config}{ 'int_specific', 'params' } = ( 'vale', 'val2' 
+);
}

sub new {
  my $class = shift;      # the usual prolog
  my $type = ref $class || $class;

  my $self = bless SUPER->new(), $type;
  @{$self}{ 'Int', 'Specific', 'Variables' } = ();

  return $self;
}
...

# Thereafter, access the class-specific ParamConfig using the accessor
+, parameter_config().

[download]

This scheme turns instances of ParamConfig into class-level closures (i.e., singletons), share among all members of the derived classes.

Update: the use ParamConfig; belongs in the subclass, not the base class.

dmm

If you GIVE a man a fish you feed him for a day
But, TEACH him to fish and you feed him for a lifetime

Replies are listed 'Best First'.
Re: Re: OO - problem with inheritance
by uwevoelker (Pilgrim) on Jan 16, 2002 at 22:20 UTC
    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
[reply]
[d/l]
[select]

In Section Seekers of Perl Wisdom