File Coverage

blib/lib/MongoDBx/Tiny/Plugin/SingleByCache.pm
Criterion Covered Total %
statement 12 39 30.7
branch 0 16 0.0
condition 0 9 0.0
subroutine 4 6 66.6
pod 2 2 100.0
total 18 72 25.0


line stmt bran cond sub pod time code
1             package MongoDBx::Tiny::Plugin::SingleByCache;
2              
3 2     2   3237 use strict;
  2         4  
  2         62  
4 2     2   10 use warnings;
  2         3  
  2         56  
5              
6             =head1 NAME
7              
8             MongoDBx::Tiny::Plugin::SingleByCache - find via cache
9              
10             =head1 SYNOPSIS
11              
12             # --------------------
13             package Your::Data;
14             use MongoDBx::Tiny;
15             # ~ snip ~
16             LOAD_PLUGIN "SingleByCache";
17              
18             # --------------------
19              
20             $object = $tiny->single_by_cache('collection_name',{ query => 'value'});
21            
22             $object = $tiny->single_by_cache('collection_name',{ query => 'value'},
23             { cache => $cache, cache_key => $key });
24              
25             #
26             # $cache need to have get, set and delete method.
27             # you can also set default $cache defining it as "tiny::get_cache"
28             #
29              
30              
31             =cut
32              
33 2     2   11 use Carp;
  2         3  
  2         116  
34 2     2   1371 use Digest::SHA;
  2         4602  
  2         920  
35              
36             =head1 EXPORT
37              
38             =cut
39              
40             our @EXPORT = qw(single_by_cache single_by_cache_key);
41              
42             =head2 single_by_cache
43              
44             =cut
45              
46             sub single_by_cache {
47 0     0 1   my $self = shift;
48 0           my ($c_name,$proto,$opt) = @_;
49 0           my $cache = delete $opt->{cache};
50 0           my $key = delete $opt->{cache_key};
51              
52 0 0 0       if (!$cache && $self->can('get_cache')) {
    0 0        
53 0           $cache = $self->get_cache;
54             } elsif (!$cache && ! $self->can('get_cache')){
55 0           Carp::confess("get_cache is abstract method, define yours.");
56             }
57              
58 0 0 0       if (!$cache->can('get') or !$cache->can('set')) {
59 0           Carp::confess("invalid cache object: get and set methods are needed");
60             }
61              
62 0 0         if (!$key) {
63 0           $key = $self->single_by_cache_key($c_name,$proto);
64             }
65 0           my $document = $cache->get($key);
66 0 0         if ($document) {
67 0           return $self->document_to_object($c_name,$document);
68             }
69 0           my $object = $self->single($c_name,$proto);
70 0 0         if (defined $object) {
71 0 0         $cache->set($key,$object->object_to_document) or Carp::confess $!;
72             }
73 0           return $object;
74             }
75              
76             =head2 single_by_cache_key
77              
78             =cut
79              
80             sub single_by_cache_key {
81 0     0 1   my $self = shift;
82 0           my $c_name = shift;
83 0           my $query = shift;
84              
85 0 0         unless (ref $query eq 'HASH') {
86 0           $query = { _id => "$query" };
87             }
88              
89 0           my $key_str;
90 0           while (my ($key,$value) = each %$query) {
91 0           $key_str .= sprintf "%s::%s",$key,"$value";
92             }
93 0           return sprintf "%s::single_by_cache::%s::%s",
94             ref $self,$c_name,Digest::SHA::sha1_hex($key_str);
95              
96             }
97              
98             1;
99             __END__
100              
101             =head1 AUTHOR
102              
103             Naoto ISHIKAWA, C<< <toona at seesaa.co.jp> >>
104              
105             =head1 LICENSE AND COPYRIGHT
106              
107             Copyright 2013 Naoto ISHIKAWA.
108              
109             This program is free software; you can redistribute it and/or modify it
110             under the terms of either: the GNU General Public License as published
111             by the Free Software Foundation; or the Artistic License.
112              
113             See http://dev.perl.org/licenses/ for more information.
114              
115              
116             =cut
117