File Coverage

blib/lib/Data/Fake/Core.pm
Criterion Covered Total %
statement 95 101 94.0
branch 22 38 57.8
condition 4 12 33.3
subroutine 29 30 96.6
pod 11 11 100.0
total 161 192 83.8


line stmt bran cond sub pod time code
1 5     5   81842 use 5.008001;
  5         25  
2 5     5   25 use strict;
  5         8  
  5         96  
3 5     5   22 use warnings;
  5         8  
  5         359  
4              
5             package Data::Fake::Core;
6             # ABSTRACT: General purpose generators
7              
8             our $VERSION = '0.006';
9              
10 5     5   33 use Exporter 5.57 qw/import/;
  5         84  
  5         425  
11              
12             our @EXPORT = qw(
13             fake_hash
14             fake_array
15             fake_flatten
16             fake_pick
17             fake_binomial
18             fake_weighted
19             fake_int
20             fake_float
21             fake_digits
22             fake_template
23             fake_join
24             );
25              
26             our @EXPORT_OK = qw/_transform/;
27              
28 5     5   33 use Carp qw/croak/;
  5         8  
  5         390  
29 5     5   33 use List::Util qw/sum/;
  5         8  
  5         7856  
30              
31             #pod =func fake_hash
32             #pod
33             #pod $generator = fake_hash(
34             #pod {
35             #pod name => fake_name,
36             #pod pet => fake_pick(qw/dog cat frog/),
37             #pod }
38             #pod );
39             #pod
40             #pod $generator = fake_hash( @hash_or_hash_generators );
41             #pod
42             #pod The C function returns a code reference that, when run,
43             #pod generates a hash reference.
44             #pod
45             #pod The simplest way to use it is to provide a hash reference with some values
46             #pod replaced with C generator functions. When the generator runs, the
47             #pod hash will be walked recursively and any code reference found will be
48             #pod replaced with its output.
49             #pod
50             #pod If more than one argument is provided, when the generator runs, they will
51             #pod be merged according to the following rules:
52             #pod
53             #pod =for :list
54             #pod * code references will be replaced with their outputs
55             #pod * after replacement, if any arguments aren't hash references, an exception
56             #pod will be thrown
57             #pod * hash references will be shallow-merged
58             #pod
59             #pod This merging allows for generating sections of hashes differently or
60             #pod generating hashes that have missing keys (e.g. using L):
61             #pod
62             #pod # 25% of the time, generate a hash with a 'spouse' key
63             #pod $factory = fake_hash(
64             #pod { ... },
65             #pod fake_binomial( 0.25, { spouse => fake_name() }, {} ),
66             #pod );
67             #pod
68             #pod =cut
69              
70             sub fake_hash {
71 5     5 1 622 my (@parts) = @_;
72             return sub {
73 26     26   10311 my $result = {};
74 26         46 for my $next ( map { _transform($_) } @parts ) {
  28         51  
75 28 50       66 croak "fake_hash can only merge hash references"
76             unless ref($next) eq 'HASH';
77 28         57 @{$result}{ keys %$next } = @{$next}{ keys %$next };
  28         74  
  28         56  
78             }
79 26         75 return $result;
80 5         35 };
81             }
82              
83             #pod =func fake_array
84             #pod
85             #pod $generator = fake_array( 5, fake_digits("###-###-####") );
86             #pod
87             #pod The C takes a positive integer size and source argument and
88             #pod returns a generator that returns an array reference with each element built
89             #pod from the source.
90             #pod
91             #pod If the size is a code reference, it will be run and can set a different size
92             #pod for every array generated:
93             #pod
94             #pod # arrays from size 1 to size 6
95             #pod $generator = fake_array( fake_int(1,6), fake_digits("###-###-###") );
96             #pod
97             #pod If the source is a code reference, it will be run; if the source is a hash
98             #pod or array reference, it will be recursively evaluated like C.
99             #pod
100             #pod =cut
101              
102             sub fake_array {
103 14     14 1 2850 my ( $size, $template ) = @_;
104             return sub {
105 79     79   110596 [ map { _transform($template) } 1 .. _transform($size) ];
  194         293  
106 14         56 };
107             }
108              
109             #pod =func fake_pick
110             #pod
111             #pod $generator = fake_pick( qw/one two three/ );
112             #pod $generator = fake_pick( @generators );
113             #pod
114             #pod Given literal values or code references, returns a generator that randomly
115             #pod selects one of them with equal probability. If the choice is a code
116             #pod reference, it will be run; if the choice is a hash or array reference, it
117             #pod will be recursively evaluated like C or C would do.
118             #pod
119             #pod =cut
120              
121             sub fake_pick {
122 26     26 1 30635 my (@list) = @_;
123 26         41 my $size = scalar @list;
124 26     255   132 return sub { _transform( $list[ int( rand($size) ) ] ) };
  255         9463  
125             }
126              
127             #pod =func fake_binomial
128             #pod
129             #pod $generator = fake_binomial(
130             #pod 0.90,
131             #pod { name => fake_name() }, # 90% likely
132             #pod {}, # 10% likely
133             #pod );
134             #pod
135             #pod $generator = fake_binomial( $prob, $lte_outcome, $gt_outcome );
136             #pod
137             #pod The C function takes a probability and two outcomes. The
138             #pod probability (between 0 and 1.0) indicates the likelihood that the return
139             #pod value will the first outcome. The rest of the time, the return value will
140             #pod be the second outcome. If the outcome is a code reference, it will be run;
141             #pod if the outcome is a hash or array reference, it will be recursively
142             #pod evaluated like C or C would do.
143             #pod
144             #pod =cut
145              
146             sub fake_binomial {
147 2     2 1 6032 my ( $prob, $first, $second ) = @_;
148 2 50 33     21 croak "fake_binomial probability must be between 0 and 1.0"
      33        
149             unless defined($prob) && $prob >= 0 && $prob <= 1.0;
150             return sub {
151 6 100   6   49 return _transform( rand() <= $prob ? $first : $second );
152 2         13 };
153             }
154              
155             #pod =func fake_weighted
156             #pod
157             #pod $generator = fake_weighted(
158             #pod [ 'a_choice', 1 ],
159             #pod [ 'ten_times_likely', 10 ],
160             #pod [ $another_generator, 1 ],
161             #pod );
162             #pod
163             #pod Given a list of array references, each containing a value and a
164             #pod non-negative weight, returns a generator that randomly selects a value
165             #pod according to the relative weights.
166             #pod
167             #pod If the value is a code reference, it will be run; if it is a hash or array
168             #pod reference, it will be recursively evaluated like C or C
169             #pod would do.
170             #pod
171             #pod =cut
172              
173             sub fake_weighted {
174 2     2 1 4037 my (@list) = @_;
175       0     return sub { }
176 2 50       7 unless @list;
177              
178 2 50       7 if ( @list != grep { ref($_) eq 'ARRAY' } @list ) {
  6         16  
179 0         0 croak("fake_weighted requires a list of array references");
180             }
181              
182             # normalize weights into cumulative probabilities
183 2         5 my $sum = sum( 0, map { $_->[1] } @list );
  6         15  
184 2         5 my $max = 0;
185 2         5 for my $s (@list) {
186 6         13 $s->[1] = $max += $s->[1] / $sum;
187             }
188 2         5 my $last = pop @list;
189              
190             return sub {
191 3     3   20 my $rand = rand();
192 3         5 for my $s (@list) {
193 3 50       9 return _transform( $s->[0] ) if $rand <= $s->[1];
194             }
195 0         0 return _transform( $last->[0] );
196 2         15 };
197             }
198              
199             #pod =func fake_int
200             #pod
201             #pod $generator = fake_int(1, 6);
202             #pod
203             #pod Given a minimum and a maximum value as inputs, returns a generator that
204             #pod will produce a random integer in that range.
205             #pod
206             #pod =cut
207              
208             sub fake_int {
209 34     34 1 25236 my ( $min, $max ) = map { int($_) } @_;
  68         141  
210 34 50 33     142 croak "fake_int requires minimum and maximum"
211             unless defined $min && defined $max;
212 34         64 my $range = $max - $min + 1;
213             return sub {
214 144     144   16793 return $min + int( rand($range) );
215 34         163 };
216             }
217              
218             #pod =func fake_float
219             #pod
220             #pod $generator = fake_float(1.0, 6.0);
221             #pod
222             #pod Given a minimum and a maximum value as inputs, returns a generator that
223             #pod will produce a random floating point value in that range.
224             #pod
225             #pod =cut
226              
227             sub fake_float {
228 13     13 1 6817 my ( $min, $max ) = @_;
229 13 50 33     78 croak "fake_float requires minimum and maximum"
230             unless defined $min && defined $max;
231 13         28 my $range = $max - $min;
232             return sub {
233 55     55   12274 return $min + rand($range);
234 13         57 };
235             }
236              
237             #pod =func fake_digits
238             #pod
239             #pod $generator = fake_digits('###-####'); # "555-1234"
240             #pod $generator = fake_digits('\###'); # "#12"
241             #pod
242             #pod Given a text pattern, returns a generator that replaces all occurrences of
243             #pod the sharp character (C<#>) with a randomly selected digit. To have a
244             #pod literal sharp character, escape it with a backslash (do it in a
245             #pod single-quoted string to avoid having to double your backslash to get a
246             #pod backslash in the string.).
247             #pod
248             #pod Use this for phone numbers, currencies, or whatever else needs random
249             #pod digits:
250             #pod
251             #pod fake_digits('###-##-####'); # US Social Security Number
252             #pod fake_digits('(###) ###-####'); # (800) 555-1212
253             #pod
254             #pod =cut
255              
256             my $DIGIT_RE = qr/(?
257              
258             sub fake_digits {
259 5     5 1 4736 my ($template) = @_;
260             return sub {
261 5     5   9 my $copy = $template;
262 5         39 1 while $copy =~ s{$DIGIT_RE}{int(rand(10))}e;
  24         135  
263 5         13 $copy =~ s{\\#}{#}g;
264 5         15 return $copy;
265 5         28 };
266             }
267              
268             #pod =func fake_template
269             #pod
270             #pod $generator = fake_template("Hello, %s", fake_name());
271             #pod
272             #pod Given a sprintf-style text pattern and a list of generators, returns a
273             #pod generator that, when run, executes the generators and returns the string
274             #pod populated with the output.
275             #pod
276             #pod Use this for creating custom generators from other generators.
277             #pod
278             #pod =cut
279              
280             sub fake_template {
281 24     24 1 57 my ( $template, @args ) = @_;
282             return sub {
283 12     12   36 return sprintf( $template, map { _transform($_) } @args );
  30         55  
284 24         94 };
285             }
286              
287             #pod =func fake_join
288             #pod
289             #pod $generator = fake_join(" ", fake_first_name(), fake_surname() );
290             #pod
291             #pod Given a character to join on a list of literals or generators, returns a
292             #pod generator that, when run, executes any generators and returns them concatenated
293             #pod together, separated by the separator character.
294             #pod
295             #pod The separator itself may also be a generator if you want that degree of
296             #pod randomness as well.
297             #pod
298             #pod $generator = fake_join( fake_pick( q{}, q{ }, q{,} ), @args );
299             #pod
300             #pod =cut
301              
302             sub fake_join {
303 2     2 1 686 my ( $char, @args ) = @_;
304             return sub {
305 2     2   10 return join( _transform($char), map { _transform($_) } @args );
  3         7  
306 2         11 };
307             }
308              
309             #pod =func fake_flatten
310             #pod
311             #pod $flatten_generator = fake_flatten( fake_array( 3, fake_first_name() ) );
312             #pod @array_of_names = $flatten_generator->();
313             #pod
314             #pod Given a generator that returns an array ref (such as fake_array) or a
315             #pod hash ref (fake_hash), fake_flatten returns a generator that, when run,
316             #pod executes the generators and returns their result in a dereferenced state.
317             #pod
318             #pod This is particularly useful when the return value is used directly as
319             #pod input to another function, for example within a fake_join.
320             #pod
321             #pod $generator = fake_join( " ", $flatten_generator );
322             #pod
323             #pod =cut
324              
325             sub fake_flatten {
326 7     7 1 6010 my ($ref) = @_;
327              
328             return sub {
329 12     12   2701 my $result = _transform($ref);
330 12         27 my $result_ref = ref($result);
331 12 100       31 if ( $result_ref eq 'ARRAY' ) {
    50          
332 7         26 return @$result;
333             }
334             elsif ( $result_ref eq 'HASH' ) {
335 5         23 return %$result;
336             }
337              
338 0         0 croak "I do not know how to flatten a $result_ref";
339             }
340 7         33 }
341              
342             sub _transform {
343 648     648   990 my ($template) = @_;
344              
345 648         973 my $type = ref($template);
346              
347 648 100       1338 if ( $type eq 'CODE' ) {
    100          
    50          
348 319         490 return $template->();
349             }
350             elsif ( $type eq 'HASH' ) {
351 38         51 my $copy = {};
352 38         116 while ( my ( $k, $v ) = each %$template ) {
353 65 50       174 $copy->{$k} =
    100          
    100          
354             ref($v) eq 'CODE' ? $v->()
355             : ref($v) eq 'HASH' ? _transform($v)
356             : ref($v) eq 'ARRAY' ? _transform($v)
357             : $v;
358             }
359 38         99 return $copy;
360             }
361             elsif ( $type eq 'ARRAY' ) {
362             my @copy = map {
363 0 0       0 ref $_ eq 'CODE' ? $_->()
  0 0       0  
    0          
364             : ref $_ eq 'HASH' ? _transform($_)
365             : ref $_ eq 'ARRAY' ? _transform($_)
366             : $_;
367             } @$template;
368 0         0 return \@copy;
369             }
370             else {
371             # literal value
372 291         857 return $template;
373             }
374             }
375              
376             1;
377              
378              
379             # vim: ts=4 sts=4 sw=4 et tw=75:
380              
381             __END__