File Coverage

blib/lib/App/RecordStream/DomainLanguage/Value.pm
Criterion Covered Total %
statement 92 153 60.1
branch 35 76 46.0
condition 14 49 28.5
subroutine 17 28 60.7
pod 0 20 0.0
total 158 326 48.4


line stmt bran cond sub pod time code
1             package App::RecordStream::DomainLanguage::Value;
2              
3 27     27   159 use strict;
  27         59  
  27         679  
4 27     27   139 use warnings;
  27         55  
  27         668  
5              
6 27     27   7027 use App::RecordStream::Aggregator::Internal::Constant;
  27         72  
  27         632  
7 27     27   6957 use App::RecordStream::DomainLanguage::Snippet;
  27         102  
  27         958  
8 27     27   5699 use App::RecordStream::DomainLanguage::Valuation::KeySpec;
  27         68  
  27         643  
9 27     27   8184 use App::RecordStream::DomainLanguage::Valuation::Sub;
  27         83  
  27         953  
10 27     27   178 use Scalar::Util ('blessed');
  27         62  
  27         37744  
11              
12             sub new
13             {
14 1194     1194 0 1943 my $class = shift;
15 1194         1756 my $desc = shift;
16              
17 1194         3474 my $this =
18             {
19             'DESCRIPTION' => $desc,
20             'POSSIBILITIES' => {},
21             };
22              
23 1194         2069 bless $this, $class;
24              
25 1194         2737 return $this;
26             }
27              
28             sub new_from_scalar
29             {
30 352     352 0 631 my $class = shift;
31 352         549 my $value = shift;
32              
33 352         1218 my $this = $class->new("scalar($value)");
34              
35 352         1024 $this->add_possibility('SCALAR', $value);
36              
37 352         1549 return $this;
38             }
39              
40             sub add_possibility
41             {
42 1699     1699 0 2883 my $this = shift;
43 1699         2922 my $type = shift;
44 1699         2946 my $value = shift;
45              
46 1699 100       3526 if($type eq 'SCALAR')
47             {
48 352 100 100     1553 if(blessed($value) && $value->isa('App::RecordStream::DomainLanguage::Snippet'))
49             {
50 138         437 return $this->add_possibility('SNIPPET', $value);
51             }
52             }
53              
54 1561   50     2110 push @{$this->{'POSSIBILITIES'}->{$type} ||= []}, $value;
  1561         6773  
55              
56             # sketchy upgrade...
57 1561 100       4123 if($type eq "SCALAR")
58             {
59 214         931 $this->add_possibility('VALUATION', App::RecordStream::DomainLanguage::Valuation::KeySpec->new($value));
60 214         754 $this->add_possibility('SNIPPET', App::RecordStream::DomainLanguage::Snippet->new($value));
61             }
62             }
63              
64             sub get_possibilities
65             {
66 715     715 0 1149 my $this = shift;
67 715         1102 my $type = shift;
68              
69 715 100       1040 return @{$this->{'POSSIBILITIES'}->{$type} || []};
  715         2715  
70             }
71              
72             sub get_possible_pairs
73             {
74 490     490 0 891 my $this = shift;
75              
76 490         709 my @ret;
77 490         790 for my $type (keys(%{$this->{'POSSIBILITIES'}}))
  490         1563  
78             {
79 781         1126 for my $value (@{$this->{'POSSIBILITIES'}->{$type}})
  781         1568  
80             {
81 781         2008 push @ret, [$type, $value];
82             }
83             }
84              
85 490         1461 return @ret;
86             }
87              
88             sub get_description
89             {
90 568     568 0 893 my $this = shift;
91              
92 568         3017 return $this->{'DESCRIPTION'};
93             }
94              
95             sub _force
96             {
97 0     0   0 my $this = shift;
98 0         0 my $type = shift;
99              
100 0   0     0 my $ar = $this->{'POSSIBILITIES'}->{$type} || [];
101 0         0 my $ct = @$ar;
102 0 0       0 if($ct != 1)
103             {
104 0         0 die "Cannot use '" . $this->{'DESCRIPTION'} . "' as $type, $ct possibilities";
105             }
106              
107 0         0 return $ar->[0];
108             }
109              
110             # TODO: amling, fake isa?
111              
112             # We can pretend to be an aggregator in a pinch
113              
114             sub initial
115             {
116 0     0 0 0 return shift->_force('AGGREGATOR')->initial(@_);
117             }
118              
119             sub combine
120             {
121 0     0 0 0 return shift->_force('AGGREGATOR')->combine(@_);
122             }
123              
124             sub squish
125             {
126 0     0 0 0 return shift->_force('AGGREGATOR')->squish(@_);
127             }
128              
129             # We can pretend to be a deaggregator in a pinch
130              
131             sub deaggregate
132             {
133 0     0 0 0 return shift->_force('DEAGGREGATOR')->deaggregate(@_);
134             }
135              
136             # We can pretend to be a clumper in a pinch
137              
138             sub clumper_begin
139             {
140 0     0 0 0 return shift->_force('CLUMPER')->clumper_begin(@_);
141             }
142              
143             sub clumper_push_record
144             {
145 0     0 0 0 return shift->_force('CLUMPER')->clumper_push_record(@_);
146             }
147              
148             sub clumper_end
149             {
150 0     0 0 0 return shift->_force('CLUMPER')->clumper_end(@_);
151             }
152              
153             # We can pretend to be a valuation in a pinch
154              
155             sub evaluate_record
156             {
157 0     0 0 0 return shift->_force('VALUATION')->evaluate_record(@_);
158             }
159              
160             sub cast_or_die
161             {
162 389     389 0 834 my $type = shift;
163 389         656 my $obj = shift;
164              
165 389 100       2126 if($type eq 'AGGREGATOR')
    50          
    50          
    100          
    50          
166             {
167 75         299 return cast_agg_or_die($obj);
168             }
169             elsif($type eq 'DEAGGREGATOR')
170             {
171 0         0 return cast_deagg_or_die($obj);
172             }
173             elsif($type eq 'CLUMPER')
174             {
175 0         0 return cast_clumper_or_die($obj);
176             }
177             elsif($type eq 'VALUATION')
178             {
179 55         257 return cast_valuation_or_die($obj);
180             }
181             elsif($type eq 'SCALAR')
182             {
183 259         884 return cast_scalar_or_die($obj);
184             }
185             else
186             {
187 0         0 die "Bad type $type?";
188             }
189             }
190              
191             sub cast_valuation_or_die
192             {
193 55     55 0 147 my $obj = shift;
194              
195 55 100 66     611 if(ref($obj) && ref($obj) eq "CODE")
196             {
197 1         11 return App::RecordStream::DomainLanguage::Valuation::Sub->new($obj);
198             }
199              
200 54 50 33     511 if(blessed($obj) && $obj->isa('App::RecordStream::DomainLanguage::Value'))
201             {
202 54         200 my @val = $obj->get_possibilities('VALUATION');
203 54 50       183 if(@val > 1)
204             {
205 0         0 die "Multiple valuations for " . $obj->get_description();
206             }
207 54 100       213 if(@val == 1)
208             {
209 1         8 return $val[0];
210             }
211             }
212              
213 53 50 33     503 if(blessed($obj) && $obj->isa('App::RecordStream::Aggregator::Aggregation'))
214             {
215 0         0 die "Aggregation found where valuation expected";
216             }
217              
218 53 50 33     472 if(blessed($obj) && $obj->isa('App::RecordStream::DomainLanguage::Valuation'))
219             {
220 0         0 return $obj;
221             }
222              
223 53         941 die "Unknown found where valuation expected";
224             }
225              
226             sub cast_agg_or_die
227             {
228 75     75 0 248 my $obj = shift;
229              
230 75 50 33     610 if(blessed($obj) && $obj->isa('App::RecordStream::DomainLanguage::Value'))
231             {
232 75         245 my @agg = $obj->get_possibilities('AGGREGATOR');
233 75 50       649 if(@agg > 1)
234             {
235 0         0 die "Multiple aggregators for " . $obj->get_description();
236             }
237 75 100       258 if(@agg == 1)
238             {
239 73         573 return $agg[0];
240             }
241              
242 2         8 my @scalar = $obj->get_possibilities('SCALAR');
243 2 50       8 if(@scalar > 1)
244             {
245 0         0 die "No aggregators and multiple scalars for " . $obj->get_description();
246             }
247 2 50       6 if(@scalar == 1)
248             {
249 0         0 $obj = $scalar[0];
250             }
251             else
252             {
253 2         6 die "No usable possibilities for " . $obj->get_description();
254             }
255             }
256              
257 0 0 0     0 if(blessed($obj) && $obj->isa('App::RecordStream::Aggregator::Aggregation'))
258             {
259 0         0 return $obj;
260             }
261              
262 0 0 0     0 if(blessed($obj) && $obj->isa('App::RecordStream::DomainLanguage::Valuation'))
263             {
264 0         0 die "Valuation found where aggregator expected";
265             }
266              
267             # running out of ideas here
268 0         0 return App::RecordStream::Aggregator::Internal::Constant->new($obj);
269             }
270              
271             sub cast_deagg_or_die
272             {
273 0     0 0 0 my $obj = shift;
274              
275 0 0 0     0 if(blessed($obj) && $obj->isa('App::RecordStream::DomainLanguage::Value'))
276             {
277 0         0 my @deagg = $obj->get_possibilities('DEAGGREGATOR');
278 0 0       0 if(@deagg > 1)
279             {
280 0         0 die "Multiple deaggregators for " . $obj->get_description();
281             }
282 0 0       0 if(@deagg == 1)
283             {
284 0         0 return $deagg[0];
285             }
286              
287 0         0 die "No usable possibilities for " . $obj->get_description();
288             }
289              
290 0 0 0     0 if(blessed($obj) && $obj->isa('App::RecordStream::Deaggregator::Base'))
291             {
292 0         0 return $obj;
293             }
294              
295 0         0 my $s = "unknown";
296 0 0       0 if(blessed($obj))
297             {
298 0         0 $s = ref($obj);
299             }
300              
301 0         0 die "Could not turn $s into a deaggregator";
302             }
303              
304             sub cast_clumper_or_die
305             {
306 0     0 0 0 my $obj = shift;
307              
308 0 0 0     0 if(blessed($obj) && $obj->isa('App::RecordStream::DomainLanguage::Value'))
309             {
310 0         0 my @clumper = $obj->get_possibilities('CLUMPER');
311 0 0       0 if(@clumper > 1)
312             {
313 0         0 die "Multiple clumpers for " . $obj->get_description();
314             }
315 0 0       0 if(@clumper == 1)
316             {
317 0         0 return $clumper[0];
318             }
319              
320 0         0 die "No usable possibilities for " . $obj->get_description();
321             }
322              
323 0 0 0     0 if(blessed($obj) && $obj->isa('App::RecordStream::Clumper::Base'))
324             {
325 0         0 return $obj;
326             }
327              
328 0         0 my $s = "unknown";
329 0 0       0 if(blessed($obj))
330             {
331 0         0 $s = ref($obj);
332             }
333              
334 0         0 die "Could not turn $s into a clumper";
335             }
336              
337             sub cast_scalar_or_die
338             {
339 259     259 0 456 my $obj = shift;
340              
341 259 100 66     1312 if(blessed($obj) && $obj->isa('App::RecordStream::DomainLanguage::Value'))
342             {
343 54         222 my @scalar = $obj->get_possibilities('SCALAR');
344 54 50       184 if(@scalar > 1)
345             {
346 0         0 die "Multiple scalar values for " . $obj->get_description();
347             }
348 54 50       175 if(@scalar == 1)
349             {
350 0         0 return $scalar[0];
351             }
352              
353 54         170 die "No scalar possibilities for " . $obj->get_description();
354             }
355              
356 205 50 33     724 if(blessed($obj) && $obj->isa('App::RecordStream::Aggregator::Aggregation'))
357             {
358 0         0 die "Aggregator found where scalar expected";
359             }
360              
361 205 50 33     610 if(blessed($obj) && $obj->isa('App::RecordStream::DomainLanguage::Valuation'))
362             {
363 0         0 die "Valuation found where scalar expected";
364             }
365              
366 205         1365 return $obj;
367             }
368              
369             1;