An Object Structural Design Pattern in Perl

edit: Dec 10: due to comments by chromatic - removed unless ref $class

Object Structural Patterns in Perl.

[Gang of Four: Gamma, Helm, Johnson, et al. Design Patterns: Elements of Reusable Object-Oriented Software. Addison-Wesley, Reading, MA, 1995]

I have what I believe is an elegant implementation of an Object Structural pattern from [Gang of Four] using Perl. In this case, I want to use the Bridge pattern. Bridge allows the decoupling of an abstraction from its implementation, or possibly several implementations.

In the current example space, my motivation is to allow a Session object to have a Bridge to a Storage and a Serializer object. Thus, the Session object can utilize any method for storing and serializing data associated with a session. In the first example, I will use XML::Simple for the serializer object. I will also give an example using a YAML object. I will also give an example of Storage using a wrapper class around DB_File that utilizes DB_File::Lock to lock the database file.

First, the (abstract) base class for the Bridge pattern.

package CGI::Armature::Bridge;

use strict;

sub new {
    my $class = shift;
    my $object_ref = shift;
    my $method_map = shift;
    my $self = {
        object=>$object_ref,
    };
    $self-{$_} = $method_map->{$_} for keys %$method_map;
    return bless($self, $class);
}

1;
[download]

This base class defines a "new" method, and defines an "object" element that contains an object reference to an implementation object. The "$method_map" hash maps the interface that will be common to each derived class to the interface of the specific object reference contained in the $self->{object} element.

package CGI::Armature::Serializer;

use strict;
use vars '@ISA';
BEGIN {
    require CGI::Armature::Bridge;
    @ISA = 'CGI::Armature::Bridge';
}

sub serialize {
    my $self = shift;
    my $hash = shift;
    my $method = $self->{serialize};
    return $self->{object}->$method($hash);
}

sub deserialize {
    my $self = shift;
    my $data = shift;
    my $method = $self->{deserialize};
    return $self->{object}->$method($data);
}

1;
[download]

This code defines a Serializer class; it derives directly from Bridge and inherits the "new" method and definition of both the method_map and the contained object reference. The child class defines the interface that forwards method calls to the "object", which contains a reference to an object implementing a serializer interface. The methods "serialize" and "deserialize" each use the respective keys to the method_map stored in $self; the values correspond to the methods defined for the interface of the $self->{object}.

use CGI::Armature::Serializer;
use XML::Simple;

my $serialize_map = {
    serialize=>'XMLin',
    deserialize=>'XMLout',
};

my $serializer = CGI::Armature::Serializer->new(
    XML::Simple->new(suppressempty=>q{}, noattr=>1),
    $serialize_map,
);
[download]

This snippet of client code instantiates a Serializer object with a method_map that maps "serialize" with "XMLout" and "deserialize" with "XMLin" using the options given to override the default options of XML::Simple.

use CGI::Armature::Serializer;
use YAML;

my $serialize_map = {
    serialize=>'Dump',
    deserialize=>'Load',
};

my $serializer = CGI::Armature::Serializer->new(
    YAML->new(),
    $serialize_map,
);
[download]

This snippet of client code does the same thing using YAML as the serialization interface.

Client code for either serializer object would be identical.

$data = $serializer->serialize($data_hash);

$data_hash = $serializer->deserialize($data);
[download]

Now for the Storage class.

package CGI::Armature::Storage;

use strict;
use vars '@ISA';
BEGIN {
    require CGI::Armature::Bridge;
    @ISA = 'CGI::Armature::Bridge';
}

sub fetch {
    my $self = shift;
    my $id = shift;
    my $method = $self->{fetch};
    return $self->{object}->$method($id);
}

sub store {
    my $self = shift;
    my $id = shift;
    my $value = shift;
    my $method = $self->{store};
    $self->{object}->$method($id, $value);
}

sub fetch_ids {
    my $self = shift;
    my $method = $self->{fetch_ids};
    return $self->{object}->$method();
}

sub delete {
    my $self = shift;
    my $id = shift;
    my $method = $self->{delete};
    $self->{object}->$method($id);
}

1;
[download]

In general, each class derived from Bridge defines an interface, and forwards the method calls corresponding to each method (which is the same as the key in the method_hash) to the contained objects interface.

Here is the wrapper for DB_File.

package CGI::Armature::Database;

use strict;

use Fcntl;
use DB_File::Lock;
use CGI::Armature::PathInfo;

my %path_info = CGI::Armature::PathInfo::get_paths();

sub new {
    my $class = shift;
    my ($dbfile) = @_;
    die "need dbfile" unless $dbfile;
    my $self = {
        dbfile=>$dbfile,
    };
    return bless($self, $class);
}

