my $parameter_config = {
        mandatory  => {type    => 'boolean',
                       default => 0,
                       valid   => 0},
                       };

sub parameter_config { $parameter_config };

sub valid_parameter {
    my $class = shift;

    my @param = @_;
    foreach (@param) {
        my $param_config = $class->parameter_config->{$_};
        if ($param_config) {
            $param_config->{valid} = 1;
        } else {
            die "Parameter $_ not known";
        }
    }
    return 1;
}
[download]

Integer->valid_parameter(qw(mandatory));
[download]

--
Ilya Martynov (http://martynov.org/)

Hello Ilya,
thank you for your fast answer. Did I got you right, that when I want to change other configuration parameters like this

&CCS::Data::Datatype::base_class::config_parameter(
        max_length => {max => 255, default => 255},
        min_length => {max => 255});
[download]

which is taken from my String class, I need to override your sub parameter_config in this way?

sub parameter_config {
    return {max_length => {max => 255, default =>255));
}
[download]

But I also need the other parameters from base class (like min => 0 and valid => 0 in this case).

Or could I do something like this:

my $parameter_config = SUPER->parameter_config;
$parameter_config->{max_length}{max} = 255;
$parameter_config->{max_length}{default} = 255;

sub parameter_config { $parameter_config }
[download]

My classes not only inherit from base_class.pm. There are also datatypes that inherit from other datatypes. Such as Text inherits from String (but no direct base_class) and PrimaryKey inherits from Integer. Is such inheritance with one of this configuration methods combineable?

My goal is, that I can add new parameters only in base_class (let's say has_double_letters or max_number / min_number) and all the datatypes need only to "activate" this new parameters via the ->valid_parameter(qw(mandatory max_number)) call.

Thanks, Uwe

my $parameter_config = __PACKAGE__->SUPER::parameter_config;
$parameter_config->{max_length}{max} = 255;
$parameter_config->{max_length}{default} = 255;

sub parameter_config { $parameter_config }
[download]

This should work if you want to register your parameters in base_class. BTW you don't need to override parameter_config at all in this case because SUPER->parameter_config returns hash reference stored in $parameter_config variable in base class. So next two lines do affect hash used by base_class. If it is not desired effect you should clone that hash:

use Storable qw(dclone);

my $parameter_config = dclone(__PACKAGE__->SUPER::parameter_config);
$parameter_config->{max_length}{max} = 255;
$parameter_config->{max_length}{default} = 255;

sub parameter_config { $parameter_config }
[download]

Update: Fixed usage of wrong syntax (SUPER->method instead of __PACKAGE__->SUPER::method)

--
Ilya Martynov (http://martynov.org/)

I think you'll find perltootc - Tom's OO Tutorial for Class Data in Perl very useful, in particular the section Inheritance Concerns. Borrowing code from that, you can use something like this:

package base_class;
my %parameter_config = {# the same as before...};

# accessor for class-specific hash named %parameter_config:
sub parameter_config {  
  my $obclass = shift;    
  my $class   = ref($obclass) || $obclass;
  my $varname = $class . "::parameter_config";
  no strict "refs";     # to access package data symbolically

  %$varname = {foo=>'bar'}; 
  # this is the package-local hash %parameter_config.  
  # Just refering to '%parameter_config' should refer to 
  # %base_class::parameter_config.

}
[download]

To initialize the package-specific %parameter_config, throw in similar magic into &base_class::new.

-- Frag.
--
"It's beat time, it's hop time, it's monk time!"

> It sounds like you're wrestling with the question of how to create class data so that the accessors are inherited but not the data itself.
I would like the accessors _and_ data inherit.

In base_class is the big $parameter_config hashref. And there is a constructor new() which execlusively deals with this hashref. He gets his values by $parameter_config->{..}{..} and so on. But the other modules, which inherit from base_class only submit their changes to that huge config-hashref. Because this can't be done directly, I wrote two subroutines in base_class: valid_parameter and config_parameter. I want them to store the additional information in this hashref. But - and here is my problem - this hashref should be unique for each datatype/class. So I would like to access the hashref in base_class but the contents should be specific to the calling class.

I agree, that this is very naive. Now I'm searching for an other approach. Have you written my reply to Ilya's answer? I would like to use the last method: copy the hash and change it a little bit. But because it's an hashref, I think this won't work...

To your suggestion:
I need the %parameter_config hash before new() is called, because new() needs this information to figure out, if the parameters given to new() are correct. So I need code I can run when the class is loaded.

Thank you, good bye, Uwe

So I would like to access the hashref in base_class but the contents should be specific to the calling class.

I'm a little confused about what you're doing. You want each change submitted to the base_class's %parameter_config for confirmation; after that, the actual values get stored in each subclass's own %parameter_config, right? If so, just change your accessors so that before fiddling with %sub_class::parameter_config it first messes with %base_class::parameter_config, to do whatever checking/storing you want done there, and then store the data in each individual subclass's hash. (Or, if you follow your new approach, replace "fiddling with %base_class::parameter_config" with "call validation methods from ValidateNewParameter". Same principle.)

I need the %parameter_config hash before new() is called, because new() needs this information to figure out, if the parameters given to new() are correct. So I need code I can run when the class is loaded.

OK, so put something like this at the start of each subclass:

use vars qw(%parameter_config); # or 'our' but NOT 'my', not if you
                                # use the approach I gave before
%parameter_config = &base_class::parameter_config;
[download]

And now each subclass has its own copy of %parameter_config. Just make sure that &base_class::parameter_config returns a copy of the hash.

-- Frag.
--
"It's beat time, it's hop time, it's monk time!"

It is similar to your original idea to store parameters data in a hash (instead of hashes you have objects which stores same information). So it is not really new idea :) Anyway it could be more cleaner approach if you move all your validation code into that class and replace hash manupulations with cleaner interface provided by that class. IMHO it is good approach.

--
Ilya Martynov (http://martynov.org/)

You are right. I thought cloning of objects is much easier (because I have heard of the common clone-method in new/copy constructors), but actually it isn't very different from copying an hash. But I also like the idea of moving all my validation code into that class.

Thank you for your comment.

This is definitely a hangover from Java, but whenever I do inheritance in Perl, I write the code so that the parent constructor is called from the child class' constructor. In Java, every time you extend a class, whether you say so explicitly or not, you instantiate everything all the way up the hierarchy up to java.lang.Object.

In Perl I often see people use inheritance with methods only; that is, they inherit the behavior but not the data. To me, both are necessary for object oriented inheritance.

My suggestion is to write the general constructor in the base class with a default value for the parameter checking. If a subclass needs something different, it calls the base class constructor with the proper parameters. In Java, this is super(params), in Perl the child constructor would say:

  my ($class, $whatever) = @_;
  my %params = (); # new params to use instead of parent's params
  my $this = new base_class(%params); # create a new parent
  bless($this, $class); # rebless into the current package

It is better to rewrite your code as:

my ($class, $whatever) = @_;
my %params = (); # new params to use instead of parent's params
my $self = $class->SUPER::new(%params); # create a new parent
bless($self, $class); # rebless into the current package
[download]

Note that this variant doesn't hardcode baseclass name.

BTW I strongly advice against using $this in Perl code. Most Perl programmers are too get used to $self. I recall than in the company where I worked until recenly we have one programmer (who was Java fan but liked Perl too) who used $this in his code. It was big PITA for everybody who had to edit that code. Fingers just type $self and only later you release (when you see Global symbol "$self" requires explicit package name) that it should be $this. After several such accidents we just told him that $this is forbidden :)

Anyway there is nothing wrong in using same constructor in all classes as long as it deffers object initialization to some methods which are overriden in subclasses. Actually it is very common practice and not only in Perl.

--
Ilya Martynov (http://martynov.org/)

And, if you need to call multiple parental classes, there's NEXT, e.g.: $class->NEXT::new(%params).

As for $this vs. $self -- it seems that should be a local style standard, and not a global Perl-wide proscription. So long as it's consistent inside a given project, and easily s///able, use $dohickey, $The_Monster, or $Frank. TMTOWTNI.

-- Frag.
--
"It's beat time, it's hop time, it's monk time!"

$class->SUPER::new(%params);
[download]

Okay point taken. However this business with '$self' is truly not something that ought to be mandated across all projects, because while it may be a common idiom in the Perl community (most likely due to the nice phrase 'my $self'), for those of us that work in multiple OO languages it is not the norm. I routinely have to switch between the two, and from experience I declare: it's no big whoop.

There's at least a potential hazard in this approach: what if your parent constructor does parameter checking, and is more restrictive than your subclass? Then the above would be dangerous -- you'd lose the values in %params -- and you'd want to do something like:

  my ($class, $whatever) = @_;
  my %params = (); # new params to use instead of parent's params
  my $this = new base_class; # create a new parent, and 
                             # let it set its own defaults
  # clobber the base_class' defaults:
  while (my ($k,$v) = each %params) {
     $this->{$k} = $v;
  }
  bless($this, $class); # re-bless into the current package
[download]

Ugly and hypothetical, but something to be aware of.

On second thought, better still: always make any parameter checking in the constructors throw a fatal error. Note such errors in development and change the parent's constructor to play nice.

-- Frag.
--
"It's beat time, it's hop time, it's monk time!"

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]

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

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