File Coverage

lib/App/SharedDatastore.pm

Criterion	Covered	Total	%
statement	80	84	95.2
branch	37	56	66.0
condition	2	3	66.6
subroutine	13	13	100.0
pod	7	7	100.0
total	139	163	85.2

#############################################################################
## $Id: SharedDatastore.pm 10851 2008-02-28 19:50:01Z spadkins $
#############################################################################

package App::SharedDatastore;
$VERSION = (q$Revision: 10851 $ =~ /(\d[\d\.]*)/)[0];  # VERSION numbers generated by svn

use App;
use App::Service;
@ISA = ( "App::Service" );

use strict;

use Storable qw(nfreeze thaw);
use Digest::SHA qw(sha1_hex);

$Storable::canonical = 1;  # this will cause hashes to be serialized the same way every time

=head1 NAME

App::SharedDatastore - Interface for sharing data between processes

=head1 SYNOPSIS

    use App;

    $context = App->context();
    $sds = $context->service("SharedDatastore");
    $sds = $context->shared_datastore();

=head1 DESCRIPTION

A SharedDatastore service represents a single hash in which scalars or
deep references may be stored (basically an MLDBM).

=cut

#############################################################################
# CLASS GROUP
#############################################################################

=head1 Class Group: SharedDatastore

The following classes might be a part of the SharedDatastore Class Group.

=over

=item * Class: App::SharedDatastore

=item * Class: App::SharedDatastore::Repository

=item * Class: App::SharedDatastore::IPCMM

=item * Class: App::SharedDatastore::DBI

=item * Class: App::SharedDatastore::MLDBM

=item * Class: App::SharedDatastore::ApacheSession

=item * Class: App::SharedDatastore::IPCShareLite

=item * Class: App::SharedDatastore::IPCShareable

=back

=cut

#############################################################################
# CLASS
#############################################################################

=head1 Class: App::SharedDatastore

A SharedDatastore service represents a single hash in which scalars or
deep references may be stored.  (They are automatically serialized
for storage.)

It is essentially identical to an MLDBM, but it supports more
implementations than an MLDBM (MLDBM is one of the implementations).
It also does not support the "tie" interface.

=cut

#############################################################################
# CONSTRUCTOR METHODS
#############################################################################

=head1 Constructor Methods:

=cut

#############################################################################
# new()
#############################################################################

=head2 new()

The constructor is inherited from
L|App::Service/"new()">.

=cut

#############################################################################
# _init()
#############################################################################

=head2 _init()

=cut

sub _init {
    &App::sub_entry if ($App::trace);
    my ($self) = @_;
    $self->{data} = {};
    if ($self->{compress}) {
        require Compress::Zlib;
    }
    if ($self->{base64}) {
        App->use("MIME::Base64");
    }
    &App::sub_exit() if ($App::trace);
}

#############################################################################
# PUBLIC METHODS
#############################################################################

=head1 Public Methods:

=cut

#############################################################################
# set()
#############################################################################

=head2 set()

    * Signature: $sds->set($key, $value);
    * Signature: $sds->set($key, $value, $options);
    * Param:     $key               scalar
    * Param:     $value             scalar
    * Param:     $options           HASH (optional)
    * Return:    void

    $sds->set($key,$value);
    $options = {
        info_columns => [ "col1", "col2" ],
        info_values  => [ "value1", "value2" ],
    };
    $sds->set($key, $value, $options);

=cut

sub set {
    &App::sub_entry if ($App::trace);
    my ($self, $key, $value, $options) = @_;
    $self->{data}{$key} = $value;
    &App::sub_exit() if ($App::trace);
}

#############################################################################
# get()
#############################################################################

=head2 get()

    * Signature: $value = $sds->get($key);
    * Param:     $key               scalar
    * Return:    $value             scalar

    $value = $sds->get($key);

=cut

sub get {
    &App::sub_entry if ($App::trace);
    my ($self, $key) = @_;
    my $value = $self->{data}{$key};
    &App::sub_exit($value) if ($App::trace);
    return($value);
}

#############################################################################
# set_ref()
#############################################################################

=head2 set_ref()

    * Signature: $sds->set_ref($keyref,$valueref);
    * Signature: $sds->set_ref($keyref,$valueref,$options);
    * Param:     $keyref       anything (ref or scalar)
    * Param:     $valueref     anything (ref or scalar)
    * Param:     $options      HASH (optional)
    * Return:    void

    $sds->set_ref($keyref, $valueref);
    $options = {
        info_columns => [ "col1", "col2" ],
        info_values  => [ "value1", "value2" ],
    };
    $sds->set_ref($keyref, $valueref, $options);

