File Coverage

blib/lib/Data/Hive/Store/Param.pm
Criterion Covered Total %
statement 50 50 100.0
branch 4 4 100.0
condition 6 11 54.5
subroutine 15 15 100.0
pod 8 9 88.8
total 83 89 93.2


line stmt bran cond sub pod time code
1 1     1   482 use strict;
  1         2  
  1         31  
2 1     1   5 use warnings;
  1         2  
  1         43  
3             package Data::Hive::Store::Param 1.014;
4             # ABSTRACT: CGI::param-like store for Data::Hive
5              
6 1     1   475 use parent 'Data::Hive::Store';
  1         325  
  1         6  
7              
8             #pod =head1 DESCRIPTION
9             #pod
10             #pod This hive store will soon be overhauled.
11             #pod
12             #pod Basically, it expects to access a hive in an object with CGI's C method,
13             #pod or the numerous other things with that interface.
14             #pod
15             #pod =method new
16             #pod
17             #pod # use default method name 'param'
18             #pod my $store = Data::Hive::Store::Param->new($obj);
19             #pod
20             #pod # use different method name 'info'
21             #pod my $store = Data::Hive::Store::Param->new($obj, { method => 'info' });
22             #pod
23             #pod # escape certain characters in keys
24             #pod my $store = Data::Hive::Store::Param->new($obj, { escape => './!' });
25             #pod
26             #pod Return a new Param store.
27             #pod
28             #pod Several interesting arguments can be passed in a hashref after the first
29             #pod (mandatory) object argument.
30             #pod
31             #pod =begin :list
32             #pod
33             #pod = method
34             #pod
35             #pod Use a different method name on the object (default is 'param').
36             #pod
37             #pod This method should have the "usual" behavior for a C method:
38             #pod
39             #pod =for :list
40             #pod * calling C<< $obj->param >> with no arguments returns all param names
41             #pod * calling C<< $obj->param($name) >> returns the value for that name
42             #pod * calling C<< $obj->param($name, $value) >> sets the value for the name
43             #pod
44             #pod The Param store does not check the types of values, but for interoperation with
45             #pod other stores, sticking to simple scalars is a good idea.
46             #pod
47             #pod = path_packer
48             #pod
49             #pod This is an object providing the L interface. It will
50             #pod convert a string to a path (arrayref) or the reverse. It defaults to a
51             #pod L.
52             #pod
53             #pod = exists
54             #pod
55             #pod This is a coderef used to check whether a given parameter name exists. It will
56             #pod be called as a method on the Data::Hive::Store::Param object with the path name
57             #pod as its argument.
58             #pod
59             #pod The default behavior gets a list of all parameters and checks whether the given
60             #pod name appears in it.
61             #pod
62             #pod = delete
63             #pod
64             #pod This is a coderef used to delete the value for a path from the hive. It will
65             #pod be called as a method on the Data::Hive::Store::Param object with the path name
66             #pod as its argument.
67             #pod
68             #pod The default behavior is to call the C method on the object providing
69             #pod the C method.
70             #pod
71             #pod =end :list
72             #pod
73             #pod =cut
74              
75 218     218 1 520 sub path_packer { $_[0]{path_packer} }
76              
77 76     76 1 157 sub name { $_[0]->path_packer->pack_path($_[1]) }
78              
79             sub new {
80 2     2 1 6 my ($class, $obj, $arg) = @_;
81 2   50     9 $arg ||= {};
82              
83             my $guts = {
84             obj => $obj,
85              
86             path_packer => $arg->{path_packer} || do {
87             require Data::Hive::PathPacker::Strict;
88             Data::Hive::PathPacker::Strict->new;
89             },
90              
91             method => $arg->{method} || 'param',
92              
93             exists => $arg->{exists} || sub {
94 28     28   50 my ($self, $key) = @_;
95 28         58 my $method = $self->{method};
96 28         54 my $exists = grep { $key eq $_ } $self->param_store->$method;
  151         380  
97 28         142 return ! ! $exists;
98             },
99              
100             delete => $arg->{delete} || sub {
101 5     5   9 my ($self, $key) = @_;
102 5         12 $self->param_store->delete($key);
103             },
104 2   66     25 };
      50        
      50        
      50        
105              
106 2         35 return bless $guts => $class;
107             }
108              
109 93     93 0 326 sub param_store { $_[0]{obj} }
110              
111             sub _param {
112 42     42   62 my $self = shift;
113 42         67 my $meth = $self->{method};
114 42         84 my $path = $self->name(shift);
115 42         95 return $self->param_store->$meth($path, @_);
116             }
117              
118             sub get {
119 24     24 1 42 my ($self, $path) = @_;
120 24         50 return $self->_param($path);
121             }
122              
123             sub set {
124 18     18 1 47 my ($self, $path, $val) = @_;
125 18         42 return $self->_param($path => $val);
126             }
127            
128             sub exists {
129 28     28 1 50 my ($self, $path) = @_;
130 28         45 my $code = $self->{exists};
131 28         58 my $key = $self->name($path);
132              
133 28         67 return $self->$code($key);
134             }
135              
136             sub delete {
137 5     5 1 10 my ($self, $path) = @_;
138 5         10 my $code = $self->{delete};
139 5         12 my $key = $self->name($path);
140              
141 5         13 return $self->$code($key);
142             }
143              
144             sub keys {
145 18     18 1 33 my ($self, $path) = @_;
146              
147 18         40 my $method = $self->{method};
148 18         33 my @names = $self->param_store->$method;
149              
150 18         118 my %is_key;
151              
152 18         37 PATH: for my $name (@names) {
153 142         235 my $this_path = $self->path_packer->unpack_path($name);
154              
155 142 100       347 next unless @$this_path > @$path;
156              
157 58         118 for my $i (0 .. $#$path) {
158 71 100       169 next PATH unless $this_path->[$i] eq $path->[$i];
159             }
160              
161 28         79 $is_key{ $this_path->[ $#$path + 1 ] } = 1;
162             }
163              
164 18         131 return keys %is_key;
165             }
166              
167             1;
168              
169             __END__