File Coverage

blib/lib/Devel/DumpTrace/CachedDisplayedHash.pm
Criterion Covered Total %
statement 11 57 19.3
branch 0 2 0.0
condition 2 3 66.6
subroutine 4 16 25.0
pod 0 4 0.0
total 17 82 20.7


line stmt bran cond sub pod time code
1             #
2             # tied hash object that maintains two additional states:
3             # 1. a parallel hash table where all original keys and values
4             # are run through &Devel::DumpTrade::dump_scalar
5             # 2. a cache of results from Text::Shorten::shorten_hash
6             #
7             # Calls to Devel::DumpTrace::hash_repr should not trigger calls
8             # to Text::Shorten::shorten_hash unless the hash table
9             # has been updated since the last shorten_hash call.
10             #
11              
12             package Devel::DumpTrace::CachedDisplayedHash;
13              
14 16     16   115 use strict;
  16         35  
  16         520  
15 16     16   88 use warnings;
  16         34  
  16         388  
16 16     16   77 use Carp;
  16         146  
  16         11597  
17             our $VERSION = '0.29';
18              
19             *dump_scalar = \&Devel::DumpTrace::dump_scalar;
20              
21              
22             sub TIEHASH {
23 0     0   0 my ($class, @list) = @_;
24              
25             # HASH: the original and primary hash table
26              
27             # PHASH: copy of HASH where all keys and values are
28             # filtered through Devel::DumpTrace::dump_scalar;
29              
30             # CACHE: store of results from Text::Shorten. Keys are
31             # auxiliary arguments to Text::Shorten::shorten_hash,
32             # values are array refs of shorten_hash return values.
33             # Cache is cleared when any element of the hash
34             # is changed.
35              
36             my $self = {
37             CACHE => {},
38             HASH => { @list },
39 0         0 PHASH => { map { dump_scalar($_) } @list }
  0         0  
40             };
41 0         0 return bless $self, $class;
42             }
43              
44             sub FETCH {
45 0     0   0 my ($self, $key) = @_;
46 0         0 return $self->{HASH}{$key};
47             }
48              
49             sub STORE {
50 0     0   0 my ($self, $key, $value) = @_;
51 0         0 $self->clear_cache;
52 0         0 my $old = $self->{HASH}{$key};
53 0         0 $self->{HASH}{$key} = $value;
54 0         0 $self->{PHASH}{dump_scalar($key)} = dump_scalar($value);
55 0         0 return $old;
56             }
57              
58             sub DELETE {
59 0     0   0 my ($self, $key) = @_;
60 0         0 $self->clear_cache;
61 0         0 delete $self->{PHASH}{dump_scalar($key)};
62 0         0 return delete $self->{HASH}{$key};
63             }
64              
65             sub CLEAR {
66 0     0   0 my $self = shift;
67 0         0 $self->clear_cache;
68 0         0 $self->{PHASH} = {};
69 0         0 $self->{HASH} = {};
70 0         0 return;
71             }
72              
73             sub EXISTS {
74 0     0   0 my ($self, $key) = @_;
75 0         0 return exists $self->{HASH}{$key};
76             }
77              
78             sub FIRSTKEY {
79 0     0   0 my $self = shift;
80 0         0 scalar keys %{$self->{HASH}};
  0         0  
81 0         0 return each %{$self->{HASH}};
  0         0  
82             }
83              
84             sub NEXTKEY {
85 0     0   0 my ($self, $lastkey) = @_;
86 0         0 return each %{$self->{HASH}};
  0         0  
87             }
88              
89             sub SCALAR {
90 0     0   0 my $self = shift;
91 0         0 return scalar %{$self->{HASH}};
  0         0  
92             }
93              
94             # sub UNTIE { } # not implemented
95             # sub DESTROY { } # not implemented
96              
97             sub clear_cache {
98 0     0 0 0 my $self = shift;
99 0         0 $self->{CACHE} = {};
100 0         0 return;
101             }
102              
103             sub store_cache {
104 0     0 0 0 my ($self, $key, $value) = @_;
105 0         0 $self->{CACHE}{$key} = $value;
106 0 0       0 if ($Devel::DumpTrace::HASHREPR_SORT) {
107 0         0 my %h = @$value;
108 0         0 $value = [ map { $_ => $h{$_} } sort keys %h ];
  0         0  
109             }
110 0         0 return;
111             }
112              
113             sub get_cache {
114 0     0 0 0 my ($self, $key) = @_;
115 0         0 return $self->{CACHE}{$key};
116             }
117              
118             sub is {
119 162     162 0 351 my ($pkg, $hashref) = @_;
120 162   66     744 return tied(%$hashref) && ref(tied(%$hashref)) eq $pkg;
121             }
122              
123             1;