=cut

sub set_ref {
    &App::sub_entry if ($App::trace);
    my ($self, $keyref, $valueref, $options) = @_;
    my $hashkey = $self->hashkey($keyref);
    my $blob = $self->serialize($valueref);
    $self->set($hashkey, $blob, $options);
    &App::sub_exit() if ($App::trace);
}

#############################################################################
# get_ref()
#############################################################################

=head2 get_ref()

    * Signature: $valueref = $sds->get_ref($keyref);
    * Param:     $keyref       anything (ref or scalar)
    * Return:    $valueref     anything (ref or scalar)

    $valueref = $sds->get_ref($keyref);

=cut

sub get_ref {
    &App::sub_entry if ($App::trace);
    my ($self, $keyref) = @_;
    my $hashkey = $self->hashkey($keyref);
    my $blob = $self->get($hashkey);
    my ($valueref);
    if (defined $blob) {
        eval {
            $valueref = $self->deserialize($blob);
        };
        # we want to catch errors in derialization which may occur due to version mismatches in the Storable module
        # (see "man Storable" in section on "FORWARD COMPATIBILITY")
        if ($@) {
            my $context = $self->{context};
            $context->log("WARNING: DataStore($self->{name})->get_ref($hashkey): $@");
        }
    }
    &App::sub_exit($valueref) if ($App::trace);
    return($valueref);
}

#############################################################################
# serialize()
#############################################################################

=head2 serialize()

    * Signature: $blob = $sds->serialize($ref);
    * Return:    $ref          any (ref)
    * Return:    $blob         scalar (binary)

    $blob = $sds->serialize($ref);

=cut

sub serialize {
    &App::sub_entry if ($App::trace);
    my ($self, $ref) = @_;
    my ($blob);
    if (defined $ref) {
        $blob = nfreeze($ref);
        if ($self->{compress}) {
            $blob = Compress::Zlib::memGzip($blob);
        }
        if ($self->{base64}) {
            $blob = MIME::Base64::encode($blob);
        }
    }
    else {
        $blob = undef;
    }
    &App::sub_exit("") if ($App::trace);
    return($blob);
}

#############################################################################
# deserialize()
#############################################################################

=head2 deserialize()

    * Signature: $ref = $sds->deserialize($blob);
    * Param:     $blob         scalar (binary)
    * Return:    $ref          any (ref)


    $ref = $sds->deserialize($blob);

=cut

sub deserialize {
    &App::sub_entry if ($App::trace);
    my ($self, $blob) = @_;
    my ($ref);
    if (defined $blob) {
        if ($self->{base64}) {
            $blob = MIME::Base64::decode($blob);
        }
        if ($self->{compress}) {
            $blob = Compress::Zlib::memGunzip($blob);
        }
        $ref = thaw($blob);
    }
    else {
        $ref = undef;
    }
    &App::sub_exit($ref) if ($App::trace);
    return($ref);
}

#############################################################################
# hashkey()
#############################################################################

=head2 hashkey()

    * Signature: $hashkey = $sds->hashkey($keyref);
    * Return:    $keyref       any (ref or scalar)
    * Return:    $hashkey      scalar

    $hashkey = $sds->hashkey($keyref);

=cut

sub hashkey {
    &App::sub_entry if ($App::trace);
    my ($self, $keyref) = @_;
    my ($hashkey);
    if (ref($keyref)) {
        $hashkey = sha1_hex(nfreeze($keyref));
    }
    elsif (length($keyref) == 40 && $keyref =~ /^[a-f0-9]+$/) {
        $hashkey = $keyref;
    }
    else {
        $hashkey = sha1_hex($keyref);
    }
    &App::sub_exit($hashkey) if ($App::trace);
    return($hashkey);
}

#############################################################################
# PROTECTED METHODS
#############################################################################

=head1 Protected Methods:

=cut

#############################################################################
# Method: service_type()
#############################################################################

=head2 service_type()

Returns "SharedDatastore";

    * Signature: $service_type = App::SharedDatastore->service_type();
    * Param:     void
    * Return:    $service_type  string

    $service_type = $sds->service_type();

=cut

sub service_type () { "SharedDatastore"; }

=head1 ACKNOWLEDGEMENTS

 * Author:  Stephen Adkins
 * License: This is free software. It is licensed under the same terms as Perl itself.

=head1 SEE ALSO

L|App::Context>,
L|App::Service>

=cut

1;