File Coverage

blib/lib/Venus/Role/Coercible.pm
Criterion Covered Total %
statement 44 47 93.6
branch 10 14 71.4
condition 1 3 33.3
subroutine 11 12 91.6
pod 6 8 75.0
total 72 84 85.7


line stmt bran cond sub pod time code
1             package Venus::Role::Coercible;
2              
3 1     1   18 use 5.018;
  1         4  
4              
5 1     1   5 use strict;
  1         2  
  1         20  
6 1     1   4 use warnings;
  1         2  
  1         25  
7              
8 1     1   5 use Venus::Role 'with';
  1         2  
  1         5  
9              
10             # BUILDERS
11              
12             sub BUILD {
13 32     32 0 57 my ($self, $data) = @_;
14              
15 32         65 $data = $self->coercion($data);
16              
17 32         89 for my $name (keys %$data) {
18 35         64 $self->{$name} = $data->{$name};
19             }
20              
21 32         72 return $self;
22             };
23              
24             # METHODS
25              
26             sub coercers {
27 0     0 1 0 my ($self) = @_;
28              
29 0 0       0 return $self->can('coerce') ? $self->coerce : {};
30             }
31              
32             sub coerce_args {
33 36     36 1 72 my ($self, $data, $spec) = @_;
34              
35 36         221 for my $name (grep exists($data->{$_}), sort keys %$spec) {
36             $data->{$name} = $self->coerce_onto(
37 41         122 $data, $name, $spec->{$name}, $data->{$name},
38             );
39             }
40              
41 36         134 return $data;
42             }
43              
44             sub coerce_attr {
45 2     2 1 8 my ($self, $name, @args) = @_;
46              
47 2 100       9 return $self->{$name} if !@args;
48              
49 1         5 return $self->{$name} = $self->coercion({$name, $args[0]})->{$name};
50             }
51              
52             sub coerce_into {
53 49     49 1 96 my ($self, $class, $value) = @_;
54              
55 49         190 require Scalar::Util;
56 49         140 require Venus::Space;
57              
58 49         144 $class = (my $space = Venus::Space->new($class))->load;
59              
60 49         124 my $name = lc $space->label;
61              
62 49 100       232 if (my $method = $self->can("coerce_into_${name}")) {
63 2         45 return $self->$method($class, $value);
64             }
65 47 50 33     155 if (Scalar::Util::blessed($value) && $value->isa($class)) {
66 0         0 return $value;
67             }
68             else {
69 47         155 return $class->new($value);
70             }
71             }
72              
73             sub coerce_onto {
74 43     43 1 93 my ($self, $data, $name, $class, $value) = @_;
75              
76 43         790 require Venus::Space;
77              
78 43         148 $class = Venus::Space->new($class)->load;
79              
80 43 100       142 $value = $data->{$name} if $#_ < 4;
81              
82 43 100       207 if (my $method = $self->can("coerce_${name}")) {
83 34         782 return $data->{$name} = $self->$method(\&coerce_into, $class, $value);
84             }
85             else {
86 9         23 return $data->{$name} = $self->coerce_into($class, $value);
87             }
88             }
89              
90             sub coercion {
91 35     35 1 68 my ($self, $data) = @_;
92              
93 35         823 my $spec = $self->coercers;
94              
95 35 50       93 return $data if !%$spec;
96              
97 35         74 return $self->coerce_args($data, $spec);
98             }
99              
100             # EXPORTS
101              
102             sub EXPORT {
103             [
104 4     4 0 13 'coerce_args',
105             'coerce_attr',
106             'coerce_into',
107             'coerce_onto',
108             'coercers',
109             'coercion',
110             ]
111             }
112              
113             1;
114              
115              
116              
117             =head1 NAME
118              
119             Venus::Role::Coercible - Coercible Role
120              
121             =cut
122              
123             =head1 ABSTRACT
124              
125             Coercible Role for Perl 5
126              
127             =cut
128              
129             =head1 SYNOPSIS
130              
131             package Person;
132              
133             use Venus::Class;
134              
135             with 'Venus::Role::Coercible';
136              
137             attr 'name';
138             attr 'father';
139             attr 'mother';
140             attr 'siblings';
141              
142             sub coercers {
143             {
144             father => 'Person',
145             mother => 'Person',
146             name => 'Venus/String',
147             siblings => 'Person',
148             }
149             }
150              
151             sub coerce_name {
152             my ($self, $code, @args) = @_;
153              
154             return $self->$code(@args);
155             }
156              
157             sub coerce_siblings {
158             my ($self, $code, $class, $value) = @_;
159              
160             return [map $self->$code($class, $_), @$value];
161             }
162              
163             package main;
164              
165             my $person = Person->new(
166             name => 'me',
167             father => {name => 'father'},
168             mother => {name => 'mother'},
169             siblings => [{name => 'brother'}, {name => 'sister'}],
170             );
171              
172             # $person
173             # bless({...}, 'Person')
174              
175             # $person->name
176             # bless({...}, 'Venus::String')
177              
178             # $person->father
179             # bless({...}, 'Person')
180              
181             # $person->mother
182             # bless({...}, 'Person')
183              
184             # $person->siblings
185             # [bless({...}, 'Person'), bless({...}, 'Person'), ...]
186              
187             =cut
188              
189             =head1 DESCRIPTION
190              
191             This package modifies the consuming package and provides methods for hooking
192             into object construction and coercing arguments into objects and values.
193              
194             =cut
195              
196             =head1 METHODS
197              
198             This package provides the following methods:
199              
200             =cut
201              
202             =head2 coerce_args
203              
204             coerce_args(HashRef $data, HashRef $spec) (HashRef)
205              
206             The coerce_args method replaces values in the data provided with objects
207             corresponding to the specification provided. The specification should contains
208             key/value pairs where the keys map to class attributes (or input parameters)
209             and the values are L compatible package names.
210              
211             I>
212              
213             =over 4
214              
215             =item coerce_args example 1
216              
217             package main;
218              
219             my $person = Person->new;
220              
221             my $data = $person->coerce_args(
222             {
223             father => { name => 'father' }
224             },
225             {
226             father => 'Person',
227             },
228             );
229              
230             # {
231             # father => bless({...}, 'Person'),
232             # }
233              
234             =back
235              
236             =cut
237              
238             =head2 coerce_attr
239              
240             coerce_attr(Str $name, Any $value) (Any)
241              
242             The coerce_attr method is a surrogate accessor and gets and/or sets an instance
243             attribute based on the coercion rules, returning the coerced value.
244              
245             I>
246              
247             =over 4
248              
249             =item coerce_attr example 1
250              
251             # given: synopsis
252              
253             package main;
254              
255             $person = Person->new(
256             name => 'me',
257             );
258              
259             my $coerce_name = $person->coerce_attr('name');
260              
261             # bless({value => "me"}, "Venus::String")
262              
263             =back
264              
265             =over 4
266              
267             =item coerce_attr example 2
268              
269             # given: synopsis
270              
271             package main;
272              
273             $person = Person->new(
274             name => 'me',
275             );
276              
277             my $coerce_name = $person->coerce_attr('name', 'myself');
278              
279             # bless({value => "myself"}, "Venus::String")
280              
281             =back
282              
283             =cut
284              
285             =head2 coerce_into
286              
287             coerce_into(Str $class, Any $value) (Object)
288              
289             The coerce_into method attempts to build and return an object based on the
290             class name and value provided, unless the value provided is already an object
291             derived from the specified class.
292              
293             I>
294              
295             =over 4
296              
297             =item coerce_into example 1
298              
299             package main;
300              
301             my $person = Person->new;
302              
303             my $friend = $person->coerce_into('Person', {
304             name => 'friend',
305             });
306              
307             # bless({...}, 'Person')
308              
309             =back
310              
311             =cut
312              
313             =head2 coerce_onto
314              
315             coerce_onto(HashRef $data, Str $name, Str $class, Any $value) (Object)
316              
317             The coerce_onto method attempts to build and assign an object based on the
318             class name and value provided, as the value corresponding to the name
319             specified, in the data provided. If the C<$value> is omitted, the value
320             corresponding to the name in the C<$data> will be used.
321              
322             I>
323              
324             =over 4
325              
326             =item coerce_onto example 1
327              
328             package main;
329              
330             my $person = Person->new;
331              
332             my $data = { friend => { name => 'friend' } };
333              
334             my $friend = $person->coerce_onto($data, 'friend', 'Person');
335              
336             # bless({...}, 'Person'),
337              
338             # $data was updated
339             #
340             # {
341             # friend => bless({...}, 'Person'),
342             # }
343              
344             =back
345              
346             =over 4
347              
348             =item coerce_onto example 2
349              
350             package Player;
351              
352             use Venus::Class;
353              
354             with 'Venus::Role::Coercible';
355              
356             attr 'name';
357             attr 'teammates';
358              
359             sub coercers {
360             {
361             teammates => 'Person',
362             }
363             }
364              
365             sub coerce_into_person {
366             my ($self, $class, $value) = @_;
367              
368             return $class->new($value);
369             }
370              
371             sub coerce_into_venus_string {
372             my ($self, $class, $value) = @_;
373              
374             return $class->new($value);
375             }
376              
377             sub coerce_teammates {
378             my ($self, $code, $class, $value) = @_;
379              
380             return [map $self->$code($class, $_), @$value];
381             }
382              
383             package main;
384              
385             my $player = Player->new;
386              
387             my $data = { teammates => [{ name => 'player2' }, { name => 'player3' }] };
388              
389             my $teammates = $player->coerce_onto($data, 'teammates', 'Person');
390              
391             # [bless({...}, 'Person'), bless({...}, 'Person')]
392              
393             # $data was updated
394             #
395             # {
396             # teammates => [bless({...}, 'Person'), bless({...}, 'Person')],
397             # }
398              
399             =back
400              
401             =cut
402              
403             =head2 coercers
404              
405             coercers() (HashRef)
406              
407             The coercers method, if defined, is called during object construction, or by the
408             L method, and returns key/value pairs where the keys map to class
409             attributes (or input parameters) and the values are L compatible
410             package names.
411              
412             I>
413              
414             =over 4
415              
416             =item coercers example 1
417              
418             package main;
419              
420             my $person = Person->new(
421             name => 'me',
422             );
423              
424             my $coercers = $person->coercers;
425              
426             # {
427             # father => "Person",
428             # mother => "Person",
429             # name => "Venus/String",
430             # siblings => "Person",
431             # }
432              
433             =back
434              
435             =cut
436              
437             =head2 coercion
438              
439             coercion(HashRef $data) (HashRef)
440              
441             The coercion method is called automatically during object construction but can
442             be called manually as well, and is passed a hashref to coerce and return.
443              
444             I>
445              
446             =over 4
447              
448             =item coercion example 1
449              
450             package main;
451              
452             my $person = Person->new;
453              
454             my $coercion = $person->coercion({
455             name => 'me',
456             });
457              
458             # $coercion
459             # {...}
460              
461             # $coercion->{name}
462             # bless({...}, 'Venus::String')
463              
464             # $coercion->{father}
465             # undef
466              
467             # $coercion->{mother}
468             # undef
469              
470             # $coercion->{siblings}
471             # undef
472              
473             =back
474              
475             =over 4
476              
477             =item coercion example 2
478              
479             package main;
480              
481             my $person = Person->new;
482              
483             my $coercion = $person->coercion({
484             name => 'me',
485             mother => {name => 'mother'},
486             siblings => [{name => 'brother'}, {name => 'sister'}],
487             });
488              
489             # $coercion
490             # {...}
491              
492             # $coercion->{name}
493             # bless({...}, 'Venus::String')
494              
495             # $coercion->{father}
496             # undef
497              
498             # $coercion->{mother}
499             # bless({...}, 'Person')
500              
501             # $coercion->{siblings}
502             # [bless({...}, 'Person'), bless({...}, 'Person'), ...]
503              
504             =back
505              
506             =cut
507              
508             =head1 AUTHORS
509              
510             Awncorp, C
511              
512             =cut
513              
514             =head1 LICENSE
515              
516             Copyright (C) 2000, Al Newkirk.
517              
518             This program is free software, you can redistribute it and/or modify it under
519             the terms of the Apache license version 2.0.
520              
521             =cut