File Coverage

blib/lib/Net/DRI/Cache.pm
Criterion Covered Total %
statement 56 63 88.8
branch 21 34 61.7
condition 6 12 50.0
subroutine 10 11 90.9
pod 3 6 50.0
total 96 126 76.1


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, local global cache
2             ##
3             ## Copyright (c) 2005,2008,2009,2011,2013 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             #########################################################################################
14              
15             package Net::DRI::Cache;
16              
17 76     76   561 use strict;
  76         68  
  76         1557  
18 76     76   200 use warnings;
  76         61  
  76         1496  
19              
20 76     76   204 use base qw(Class::Accessor::Chained::Fast);
  76         70  
  76         32010  
21             __PACKAGE__->mk_accessors(qw/ttl/);
22              
23 76     76   274772 use Net::DRI::Util;
  76         150  
  76         2448  
24 76     76   404 use Net::DRI::Exception;
  76         78  
  76         30137  
25              
26             =pod
27              
28             =head1 NAME
29              
30             Net::DRI::Cache - Local cache for Net::DRI
31              
32             =head1 DESCRIPTION
33              
34             Please see the README file for details.
35              
36             =head1 SUPPORT
37              
38             For now, support questions should be sent to:
39              
40             Enetdri@dotandco.comE
41              
42             Please also see the SUPPORT file in the distribution.
43              
44             =head1 SEE ALSO
45              
46             Ehttp://www.dotandco.com/services/software/Net-DRI/E
47              
48             =head1 AUTHOR
49              
50             Patrick Mevzek, Enetdri@dotandco.comE
51              
52             =head1 COPYRIGHT
53              
54             Copyright (c) 2005,2008,2009,2011,2013 Patrick Mevzek .
55             All rights reserved.
56              
57             This program is free software; you can redistribute it and/or modify
58             it under the terms of the GNU General Public License as published by
59             the Free Software Foundation; either version 2 of the License, or
60             (at your option) any later version.
61              
62             See the LICENSE file that comes with this distribution for more details.
63              
64             =cut
65              
66             ####################################################################################################
67             sub new
68             {
69 71     71 1 597 my ($c,$ttl)=@_;
70              
71 71         258 my $self={
72             ttl => $ttl, ## if negative, never use cache
73             data => {},
74             };
75              
76 71         1706 bless($self,$c);
77 71         721 return $self;
78             }
79              
80             sub set
81             {
82 25     25 1 696 my ($self,$regname,$type,$key,$data,$ttl)=@_;
83 25 50       51 Net::DRI::Exception::err_insufficient_parameters() unless Net::DRI::Util::all_valid($regname,$type,$key);
84              
85 25         49 my $now=Net::DRI::Util::microtime();
86 25 100       62 $ttl=$self->{ttl} unless defined($ttl);
87 25 50       59 my $until=($ttl==0)? 0 : $now+1000000*$ttl;
88 25         68 my %c=(_on => $now,
89             _from => $regname,
90             _until => $until,
91             );
92              
93 25 50 33     106 if ($data && (ref $data eq 'HASH'))
94             {
95 25         66 while(my ($k,$v)=each(%$data))
96             {
97 110         262 $c{$k}=$v;
98             }
99             }
100              
101 25 100       52 if ($self->{ttl} >= 0) ## we really store something
102             {
103 4 100       11 $self->{data}->{$type}={} unless exists $self->{data}->{$type};
104             ## We store only the last version of a given key, so start from scratch
105 4         8 $self->{data}->{$type}->{$key}=\%c;
106             }
107              
108 25         55 return \%c;
109             }
110              
111             sub set_result_from_cache
112             {
113 0     0 0 0 my ($self,$type,$key)=@_;
114 0 0       0 Net::DRI::Exception::err_insufficient_parameters() unless Net::DRI::Util::all_valid($type,$key);
115 0 0       0 return unless exists $self->{data}->{$type};
116 0         0 $self->{data}->{$type}->{$key}->{result_from_cache}=1;
117 0         0 return;
118             }
119              
120             sub get
121             {
122 10     10 1 24 my ($self,$type,$key,$data,$from)=@_;
123              
124 10 100       37 return if ($self->{ttl} < 0);
125 5 50       17 Net::DRI::Exception::err_insufficient_parameters() unless Net::DRI::Util::all_valid($type,$key);
126 5         15 ($type,$key)=Net::DRI::Util::normalize_name($type,$key);
127 5 50       18 return unless exists $self->{data}->{$type};
128 5 50       11 return unless exists $self->{data}->{$type}->{$key};
129              
130 5         7 my $c=$self->{data}->{$type}->{$key};
131              
132 5 100 66     18 if ($c->{_until} > 0 && (Net::DRI::Util::microtime() > $c->{_until}))
133             {
134 1         4 delete $self->{data}->{$type}->{$key};
135 1         10 return;
136             }
137              
138 4 100 66     19 return if (defined $from && ($c->{_from} ne $from));
139              
140 3 50       5 if (defined $data)
141             {
142 3 50       17 return $c->{$data} if exists $c->{$data};
143             } else
144             {
145 0         0 return $c;
146             }
147              
148 0         0 return;
149             }
150              
151             sub delete_expired
152             {
153 1     1 0 2 my $self=shift;
154 1         3 my $now=Net::DRI::Util::microtime();
155 1         2 my $c=$self->{data};
156 1         6 while(my ($type,$c1)=each(%$c))
157             {
158 1         2 while(my ($key,$c2)=each(%{$c1}))
  2         8  
159             {
160 1 50 33     12 delete $c->{$type}->{$key} if ($c2->{_until} > 0 && ($now > $c2->{_until}));
161             }
162             }
163 1         2 return;
164             }
165              
166             sub delete ## no critic (Subroutines::ProhibitBuiltinHomonyms)
167             {
168 1     1 0 2 my $self=shift;
169 1         2 $self->{data}={};
170 1         4 return;
171             }
172              
173             ####################################################################################################
174             1;