Tiny Frameworks

[Ovid]

Rather than have a reply buried somewhere in this thread where it might get missed, I bow to consensus and and agree that I was wrong. Sorry for all of the hullabaloo :) (though I see from comments below that not everyone disagreed with my post)

It seems that the work "framework" has fallen out of fashion in some circles. In fact, many programmers sneer at the thought of frameworks. This is disappointing because a framework, to borrow the Wikipedia definition, is merely a conceptual structure to solve a complex issue.

We might think of things like J2EE, Catalyst, or other things as frameworks and be scared of them. This is sad because those can be great tools, but the important thing is to understand the problem you are trying to solve and decide if the framework is applicable to this problem. In reality, general purpose frameworks such as Catalyst often offer a lot more than you need or solve problems in a different way from what you expect. The might be huge and have a steep learning curve or they might be so simple as to not solve your needs. In this meditation, I want to describe a very common problem and offer a simple framework to solve it. In fact, the framework is so simple that it's merely a small class, but it can save much work later on.

Disclaimer: I'm not going to pretend that my framework is a general purpose solution for you or that it's the right solution for any problem. In fact, I can definitely point out some flaws in in, but it's merely intended as an example of one way of bringing structure to your code. I'm also going to touch on the highlights of the code and let you work out the details for yourself.

The problem: you want to quickly prototype classes for your code in a way that is easy to learn.

The solution: a tiny superclass.

Some of you might argue that a single superclass is not a framework. However, remember that a framework is merely a way to solve a complex problem. This does not mean that the framework must be complex. The simple framework that I am presenting offers the following:

• Built-in class data
• Blessed hashrefs (because all OO programmers know them)
• A standard constructor
• Easy validation of presence of constructor arguments
• Easy getter/setters

The framework is simplistic, but that's the point. What it brings is a consistency to class construction. As a result, if all of your classes are based on it, programmers coming into your project easily learn how to create and use new classes rather than wondering "what's the constructor name? How do I handle class data? What are the constructor arguments? How are errors handled?"

First, let's call the class My::UNIVERSAL. It's intended that most if not all of your classes will inherit from this or from another class which does. We're not sticking anything directly into UNIVERSAL because we don't want to introduce a global change which might have unexpected side-effects on modules which don't use this.

Now, the first thing we want to do is handle class data (strict and warnings should be included but are omitted to keep the examples simpler):

package My::UNIVERSAL;

use base qw(Class::Data::Inheritable);

1;

Now every class which inherits from this gets class data for free. That's not a huge win, but we can also get accessor/mutator method generation for free:

package My::UNIVERSAL;

use strict;
use warnings;

use base qw(
  Class::Data::Inheritable
  Class::Accessor
);

1;

Now that sort of works, but there are some problems with this:

package Creature;

use base 'My::UNIVERSAL';

__PACKAGE__->mk_classdata( mortal => 1 );
__PACKAGE__->mk_accessors( qw/name gender/ );

1;

# in the code

my $creature = Creature->new({
    name   => 'Alice',
    gender => 'female',
} );

In the above example, the resulting data structure looks like this:

$VAR1 = bless( {
  gender => 'female',
  name   => 'Alice'
}, 'Creature' );

For this simple example, this seems fine, but as many who have worked on large code bases can attest, accidentally overwriting a hash key in a blessed hash can cause bugs which are very painful to track down. Further, Class::Accessor, while useful, has mutators which return the value we're setting the objects to. In other words:

print $creature->gender('male');   # prints 'male'

If you like to chain method calls, that doesn't work.

As an added issue, passing unknown hash keys results in those appearing in blessed hash. We'll deal with that later, but for now, let's dispense with Class::Accessor and write our own. We want it to make keys local to the class we're using and to return the invocant (the object) when setting a value.

sub mk_accessors {
    my ( $class, @accessors ) = @_;
    foreach my $accessor (@accessors) {
        no strict 'refs';
        my $key  = "$class\::$accessor";
        *$key = sub {
            my $self = shift;
            return $self->{$key} unless @_;
            $self->{$key} = shift;
            return $self;
        };
    }
}

