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]