File Coverage

blib/lib/Memoize/Saves.pm
Criterion Covered Total %
statement 29 58 50.0
branch 9 30 30.0
condition 4 11 36.3
subroutine 6 6 100.0
pod n/a
total 48 105 45.7


line stmt bran cond sub pod time code
1 1     1   8646 use strict; use warnings;
  1     1   2  
  1         24  
  1         5  
  1         1  
  1         552  
2              
3             package Memoize::Saves;
4             our $VERSION = '0.700';
5              
6             our $DEBUG;
7              
8             sub TIEHASH
9             {
10 1     1   77 my ($package, %args) = @_;
11 1   50     5 my $cache = $args{HASH} || {};
12              
13             # Convert the CACHE to a referenced hash for quick lookup
14             #
15 1 50       4 if( $args{CACHE} )
16             {
17 0         0 my %hash;
18 0 0       0 $args{CACHE} = [ $args{CACHE} ] unless ref $args{CACHE} eq "ARRAY";
19 0         0 foreach my $value ( @{$args{CACHE}} )
  0         0  
20             {
21 0         0 $hash{$value} = 1;
22             }
23 0         0 $args{CACHE} = \%hash;
24             }
25              
26             # Convert the DUMP list to a referenced hash for quick lookup
27             #
28 1 50       3 if( $args{DUMP} )
29             {
30 0         0 my %hash;
31 0 0       0 $args{DUMP} = [ $args{DUMP} ] unless ref $args{DUMP} eq "ARRAY";
32 0         0 foreach my $value ( @{$args{DUMP}} )
  0         0  
33             {
34 0         0 $hash{$value} = 1;
35             }
36 0         0 $args{DUMP} = \%hash;
37             }
38              
39 1 50       4 if ($args{TIE})
40             {
41 0         0 my ($module, @opts) = @{$args{TIE}};
  0         0  
42 0         0 my $modulefile = $module . '.pm';
43 0         0 $modulefile =~ s{::}{/}g;
44 0         0 eval { require $modulefile };
  0         0  
45 0 0       0 if ($@) {
46 0         0 die "Memoize::Saves: Couldn't load hash tie module `$module': $@; aborting";
47             }
48 0         0 my $rc = (tie %$cache => $module, @opts);
49 0 0       0 unless ($rc) {
50 0         0 die "Memoize::Saves: Couldn't tie hash to `$module': $@; aborting";
51             }
52             }
53              
54 1         2 $args{C} = $cache;
55 1         5 bless \%args => $package;
56             }
57              
58             sub EXISTS
59             {
60 2     2   1180 my $self = shift;
61 2         4 my $key = shift;
62              
63 2 100       6 if( exists $self->{C}->{$key} )
64             {
65 1         3 return 1;
66             }
67              
68 1         2 return 0;
69             }
70              
71              
72             sub FETCH
73             {
74 1     1   6 my $self = shift;
75 1         2 my $key = shift;
76              
77 1         6 return $self->{C}->{$key};
78             }
79              
80             sub STORE
81             {
82 1     1   15 my $self = shift;
83 1         2 my $key = shift;
84 1         2 my $value = shift;
85              
86             # If CACHE defined and this is not in our list don't save it
87             #
88 1 50 33     4 if(( defined $self->{CACHE} )&&
89             ( ! defined $self->{CACHE}->{$value} ))
90             {
91 0 0       0 print "$value not in CACHE list.\n" if $DEBUG;
92 0         0 return;
93             }
94              
95             # If DUMP is defined and this is in our list don't save it
96             #
97 1 50 33     5 if(( defined $self->{DUMP} )&&
98             ( defined $self->{DUMP}->{$value} ))
99             {
100 0 0       0 print "$value in DUMP list.\n" if $DEBUG;
101 0         0 return;
102             }
103              
104             # If REGEX is defined we will store it only if its true
105             #
106 1 50 33     26 if(( defined $self->{REGEX} )&&
107             ( $value !~ /$self->{REGEX}/ ))
108             {
109 0 0       0 print "$value did not match regex.\n" if $DEBUG;
110 0         0 return;
111             }
112              
113             # If we get this far we should save the value
114             #
115 1 50       4 print "Saving $key:$value\n" if $DEBUG;
116 1         5 $self->{C}->{$key} = $value;
117             }
118              
119             1;
120              
121             __END__