File Coverage

blib/lib/MooseX/Prototype.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1 2     2   23756 use 5.008;
  2         6  
  2         63  
2 2     2   10 use strict;
  2         3  
  2         55  
3 2     2   10 use warnings;
  2         7  
  2         53  
4              
5 2     2   2291 use Moose 2.00 ();
  0            
  0            
6             use Data::OptList 0 ();
7             use Sub::Exporter 0 ();
8             use thanks 0 ();
9              
10             my $serial = 0;
11             my $serial_name = sub {
12             sprintf('MooseX::Prototype::__ANON__::%04d', ++$serial);
13             };
14              
15             my $mk_attribute = sub {
16             my ($name, $rw) = @_;
17             Moose::Meta::Attribute::->new($name, is => ($rw||'rw'), isa => 'Any');
18             };
19              
20             my $cloned_attributes = sub {
21             return [
22             map {
23             my $attr = $_;
24             my @clone = ();
25             if ($attr->has_value($_[0]))
26             {
27             my $value = $attr->get_value($_[0]);
28             @clone = ( default => sub{$value} );
29             }
30             $attr->clone(@clone);
31             } $_[0]->meta->get_all_attributes
32             ]
33             };
34              
35             BEGIN {
36             package MooseX::Prototype;
37             our $AUTHORITY = 'cpan:TOBYINK';
38             our $VERSION = '0.003';
39             no thanks;
40              
41             use Sub::Exporter -setup => {
42             exports => [
43             create_class_from_prototype => \&_build_create_class_from_prototype,
44             object => \&_build_object,
45             ],
46             groups => {
47             default => [qw/ object /],
48             },
49             };
50            
51             sub _build_create_class_from_prototype
52             {
53             my ($class, $name, $arg) = @_;
54            
55             my $IS = $arg->{ -is } || 'rw';
56             my $BASE = $arg->{ -base } || 'Moose::Object';
57             my $ROLE = $arg->{ -role } || (
58             $IS eq 'ro'
59             ? 'MooseX::Prototype::Trait::Object::RO'
60             : 'MooseX::Prototype::Trait::Object::RW'
61             );
62            
63             return sub
64             {
65             my ($instance, $opts) = @_;
66             $opts = { name => $opts } if defined $opts && !ref $opts;
67            
68             $opts->{name} ||= $serial_name->();
69            
70             Moose::Meta::Class::->create(
71             $opts->{name},
72             superclasses => [ ref $instance ],
73             roles => [ $ROLE ],
74             attributes => $instance->$cloned_attributes,
75             );
76             return $opts->{name};
77             }
78             }
79            
80             sub _build_object
81             {
82             my ($class, $name, $arg) = @_;
83            
84             my $IS = $arg->{ -is } || 'rw';
85             my $BASE = $arg->{ -base } || 'Moose::Object';
86             my $ROLE = $arg->{ -role } || (
87             $IS eq 'ro'
88             ? 'MooseX::Prototype::Trait::Object::RO'
89             : 'MooseX::Prototype::Trait::Object::RW'
90             );
91            
92             return sub ($)
93             {
94             my $hash = ref $_[0] ? shift : +{@_};
95             my $class = Moose::Meta::Class::->create(
96             $serial_name->(),
97             superclasses => [ $BASE ],
98             roles => [ $ROLE ],
99             attributes => [
100             map { $mk_attribute->($_, $IS) }
101             grep { not /^\&/ }
102             keys %$hash
103             ],
104             methods => {
105             map { ; substr($_, 1) => $hash->{$_} }
106             grep { /^\&/ }
107             keys %$hash
108             },
109             );
110             return $class->name->new({
111             map { ; $_ => $hash->{$_} }
112             grep { not /^\&/ }
113             keys %$hash
114             });
115             }
116             }
117            
118             *create_class_from_prototype = __PACKAGE__->_build_create_class_from_prototype;
119             *object = __PACKAGE__->_build_object;
120             };
121              
122             BEGIN {
123             package MooseX::Prototype::Trait::Object;
124             our $AUTHORITY = 'cpan:TOBYINK';
125             our $VERSION = '0.003';
126             no thanks;
127            
128             use Moose::Role;
129            
130             sub create_class { goto \&MooseX::Prototype::create_class_from_prototype };
131            
132             requires '_attribute_accessor_type';
133            
134             around new => sub {
135             my ($orig, $class, @args) = @_;
136             if (ref $class)
137             {
138             return $class->create_class->new(@args);
139             }
140             $class->$orig(@args);
141             };
142            
143             around [qw/ does DOES /] => sub {
144             my ($orig, $self, $role) = @_;
145             return 1 if $role eq -proto;
146             return $self->$orig($role);
147             };
148            
149             sub extend {
150             my $self = shift;
151             my $hash = ref($_[0]) ? $_[0] : +{@_};
152             my $extension = Moose::Meta::Class::->create(
153             $serial_name->(),
154             superclasses => [ ref $self ],
155             attributes => [
156             map { $mk_attribute->($_) }
157             grep { not /^\&/ }
158             keys %$hash
159             ],
160             methods => {
161             map { ; substr($_, 1) => $hash->{$_} }
162             grep { /^\&/ }
163             keys %$hash
164             },
165             );
166             bless $self, $extension->name;
167             if ($self->DOES('MooseX::Prototype::Trait::Object::RO'))
168             {
169             foreach my $key (keys %$hash)
170             {
171             next if $key =~ /^\&/;
172             # breaks Moose encapsulation :-(
173             $self->{$key} = $hash->{$key};
174             }
175             }
176             else
177             {
178             foreach my $key (keys %$hash)
179             {
180             next if $key =~ /^\&/;
181             $self->$key($hash->{$key});
182             }
183             }
184             return $self;
185             }
186             };
187              
188             BEGIN {
189             package MooseX::Prototype::Trait::Object::RO;
190             our $AUTHORITY = 'cpan:TOBYINK';
191             our $VERSION = '0.003';
192             no thanks;
193             use Moose::Role;
194             with qw( MooseX::Prototype::Trait::Object );
195             sub _attribute_accessor_type { 'ro' };
196             };
197              
198             BEGIN {
199             package MooseX::Prototype::Trait::Object::RW;
200             our $AUTHORITY = 'cpan:TOBYINK';
201             our $VERSION = '0.003';
202             no thanks;
203             use Moose::Role;
204             with qw( MooseX::Prototype::Trait::Object );
205             sub _attribute_accessor_type { 'rw' };
206             };
207              
208             1;
209              
210             __END__
211              
212             =head1 NAME
213              
214             MooseX::Prototype - prototype-based programming for Moose
215              
216             =head1 SYNOPSIS
217              
218             From Wikipedia: I<< "Prototype-based programming is a style of object-oriented
219             programming in which classes are not present, and behaviour reuse (known as
220             inheritance in class-based languages) is performed via a process of cloning
221             existing objects that serve as prototypes." >>
222              
223             use MooseX::Prototype;
224            
225             my $Person = object {
226             name => undef,
227             };
228            
229             my $Employee = $Person->new->extend({
230             job => undef,
231             employer => undef,
232             });
233            
234             my $CivilServant = $Employee->new(
235             employer => 'Government',
236             );
237            
238             $CivilServant->extend({
239             department => undef,
240             });
241            
242             my $bob = $CivilServant->new(
243             name => 'Robert',
244             department => 'HMRC',
245             job => 'Tax Inspector',
246             );
247            
248             print $bob->dump;
249            
250             # $VAR1 = bless( {
251             # name => 'Robert',
252             # job => 'Tax Inspector',
253             # department => 'HMRC',
254             # employer => 'Government'
255             # }, 'MooseX::Prototype::__ANON__::0006' );
256              
257             =head1 DESCRIPTION
258              
259             Due to familiarity with class-based languages such as Java, many
260             programmers assume that object-oriented programming is synonymous with
261             class-based programming. However, class-based programming is just one
262             kind of object-oriented programming style, and other varieties exist
263             such as role-oriented, aspect-oriented and prototype-based programming.
264              
265             A prominent example of a prototype-based programming language is
266             ECMAScript (a.k.a. Javascript/JScript/ActionScript). ECMAScript does
267             provide a thin class-like layer over the top of its prototype-based
268             OO system, which some (even experienced) ECMAScript developers rarely
269             see beyond.
270              
271             This module implements a thin prototype-like layer on top of L<Moose>'s
272             class/role-based toolkit.
273              
274             =head2 Ex-Nihilo Object Creation
275              
276             In prototype-based languages, objects are created by cloning other
277             objects. But it's often useful to be able to magic up an object out of
278             nowhere. MooseX::Prototype provides a convenience function to do this:
279              
280             =over
281              
282             =item C<< object \%attrs >>
283              
284             Creates a new object with the given attributes. The hash is treated
285             as attribute-name, attribute-value pairs, but any names beginning with
286             C<< "&" >> are installed as methods. For example:
287              
288             my $person = object {
289             "name" => "Robert",
290             "&changeName" => sub {
291             my ($self, $newname) = @_;
292             $self->name($newname);
293             },
294             };
295              
296             Objects created this way inherit from L<Moose::Object> and perform the
297             C<MooseX::Prototype::Trait::Object> role.
298              
299             =back
300              
301             =head2 Creating Objects from a Prototype
302              
303             A prototype is just an object. When you create a new object from it,
304             the prototype will be cloned and the new object will inherit all its
305             attributes and methods.
306              
307             =over
308              
309             =item C<< $prototype->new(%attrs) >>
310              
311             Creates a new object which inherits its methods and attributes from
312             C<< $prototype >>. The C<< %attrs >> hash can override attribute values
313             from the prototype, but cannot add new attributes or methods.
314              
315             This method is provided by the C<MooseX::Prototype::Trait::Object>
316             role, so C<< $prototype >> must perform that role.
317              
318             =item C<< $prototype->create_class >>
319              
320             Rather than creating a new object from a prototype, this creates a whole
321             new Moose class which can be used to instantiate objects. If you need to
322             create a whole bunch of objects from a prototype, it is probably more
323             efficient to create a class and use that, rather than just calling C<new>
324             a bunch of times.
325              
326             The class can be given a name, a la:
327              
328             $prototype->create_class("Foo::Bar");
329              
330             Otherwise an arbitary name will be generated and returned.
331              
332             This method is provided by the C<MooseX::Prototype::Trait::Object>
333             role, so C<< $prototype >> must perform that role.
334              
335             =item C<< create_class_from_prototype($prototype) >>
336              
337             A convenience function allowing you to use arbitary Moose objects (which
338             lack the C<create_class> method) as prototypes.
339              
340             Also note:
341              
342             my $obj = create_class_from_prototype($proto)->new(%attrs);
343              
344             This function is not exported by default, but can be exported using:
345              
346             use MooseX::Prototype -all;
347              
348             =back
349              
350             =head2 Extending Existing Objects
351              
352             A key feature of Javascript is that new attributes and methods can be given
353             to an object using simple assignment;
354              
355             my_object.some_attribute = 123;
356             my_object.some_method = function () { return 456 };
357              
358             In MooseX::Prototype, there is an explicit syntax for adding new attributes
359             and methods to an object.
360              
361             =over
362              
363             =item C<< $object->extend(\%attrs) >>
364              
365             As per ex-nihilo object creation, the attribute hashref can define attribute
366             name-value pairs, or new methods with a leading C<< "&" >>.
367              
368             =back
369              
370             =head1 HISTORY
371              
372             Version 0.001 of MooseX::Prototype consisted of just a single function,
373             C<use_as_prototype> which was much the same as C<create_class_from_prototype>.
374              
375             Version 0.002 is an almost complete rewrite.
376              
377             =head1 BUGS
378              
379             Please report any bugs to
380             L<http://rt.cpan.org/Dist/Display.html?Queue=MooseX-Prototype>.
381              
382             =head1 SEE ALSO
383              
384             L<Object::Prototype>,
385             L<Class::Prototyped>,
386             L<JE::Object>.
387              
388             =head1 AUTHOR
389              
390             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
391              
392             =head1 COPYRIGHT AND LICENCE
393              
394             This software is copyright (c) 2012 by Toby Inkster.
395              
396             This is free software; you can redistribute it and/or modify it under
397             the same terms as the Perl 5 programming language system itself.
398              
399             =head1 DISCLAIMER OF WARRANTIES
400              
401             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
402             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
403             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
404