File Coverage

blib/lib/Scalar/Accessors/LikeHash.pm
Criterion Covered Total %
statement 61 62 98.3
branch 20 34 58.8
condition 10 21 47.6
subroutine 15 15 100.0
pod 8 8 100.0
total 114 140 81.4


line stmt bran cond sub pod time code
1             package Scalar::Accessors::LikeHash;
2              
3 3     3   9089 use 5.008;
  3         14  
  3         128  
4 3     3   19 use strict;
  3         7  
  3         160  
5 3     3   17 use warnings;
  3         16  
  3         128  
6              
7 3     3   16 use Carp qw(croak);
  3         7  
  3         175  
8 3     3   17 use Role::Tiny;
  3         5  
  3         31  
9 3     3   514 use Scalar::Util qw(blessed);
  3         8  
  3         3046  
10              
11             our $AUTHORITY = 'cpan:TOBYINK';
12             our $VERSION = '0.002';
13              
14             requires qw( _to_hash _from_hash );
15              
16             sub new
17             {
18 4 50   4 1 3288 my $class = blessed($_[0]) ? ref(shift) : shift;
19            
20 4 50       20 croak "Class $class does not implement a constructor"
21             unless $class->does(__PACKAGE__);
22            
23 0         0 return bless(ref $_ ? \${$_} : \$_, $class)
24 4 50       6694 for (@_, $class->_empty_structure);
25             }
26              
27             sub _empty_structure
28             {
29 3     3   7 my $class = shift;
30 3         22 $class->can('_from_hash')->(\(my $r), {});
31 3         23 return $r;
32             }
33              
34             sub fetch
35             {
36 6     6 1 18 my $invocant = shift;
37 6 100       19 my $ref = (not ref $invocant) ? shift : $invocant;
38 6 50 66     39 $invocant = __PACKAGE__ if ref $invocant && ! blessed $invocant;
39            
40 6         36 $invocant->can('_to_hash')->($ref)->{ $_[0] };
41             }
42              
43             sub store
44             {
45 10     10 1 2329 my $invocant = shift;
46 10 100       29 my $ref = (not ref $invocant) ? shift : $invocant;
47 10 50 66     682 $invocant = __PACKAGE__ if ref $invocant && ! blessed $invocant;
48            
49 10         59 my $hash = $invocant->can('_to_hash')->($ref);
50 10         30 $hash->{ $_[0] } = $_[1];
51 10         52 $invocant->can('_from_hash')->($ref, $hash);
52 10         53 return;
53             }
54              
55             sub exists
56             {
57 10     10 1 49 my $invocant = shift;
58 10 50       38 my $ref = (not ref $invocant) ? shift : $invocant;
59 10 50 33     68 $invocant = __PACKAGE__ if ref $invocant && ! blessed $invocant;
60            
61 10         49 exists $invocant->can('_to_hash')->($ref)->{ $_[0] };
62             }
63              
64             sub values
65             {
66 2     2 1 5 my $invocant = shift;
67 2 50       24 my $ref = (not ref $invocant) ? shift : $invocant;
68 2 50 33     22 $invocant = __PACKAGE__ if ref $invocant && ! blessed $invocant;
69            
70 2         12 my $hash = $invocant->can('_to_hash')->($ref);
71 2         11 map { $hash->{$_} } sort keys %$hash;
  4         21  
72             }
73              
74             sub keys
75             {
76 10     10 1 16 my $invocant = shift;
77 10 100       25 my $ref = (not ref $invocant) ? shift : $invocant;
78 10 50 66     50 $invocant = __PACKAGE__ if ref $invocant && ! blessed $invocant;
79            
80 10         57 my $hash = $invocant->can('_to_hash')->($ref);
81 10         82 sort keys %$hash;
82             }
83              
84             sub delete
85             {
86 2     2 1 5 my $invocant = shift;
87 2 50       11 my $ref = (not ref $invocant) ? shift : $invocant;
88 2 50 33     37 $invocant = __PACKAGE__ if ref $invocant && ! blessed $invocant;
89            
90 2         15 my $hash = $invocant->can('_to_hash')->($ref);
91 2         8 my $r = CORE::delete($hash->{ $_[0] });
92 2         14 $invocant->can('_from_hash')->($ref, $hash);
93 2         16 return $r;
94             }
95              
96             sub clear
97             {
98 2     2 1 4 my $invocant = shift;
99 2 50       10 my $ref = (not ref $invocant) ? shift : $invocant;
100 2 50 33     26 $invocant = __PACKAGE__ if ref $invocant && ! blessed $invocant;
101            
102 2         9 $$ref = $invocant->_empty_structure;
103             }
104              
105             1;
106              
107             __END__
108              
109             =head1 NAME
110              
111             Scalar::Accessors::LikeHash - access a JSON/Sereal/etc scalar string in a hash-like manner
112              
113             =head1 SYNOPSIS
114              
115             {
116             package Acme::Storable::Accessors;
117            
118             use Storable qw/ freeze thaw /;
119            
120             use Role::Tiny::With;
121             with 'Scalar::Accessors::LikeHash';
122            
123             sub _to_hash {
124             my ($ref) = @_;
125             thaw($$ref);
126             }
127            
128             sub _from_hash {
129             my ($ref, $hash) = @_;
130             $$ref = freeze($hash);
131             }
132             }
133            
134             my $string = File::Slurp::slurp("some-data.storable");
135             my $object = Acme::Storable::Accessors->new(\$string);
136            
137             $object->store(some_key => 42) unless $object->exists('some_key');
138             $object->fetch('some_key');
139             $object->delete('some_key');
140              
141             =head1 DESCRIPTION
142              
143             The idea of this is to treat a reference to a string as if it were a hash.
144             You can store key-values pairs; fetch values using keys; delete keys; etc.
145             This is slow and quite silly.
146              
147             This module is a role. Concrete implementations of the role need to provide
148             C<< _from_hash >> and C<< _to_hash >> methods to serialize and deserialize
149             a hashref to/from a scalarref.
150              
151             This role provides the following methods:
152              
153             =over
154              
155             =item C<< new(\$scalar) >>
156              
157             Yes, this role provides a constructor. Consumers can overide it.
158              
159             =item C<< fetch($key) >>
160              
161             =item C<< store($key, $value) >>
162              
163             =item C<< exists($key) >>
164              
165             =item C<< delete($key) >>
166              
167             =item C<< clear() >>
168              
169             Delete for each key.
170              
171             =item C<< keys() >>
172              
173             =item C<< values() >>
174              
175             =back
176              
177             These can be called as methods on a blessed scalar reference:
178              
179             my $string = "{}";
180             bless \$string, "Scalar::Accessors::LikeHash::JSON";
181             $string->store(foo => 42);
182              
183             Or as class methods passing the scalar reference as an extra first argument:
184              
185             my $string = "{}";
186             Scalar::Accessors::LikeHash::JSON->store(\$string, foo => 42);
187              
188             =head1 BUGS
189              
190             Please report any bugs to
191             L<http://rt.cpan.org/Dist/Display.html?Queue=Scalar-Accessors-LikeHash>.
192              
193             =head1 SEE ALSO
194              
195             For a more usable interface, see L<Tie::Hash::SerializedString>.
196              
197             For concrete implementations, see L<Scalar::Accessors::LikeHash::JSON>
198             and L<Scalar::Accessors::LikeHash::Sereal>.
199              
200             For an insane usage of this concept, see L<Acme::MooseX::JSON>.
201              
202             =head1 AUTHOR
203              
204             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
205              
206             =head1 COPYRIGHT AND LICENCE
207              
208             This software is copyright (c) 2013 by Toby Inkster.
209              
210             This is free software; you can redistribute it and/or modify it under
211             the same terms as the Perl 5 programming language system itself.
212              
213             =head1 DISCLAIMER OF WARRANTIES
214              
215             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
216             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
217             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
218