File Coverage

blib/lib/Venus/Prototype.pm
Criterion Covered Total %
statement 46 65 70.7
branch 16 30 53.3
condition 11 19 57.8
subroutine 14 17 82.3
pod 5 8 62.5
total 92 139 66.1


line stmt bran cond sub pod time code
1             package Venus::Prototype;
2              
3 1     1   28 use 5.018;
  1         3  
4              
5 1     1   6 use strict;
  1         1  
  1         22  
6 1     1   5 use warnings;
  1         2  
  1         31  
7              
8 1     1   6 use Venus::Class 'base', 'with';
  1         2  
  1         6  
9              
10             base 'Venus::Kind::Utility';
11              
12             with 'Venus::Role::Valuable';
13             with 'Venus::Role::Buildable';
14             with 'Venus::Role::Proxyable';
15              
16 1     1   7 use Scalar::Util ();
  1         2  
  1         1041  
17              
18             # HOOKS
19              
20             sub _clone {
21 56     56   88 my ($data) = @_;
22              
23 56 50 66     276 if (!defined($data)) {
    100 33        
    50          
24 0         0 return $data;
25             }
26             elsif (!Scalar::Util::blessed($data) && ref($data) eq 'HASH') {
27 23         51 my $copy = {};
28 23         59 for my $key (keys %$data) {
29 36         63 $copy->{$key} = _clone($data->{$key});
30             }
31 23         94 return $copy;
32             }
33             elsif (!Scalar::Util::blessed($data) && ref($data) eq 'ARRAY') {
34 0         0 my $copy = [];
35 0         0 for (my $i = 0; $i < @$data; $i++) {
36 0         0 $copy->[$i] = _copy($data->[$i]);
37             }
38 0         0 return $copy;
39             }
40             else {
41 33         89 return $data;
42             }
43             }
44              
45             sub _value {
46 14     14   22 my ($data) = @_;
47              
48 14 100 100     56 if (keys %$data == 1 && exists $data->{value}) {
49 7         23 return $data->{value};
50             }
51             else {
52 7         25 return $data;
53             }
54             }
55              
56             # BUILDERS
57              
58             sub build_args {
59 13     13 0 27 my ($self, $data) = @_;
60              
61 13 50 66     50 if (keys %$data == 1 && exists $data->{value}) {
62 0         0 return _clone($data);
63             }
64             return {
65 13         26 value => _clone($data)
66             };
67             }
68              
69             sub build_proxy {
70 20     20 0 43 my ($self, $package, $method, @args) = @_;
71              
72             # as a method/routine
73             return sub {
74 4     4   95 $self->{value}{"\&$method"}->($self, @args)
75             }
76 20 100       77 if defined $self->{value}{"\&$method"};
77              
78             # as a property/attribute
79             return sub {
80 16 100   16   152 @args ? $self->{value}{"\$$method"} = $args[0] : $self->{value}{"\$$method"}
81             }
82 16 50       104 if exists $self->{value}{"\$$method"};
83              
84 0         0 return undef;
85             }
86              
87             # METHODS
88              
89             sub apply {
90 3     3 1 23 my ($self, $data) = @_;
91              
92 3   100     11 $data ||= {};
93              
94 3         6 return $self->do('value', _clone({%{_value($self)}, %{_value($data)}}));
  3         8  
  3         7  
95             }
96              
97             sub call {
98 2     2 1 6 my ($self, $method, @args) = @_;
99              
100             # as a method/routine
101             return $self->{value}{"\&$method"}->($self, @args)
102 2 50       13 if defined $self->{value}{"\&$method"};
103              
104             # as a property/attribute
105             return @args ? $self->{value}{"\$$method"} = $args[0] : $self->{value}{"\$$method"}
106 2 100       20 if exists $self->{value}{"\$$method"};
    50          
107             }
108              
109             sub default {
110 0     0 0 0 my ($self) = @_;
111              
112 0         0 return {};
113             }
114              
115             sub extend {
116 4     4 1 9 my ($self, $data) = @_;
117              
118 4   50     11 $data ||= {};
119              
120 4         78 return $self->class->new(_clone({%{_value($self)}, %{_value($data)}}));
  4         10  
  4         6  
121             }
122              
123             sub get {
124 0     0 1   my ($self, @args) = @_;
125              
126 0 0         return $self->value if !@args;
127              
128 0           my ($index) = @args;
129              
130 0           return $self->value->{$index};
131             }
132              
133             sub set {
134 0     0 1   my ($self, @args) = @_;
135              
136 0 0         return $self->value if !@args;
137              
138 0 0 0       return $self->value(@args) if @args == 1 && ref $args[0] eq 'HASH';
139              
140 0           my ($index, $value) = @args;
141              
142 0 0         return if not defined $index;
143              
144 0           return $self->value->{$index} = $value;
145             }
146              
147             1;
148              
149              
150              
151             =head1 NAME
152              
153             Venus::Prototype - Prototype Class
154              
155             =cut
156              
157             =head1 ABSTRACT
158              
159             Prototype Class for Perl 5
160              
161             =cut
162              
163             =head1 SYNOPSIS
164              
165             package main;
166              
167             use Venus::Prototype;
168              
169             my $prototype = Venus::Prototype->new(
170             '$counter' => 0,
171             '&decrement' => sub { $_[0]->counter($_[0]->counter - 1) },
172             '&increment' => sub { $_[0]->counter($_[0]->counter + 1) },
173             );
174              
175             # bless({value => {...}}, 'Venus::Prototype')
176              
177             # $prototype->counter # 0
178             # $prototype->increment # 1
179             # $prototype->counter # 1
180             # $prototype->decrement # 0
181             # $prototype->counter # 0
182              
183             =cut
184              
185             =head1 DESCRIPTION
186              
187             This package provides a simple construct for enabling prototype-base
188             programming. Properties can be called as methods when prefixed with a dollar or
189             ampersand symbol. See L for more details.
190              
191             =cut
192              
193             =head1 INHERITS
194              
195             This package inherits behaviors from:
196              
197             L
198              
199             =cut
200              
201             =head1 INTEGRATES
202              
203             This package integrates behaviors from:
204              
205             L
206              
207             L
208              
209             L
210              
211             =cut
212              
213             =head1 METHODS
214              
215             This package provides the following methods:
216              
217             =cut
218              
219             =head2 apply
220              
221             apply(HashRef $data) (Prototype)
222              
223             The apply method extends the underlying data structure by merging the data
224             provided, and then returns the invocant.
225              
226             I>
227              
228             =over 4
229              
230             =item apply example 1
231              
232             package main;
233              
234             my $person = Venus::Prototype->new({
235             '$name' => '',
236             });
237              
238             $person->apply;
239              
240             # bless({value => {'$name' => ''}}, 'Venus::Prototype')
241              
242             =back
243              
244             =over 4
245              
246             =item apply example 2
247              
248             package main;
249              
250             my $person = Venus::Prototype->new({
251             '$name' => '',
252             });
253              
254             $person->apply({
255             '$name' => 'Elliot Alderson',
256             });
257              
258             # bless({value => {'$name' => 'Elliot Alderson'}}, 'Venus::Prototype')
259              
260             =back
261              
262             =over 4
263              
264             =item apply example 3
265              
266             package main;
267              
268             my $person = Venus::Prototype->new({
269             '$name' => '',
270             '&greet' => sub {'hello'},
271             });
272              
273             $person->apply({
274             '$name' => 'Elliot Alderson',
275             });
276              
277             # bless({value => {...}}, 'Venus::Prototype')
278              
279             =back
280              
281             =cut
282              
283             =head2 call
284              
285             call(Str $method, Any @args) (Any)
286              
287             The call method dispatches method calls based on the method name provided and
288             the state of the object, and returns the results. If the method name provided
289             matches an object property of the same name with an ampersand prefix, denoting
290             a method, then the dispatched method call acts as a method call providing the
291             invocant as the first argument. If the method name provided matches an object
292             property of the same name with a dollar sign prefix, denoting an attribute,
293             then the dispatched method call acts as an attribute accessor call. This method
294             is also useful for calling virtual methods when those virtual methods conflict
295             with the L methods.
296              
297             I>
298              
299             =over 4
300              
301             =item call example 1
302              
303             package main;
304              
305             my $person = Venus::Prototype->new({
306             '$name' => 'anonymous',
307             });
308              
309             my $name = $person->call('name');
310              
311             # "anonymous"
312              
313             =back
314              
315             =over 4
316              
317             =item call example 2
318              
319             package main;
320              
321             my $person = Venus::Prototype->new({
322             '$name' => 'anonymous',
323             });
324              
325             my $name = $person->call('name', 'unidentified');
326              
327             # "unidentified"
328              
329             =back
330              
331             =cut
332              
333             =head2 extend
334              
335             extend(HashRef $data) (Prototype)
336              
337             The extend method copies the underlying data structure, merging the data
338             provided if any, and then returns a new prototype object.
339              
340             I>
341              
342             =over 4
343              
344             =item extend example 1
345              
346             package main;
347              
348             my $mrrobot = Venus::Prototype->new({
349             '$name' => 'Edward Alderson',
350             '$group' => 'fsociety',
351             });
352              
353             my $elliot = $mrrobot->extend({
354             '$name' => 'Elliot Alderson',
355             });
356              
357             # bless({value => {...}}, 'Venus::Prototype')
358              
359             =back
360              
361             =over 4
362              
363             =item extend example 2
364              
365             package main;
366              
367             my $mrrobot = Venus::Prototype->new({
368             '$name' => 'Edward Alderson',
369             '$group' => 'fsociety',
370             '$login' => { username => 'admin', password => 'secret', },
371             });
372              
373             my $elliot = $mrrobot->extend({
374             '$name' => 'Elliot Alderson',
375             '$login' => { password => '$ecr3+', },
376             });
377              
378             # bless({value => {...}}, 'Venus::Prototype')
379              
380             =back
381              
382             =over 4
383              
384             =item extend example 3
385              
386             package main;
387              
388             my $ability = {
389             '&access' => sub {time},
390             };
391              
392             my $person = Venus::Prototype->new;
393              
394             my $mrrobot = $person->extend($ability);
395              
396             my $elliot = $mrrobot->extend($ability);
397              
398             # bless({value => {...}}, 'Venus::Prototype')
399              
400             =back
401              
402             =cut
403              
404             =head1 AUTHORS
405              
406             Awncorp, C
407              
408             =cut
409              
410             =head1 LICENSE
411              
412             Copyright (C) 2000, Al Newkirk.
413              
414             This program is free software, you can redistribute it and/or modify it under
415             the terms of the Apache license version 2.0.
416              
417             =cut