With this, all keys in the hashref are now prepended with the package name. Now this might seem like a pain to type out, but if you use those methods internally in your class, it's not so bad. Imagine a Rectangle class:

sub area {
    my $self = shift;
    return $self->height * $self->width;
}

That's easy to read and pretty self-documenting.

Getting rid of Class::Accessor means we no longer have a default constructor, so let's add one.

use Scalar::Util 'reftype';

sub new {
    my ( $class, $args ) = @_;
    $args = {} unless defined $args;
    unless ( 'HASH' eq reftype $args ) {
        croak "Argument to new() must be a hash reference";
    }
    my $self = bless {} => $class;
    while ( my ( $key, $value ) = each %$args ) {
        $self->$key($value);
    }
    return $self;
}

And the constructor does not change, but look at the object now:

$VAR1 = bless( {
  'Creature::gender' => 'female',
  'Creature::name'   => 'Alice'
}, 'Creature' );

Now instance data is per class and we can chain method calls if we prefer this style (separate method calls are always fine):

$creature->name('Bob')
         ->gender('unknown');

Also, let's look at what happens if we try to add an unknown key:

my $creature = Creature->new( {
    name   => 'Alice',
    gender => 'female',
    foo    => 1,
} );

This results in the error Can't locate object method "foo" via package "Creature". Very handy!

At this point, we have a useful but simplistic class creation framework. However, there are a couple of features we want. Perhaps "name" is mandatory but "gender" is not. Let's add a couple of helpers for this. The code here is going to get a bit magical for a couple of reasons. First, we want something that's easy to use and sometimes you need to do funky things under the covers. Second, in refactoring out some common code, we can lose the return value of wantarray because, unlike caller, wantarray does not allow you to inspect higher stack frames. Thus, we'll use a "magic" goto to ignore the existing stack frame (see the documentation of goto for an explanation) We'll also have to change our constructor for this.

__PACKAGE__->mk_class_data('__data_key');

sub new {
    my ( $class, $args ) = @_;

    # XXX I don't like doing this for every instance, but 
    # use 'base' doesn't call import()
    my $key = " $class data ";
    $class->__data_key($key);
    $args ||= {};
    unless ( 'HASH' eq reftype $args ) {
        croak('Argument to new() must be a hashref');
    }
    my $self = bless { $key => $args } => $class;
    $self->_initialize;
    delete $self->{$key};
    return $self;
}

sub _initialize {
    my $class = ref($_[0]);
    croak "_initialize() must be overridden in a ($class)";
}

# a truly private method!
my $check_attribute = sub {
    my ( $self, $attribute ) = @_;
    my $value = delete $self->{ $self->__data_key }->{$attribute};
    if ( ! defined wantarray ) {
        $self->$attribute($value);
    }
    else {
        return $value;
    }
};

sub _must_have {
    my ( $self, $attribute ) = @_;

    croak("Mandatory attribute ($attribute) not found")
      unless exists $self->{ $self->__data_key }->{$attribute};
    goto $check_attribute;
}


sub _may_have {
    my ( $self, $attribute ) = @_;
    return unless exists $self->{ $self->__data_key }->{$attribute};
    goto $check_attribute;
}

We now create a subclass as follows:

package Creature;

use base 'My::UNIVERSAL';

__PACKAGE__->mk_classdata( mortal => 1 );
__PACKAGE__->mk_accessors(qw/name gender/);

sub _initialize {
    my ( $self, $args ) = @_;
    $self->_must_have('name');
    $self->_may_have('gender');
}

Pretty simple, eh? If we're missing 'name' in the constructor, creating the class will fail. The 'gender' attribute is still optional.

But what's with the wantarray stuff? Well, it's possible that the accessor has a different name, so we support that:

package IP::Address;

use base 'My::Universal';
__PACKAGE__->mk_accessors('address');

sub _initialize {
    my $self = shift;
    $self->address( $self->_must_have('ip') );
}

1;

#

use IP::Address;

my $ip = IP::Address->new({ ip => $some_ip });
print $ip->address;   # prints $some_ip

Of course, having different accessors for property names can quickly get confusing, but it's now there if you need it.

