File Coverage

blib/lib/Log/Message/JSON/Hash.pm

Criterion	Covered	Total	%
statement	34	44	77.2
branch	4	8	50.0
condition			n/a
subroutine	12	16	75.0
pod	2	2	100.0
total	52	70	74.2

#!/usr/bin/perl

=head1 NAME

Log::Message::JSON::Hash - L wrapper supporting storing cache

=head1 SYNOPSIS

  use Log::Message::JSON::Hash;
  use JSON;

  tie my %hash, "Log::Message::JSON::Hash";
  # fill %hash...
  tied(%hash)->cache = encode_json(\%hash);

  # ...

  print tied(%hash)->cache;

=head1 DESCRIPTION

This class is a proxy to L. It's a valid class to tie hash to,
and above this the class adds possibility of storing a cache.

The cache is cleared on every destructive operation (storing an element,
deleting an element and clearing whole hash).

=cut

#-----------------------------------------------------------------------------

package Log::Message::JSON::Hash;

use warnings;
use strict;

use Tie::IxHash;
use Carp;

#-----------------------------------------------------------------------------

=head1 API

=head2 Own Methods

=over

=cut

#-----------------------------------------------------------------------------

=item C<< new() >>

Constructor.

=cut

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

  my $tied = tie my %val, "Tie::IxHash";

  my $self = bless {
    tied_object => $tied,
    cache => undef,
  }, $class;

  return $self;
}

=item C

=item C

Get or set cache for this object.

Cache will be cleared on any destructive operation performed on this object.

=cut

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

  if (defined $cache) {
    $self->{cache} = $cache;
  }

  return $self->{cache};
}

=back

=cut

#-----------------------------------------------------------------------------

=head2 Methods Satisfying C API

All the rest of methods are defined to satisfy API for C function. They
call appropriate methods of underlying L object.

=cut

#-----------------------------------------------------------------------------

=begin InternalDocs

=head3 Creating and destroying objects

=over

=cut

#-----------------------------------------------------------------------------

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

  return $class->new(@args);
}

sub UNTIE {
  my ($self, @args) = @_;

  $self->{tied_object}->UNTIE(@args);
  $self->{cache} = undef;
}

=back

=cut

#-----------------------------------------------------------------------------

=head3 Altering object's data

=over

=cut

#-----------------------------------------------------------------------------

sub STORE {
  my ($self, @args) = @_;

  $self->{cache} = undef if defined $self->{cache};

  $self->{tied_object}->STORE(@args);
}

sub DELETE {
  my ($self, @args) = @_;

  $self->{cache} = undef if defined $self->{cache};

  $self->{tied_object}->DELETE(@args);
}

sub CLEAR {
  my ($self, @args) = @_;

  $self->{cache} = undef if defined $self->{cache};

  $self->{tied_object}->CLEAR(@args);
}

=back

=cut

#-----------------------------------------------------------------------------

=head3 Reading object's data

=over

=cut

#-----------------------------------------------------------------------------

sub FETCH {
  my ($self, @args) = @_;

  $self->{tied_object}->FETCH(@args);
}

sub EXISTS {
  my ($self, @args) = @_;

  $self->{tied_object}->EXISTS(@args);
}

sub FIRSTKEY {
  my ($self, @args) = @_;

  $self->{tied_object}->FIRSTKEY(@args);
}

sub NEXTKEY {
  my ($self, @args) = @_;

  $self->{tied_object}->NEXTKEY(@args);
}

sub SCALAR {
  my ($self, @args) = @_;

  $self->{tied_object}->SCALAR(@args);
}

=back

=end InternalDocs

=cut

#-----------------------------------------------------------------------------

=head1 AUTHOR

Stanislaw Klekot, C<<  >>

=head1 LICENSE AND COPYRIGHT

Copyright 2013 Stanislaw Klekot.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=head1 SEE ALSO

L, L, C in L

=cut

#-----------------------------------------------------------------------------
1;
# vim:ft=perl