File Coverage

blib/lib/Data/Tumbler.pm
Criterion Covered Total %
statement 43 45 95.5
branch 13 14 92.8
condition n/a
subroutine 11 12 91.6
pod 5 5 100.0
total 72 76 94.7


line stmt bran cond sub pod time code
1             package Data::Tumbler;
2              
3 4     4   145817 use strict;
  4         6  
  4         100  
4 4     4   13 use warnings;
  4         4  
  4         158  
5              
6             =head1 NAME
7              
8             Data::Tumbler - Dynamic generation of nested combinations of variants
9              
10             =head1 SYNOPSIS
11              
12             $tumbler = Data::Tumbler->new(
13              
14             add_path => sub {
15             my ($path, $name) = @_;
16             return [ @$path, $name ];
17             },
18              
19             add_context => sub {
20             my ($context, $value) = @_;
21             return [ @$context, $value ]
22             },
23              
24             consumer => sub {
25             my ($path, $context, $payload) = @_;
26             print "@$path: @$context\n";
27             },
28             );
29              
30             $tumbler->tumble(
31             [ # provider code refs
32             sub { (red => 42, green => 24, mauve => 19) },
33             sub { (circle => 1, square => 2) },
34             # ...
35             ],
36             [], # initial path
37             [], # initial context
38             [], # initial payload
39             );
40              
41             The consumer code outputs:
42              
43             green circle: 24 1
44             green square: 24 2
45             mauve circle: 19 1
46             mauve square: 19 2
47             red circle: 42 1
48             red square: 42 2
49              
50             Here's a longer example showing more features:
51              
52             use List::Util qw(sum);
53              
54             $tumbler = Data::Tumbler->new(
55              
56             # The default add_path is as shown above
57             # The default add_context is as shown above
58              
59             consumer => sub {
60             my ($path, $context, $payload) = @_;
61             printf "path: %-20s context: %-12s payload: %s\n",
62             join("/", @$path),
63             join(", ", @$context),
64             join(", ", map { "$_=>$payload->{$_}" } sort keys %$payload);
65             },
66             );
67              
68             $tumbler->tumble(
69             [ # providers
70             sub {
71             my ($path, $context, $payload) = @_;
72              
73             my %variants = (red => 42, green => 24, mauve => 19);
74              
75             return %variants;
76             },
77             sub {
78             my ($path, $context, $payload) = @_;
79              
80             # change paint to matt based on context
81             $payload->{paint} = 'matt' if sum(@$context) > 20;
82              
83             my %variants = (circle => 10, square => 20);
84              
85             # add an extra triangular variant for mauve
86             $variants{triangle} = 13 if grep { $_ eq 'mauve' } @$path;
87              
88             return %variants;
89             },
90             sub {
91             my ($path, $context, $payload) = @_;
92              
93             # skip all variants if path contains anything red or circular
94             return if grep { $_ eq 'red' or $_ eq 'circle' } @$path;
95              
96             $payload->{spotty} = 1 if sum(@$context) > 35;
97              
98             my %variants = (small => 17, large => 92);
99              
100             return %variants;
101             },
102             # ...
103             ],
104             [], # initial path
105             [], # initial context
106             { paint => 'gloss' }, # initial payload
107             );
108              
109             The consumer code outputs:
110              
111             path: green/square/large context: 24, 20, 92 payload: paint=>matt, spotty=>1
112             path: green/square/small context: 24, 20, 17 payload: paint=>matt, spotty=>1
113             path: mauve/square/large context: 19, 20, 92 payload: paint=>gloss, spotty=>1
114             path: mauve/square/small context: 19, 20, 17 payload: paint=>gloss, spotty=>1
115             path: mauve/triangle/large context: 19, 13, 92 payload: paint=>gloss
116             path: mauve/triangle/small context: 19, 13, 17 payload: paint=>gloss
117              
118             =head1 DESCRIPTION
119              
120             NOTE: This is alpha code and liable to change while it and L
121             mature.
122              
123             The tumble() method calls a sequence of 'provider' code references each of
124             which returns a hash. The first provider is called and then, for each hash
125             item it returns, the tumble() method recurses to call the next provider.
126              
127             The recursion continues until there are no more providers to call, at which
128             point the consumer code reference is called. Effectively the providers create
129             a tree of combinations and the consumer is called at the leafs of the tree.
130              
131             If a provider returns no items then that part of the tree is pruned. Further
132             providers, if any, are not called and the consumer is not called.
133              
134             During a call to tumble() three values are passed down through the tree and
135             into the consumer: path, context, and payload.
136              
137             The path and context are derived from the names and values of the hashes
138             returned by the providers. Typically the path define the current "path"
139             through the tree of combinations.
140              
141             The providers are passed the current path, context, and payload.
142             The payload is cloned at each level of recursion so that any changes made to it
143             by providers are only visible within the scope of the generated sub-tree.
144              
145             Note that although the example above shows the path, context and payload as
146             array references, the tumbler code makes no assumptions about them. They can be
147             any kinds of values.
148              
149             See L for a practical example use.
150              
151             =head1 ATTRIBUTES
152              
153             =head2 consumer
154              
155             $tumbler->consumer( sub { my ($path, $context, $payload) = @_; ... } );
156              
157             Defines the code reference to call at the leafs of the generated tree of combinations.
158             The default is to throw an exception.
159              
160             =head2 add_path
161              
162             $tumbler->add_path( sub { my ($path, $name) = @_; return [ @$path, $name ] } )
163              
164             Defines the code reference to call to create a new path value that combines
165             the existing path and the new name. The default is shown in the example above.
166              
167              
168             =head2 add_context
169              
170             $tumbler->add_context( sub { my ($context, $value) = @_; return [ @$context, $value ] } )
171              
172             Defines the code reference to call to create a new context value that combines
173             the existing context and the new value. The default is shown in the example above.
174              
175             =cut
176              
177 4     4   2017 use Storable qw(dclone);
  4         8718  
  4         207  