sub create {
    my $self = shift;
    my %db_file;
    my $locking = {
        mode=>'write',
        lockfile_name=>"$path_info{sessionpath}/exclusive.lock",
    };
    tie(
        %db_file, 
        'DB_File::Lock', 
        "$path_info{sessionpath}/$self->{dbfile}", 
        O_RDWR|O_CREAT, 
        0600,
        $DB_HASH,
        $locking,
    ) or die "Couldn't tie DB_File $path_info{sessionpath}/$self->{dbf
+ile} $!; aborting";
    untie %db_file;
}

sub delete {
    my $self = shift;
    my $key = shift;
    my %db_file;
    my $locking = {
        mode=>'write',
        lockfile_name=>"$path_info{sessionpath}/exclusive.lock",
    };
    tie(
        %db_file, 
        'DB_File::Lock', 
        "$path_info{sessionpath}/$self->{dbfile}", 
        O_RDWR, 
        0600,
        $DB_HASH,
        $locking,
    ) or die "Couldn't tie DB_File $path_info{sessionpath}/$self->{dbf
+ile} $!; aborting";
    delete $db_file{$key};
    untie %db_file;
}

sub set_value {
    my $self = shift;
    die "not enough values for set_value" unless @_ == 2;
    my ($key, $value) = @_;
    my %db_file;
    my $locking = {
        mode=>'write',
        lockfile_name=>"$path_info{sessionpath}/exclusive.lock",
    };
    tie(
        %db_file, 
        'DB_File::Lock', 
        "$path_info{sessionpath}/$self->{dbfile}", 
        O_RDWR, 
        0600,
        $DB_HASH,
        $locking,
    ) or die "Couldn't tie DB_File $path_info{sessionpath}/$self->{dbf
+ile} $!; aborting";
    $db_file{$key} = $value;
    untie %db_file;
}

sub get_value {
    my $self = shift;
    my $key = shift;
    my %db_file;
    my $locking = {
        mode=>'read',
        lockfile_name=>"$path_info{sessionpath}/exclusive.lock",
    };
    tie(
        %db_file, 
        'DB_File::Lock', 
        "$path_info{sessionpath}/$self->{dbfile}", 
        O_RDONLY, 
        0600,
        $DB_HASH,
        $locking,
    ) or die "Couldn't tie DB_File $path_info{sessionpath}/$self->{dbf
+ile} $!; aborting";
    my $value = $db_file{$key};
    untie %db_file;
    return $value;
}

sub get_keys {
    my $self = shift;
    my %db_file;
    my $locking = {
        mode=>'read',
        lockfile_name=>"$path_info{sessionpath}/exclusive.lock",
    };
    tie(
        %db_file, 
        'DB_File::Lock', 
        "$path_info{sessionpath}/$self->{dbfile}", 
        O_RDONLY, 
        0600,
        $DB_HASH,
        $locking,
    ) or die "Couldn't tie DB_File $path_info{sessionpath}/$self->{dbf
+ile} $!; aborting";
    my @keys =  keys %db_file;
    untie %db_file;
    return \@keys;
}

1;
[download]

And a snippet of client code.

use CGI::Armature::Storage;
use CGI::Armature::Database;

my $storage_map = {
    fetch=>'get_value',
    store=>'set_value',
    fetch_ids=>'get_keys',
    delete=>'delete',
};

my $storage = CGI::Armature::Storage->new(
    CGI::Armature::Database->new('session_id.db'),
    $storage_map,
);

my $data = $storage->fetch($session_id);
[download]

Comment on An Object Structural Design Pattern in Perl Select or Download Code

Replies are listed 'Best First'.
Re: An Object Structural Design Pattern in Perl by chromatic (Archbishop) on Oct 23, 2007 at 01:45 UTC
`my $self = { object=>$object_ref, } unless ref $class;` [download] Per my reading of this code (without running any tests), I believe this will allow you to call the constructor as an instance method and get back the previously-created object--not the same instance, but the most recently created instance. What did you intend to do here?	[reply] [d/l]
Re^2: An Object Structural Design Pattern in Perl by hypochrismutreefuzz (Scribe) on Nov 05, 2007 at 18:08 UTC
The "unless" is used to prevent calling the constructor as an instance method. The constructor can ONLY be called on the class name. Thus `CGI::Armature::Storage->new($obj, $hash);` [download] will work while `$obj->new($obj, $hash);` [download] will cause a fatal error due to $self not being initialized. edit: Dec 10 2007 Sorry about that. I will append an edited version of my code after this reply.	[reply] [d/l] [select]
Re^3: An Object Structural Design Pattern in Perl by chromatic (Archbishop) on Nov 06, 2007 at 02:32 UTC
How is it a fatal error? It's effectively a semi-static variable, but I don't see any error checking code. I would have expected something like `croak( 'Cannot call constructor on instance' ) if blessed( $class );`, but all I see is mixing a lexical declaration with a postfix conditional, which usually isn't the right thing.	[reply] [d/l]
Re^4: An Object Structural Design Pattern in Perl by hypochrismutreefuzz (Scribe) on Dec 10, 2007 at 19:54 UTC


"be consistent"
	PerlMonks