Another problem we want to solve is passing unknown attributes to the constructor. Because our constructor is deliberately destructive to the hashref passed into it, this makes this simple. We'll add a private $check_keys method and tweak our constructor a little.

my $check_keys = sub {
    my $self = shift;
    my $data = delete $self->{ $self->__data_key };
    if ( my @keys = keys %$data ) {
        local $" = ', ';
        croak("Unknown keys to constructor:  (@keys)");
    }
};

sub new {
    my ( $class, $args ) = @_;
    my $key = " $class data ";
    $class->__data_key($key);
    $args ||= {};
    unless ( 'HASH' eq reftype $args ) {
        croak('Argument to new() must be a hashref');
    }
    my $self = bless { $key => $args } => $class;
    $self->_initialize;
    $self->$check_keys;
    return $self;
}

And let's see what happens with this:

my $creature = Creature->new( {
    name   => 'Alice',
    gender => 'female',
    foo    => 1,
    bar    => 1,
} );

# Unknown keys to constructor:  (bar, foo)

We have now met all of our original design goals. There are plenty of other improvements we could make. Standard _carp and _croak methods might be useful. Perhaps proper exception handling would be good. And, of course, if we wanted this to be a serious class, we would have to modify mk_accessors to allow for proper data validation:

package Tall::Square;

use Scalar::Util 'looks_like_number';
use base 'My::UNIVERSAL';

__PACKAGE__->mk_accessors(
  width  => sub { looks_like_number($_[1]) && $_[1] > 0 ),
  height => sub {
      my ( $self, $height ) = @_;
      return looks_like_number($height) && $height > $self->width;
  },
);

sub _initialize {
    my $self = shift;
    $self->_must_have('height');
    $self->_must_have('width');
}

sub area {
    my $self = shift;
    return $self->height * $self->width;
}

1;

Adding that is left as an exercise to the reader.

This simple class construction framework is not intended to be a serious framework (you might consider Moose or something similar), but it does show that frameworks need not be complex and they can reduce the tedium of 'grunt work' that can come with writing code. Remember that just because general purpose frameworks are often huge and have more features than you need, creating and using one for your personal or professional code does not have to be a bad thing.

package My::UNIVERSAL;

use strict;
use warnings;
use Scalar::Util 'reftype';
use Carp 'croak';

use base qw(Class::Data::Inheritable);
__PACKAGE__->mk_classdata('__data_key');

sub mk_accessors {
    my ( $class, @accessors ) = @_;
    foreach my $accessor (@accessors) {
        no strict 'refs';
        my $key  = "$class\::$accessor";
        *$key = sub {
            my $self = shift;
            return $self->{$key} unless @_;
            $self->{$key} = shift;
            return $self;
        };
    }
}

my $check_keys = sub {
    my $self = shift;
    my $data = delete $self->{ $self->__data_key };
    if ( my @keys = keys %$data ) {
        local $" = ', ';
        croak("Unknown keys to constructor:  (@keys)");
    }
};

sub new {
    my ( $class, $args ) = @_;
    my $key = " $class data ";
    $class->__data_key($key);
    $args ||= {};
    unless ( 'HASH' eq reftype $args ) {
        croak('Argument to new() must be a hashref');
    }
    my $self = bless { $key => $args } => $class;
    $self->_initialize;
    $self->$check_keys;
    return $self;
}

sub _initialize {
    my $class = ref($_[0]);
    croak "_initialize() must be overridden in a ($class)";
}

my $check_attribute = sub {
    my ( $self, $attribute ) = @_;
    my $value = delete $self->{ $self->__data_key }->{$attribute};
    if ( !defined wantarray ) {
        $self->$attribute($value);
    }
    else {
        return $value;
    }
};

sub _must_have {
    my ( $self, $attribute ) = @_;

    croak("Mandatory attribute ($attribute) not found")
      unless exists $self->{ $self->__data_key }->{$attribute};
    goto $check_attribute;
}

sub _may_have {
    my ( $self, $attribute ) = @_;
    return unless exists $self->{ $self->__data_key }->{$attribute};
    goto $check_attribute;
}

1;

Update: Fixed a typo noticed by calin whereby I referred to a superclass as a subclass.