178 4     4   16 use Carp qw(confess);
  4         4  
  4         1297  
179              
180             our $VERSION = '0.010';
181              
182             =head1 METHODS
183              
184             =head2 new
185              
186             Contructs new Data::Tumbler, deals with initial values for L.
187              
188             =cut
189              
190             sub new {
191 4     4 1 1376 my ($class, %args) = @_;
192              
193             my %defaults = (
194 0     0   0 consumer => sub { confess "No Data::Tumbler consumer defined" },
195 87405     87405   58595 add_path => sub { my ($path, $name ) = @_; return [ @$path, $name ] },
  87405         143808  
196 87405     87405   55218 add_context => sub { my ($context, $value) = @_; return [ @$context, $value ] },
  87405         112758  
197 4         27 );
198 4         10 my $self = bless \%defaults => $class;
199              
200 4         7 for my $attribute (qw(consumer add_path add_context)) {
201 12 100       23 next unless exists $args{$attribute};
202 6         20 $self->$attribute(delete $args{$attribute});
203             }
204 4 50       11 confess "Unknown $class arguments: @{[ keys %args ]}"
  0         0  
205             if %args;
206              
207 4         10 return $self;
208             }
209              
210              
211             sub consumer {
212 65558     65558 1 37133 my $self = shift;
213 65558 100       65822 $self->{consumer} = shift if @_;
214 65558         76761 return $self->{consumer};
215             }
216              
217             sub add_path {
218 87415     87415 1 49523 my $self = shift;
219 87415 100       95317 $self->{add_path} = shift if @_;
220 87415         93035 return $self->{add_path};
221             }
222              
223             sub add_context {
224 87415     87415 1 48668 my $self = shift;
225 87415 100       85356 $self->{add_context} = shift if @_;
226 87415         84797 return $self->{add_context};
227             }
228              
229             =head2 tumble
230              
231             Tumbles providers to compute variants.
232              
233             =cut
234              
235             sub tumble {
236 87418     87418 1 60402 my ($self, $providers, $path, $context, $payload) = @_;
237              
238 87418 100       90095 if (not @$providers) { # no more providers in this context
239 65554         53714 $self->consumer->($path, $context, $payload);
240 65554         165895 return;
241             }
242              
243             # clone the $payload so the provider can alter it for the consumer
244             # at and below this point in the tree of variants
245 21864 100       195887 $payload = dclone($payload) if ref $payload;
246              
247 21864         22497 my ($current_provider, @remaining_providers) = @$providers;
248              
249             # call the current provider to supply the variants for this context
250             # returns empty if the consumer shouldn't be called in the current context
251             # returns a single (possibly nil/empty/dummy) variant if there are
252             # no actual variations needed.
253 21864         26536 my %variants = $current_provider->($path, $context, $payload);
254              
255             # for each variant in turn, call the next level of provider
256             # with the name and value of the variant appended to the
257             # path and context.
258              
259 21864         176918 for my $name (sort keys %variants) {
260              
261 87414         89880 $self->tumble(
262             \@remaining_providers,
263             $self->add_path->($path, $name),
264             $self->add_context->($context, $variants{$name}),
265             $payload,
266             );
267             }
268              
269 21864         41971 return;
270             }
271              
272             1;
273              
274             __END__