File Coverage

blib/lib/Venus/Role/Makeable.pm
Criterion Covered Total %
statement 44 47 93.6
branch 10 12 83.3
condition 1 3 33.3
subroutine 11 12 91.6
pod 6 8 75.0
total 72 82 87.8


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