Toby Inkster avatar Toby Inkster committed f5c377d

initial version

Comments (0)

Files changed (16)

+use inc::Module::Package 'RDF:standard';
+

examples/basic.pl

+use 5.010;
+use strict;
+use Data::Dumper;
+
+{
+	package Person;
+	use Moose;
+	has name     => (is => 'rw', isa => 'Str');
+	has employer => (is => 'rw', isa => 'Str');
+}
+
+use MooseX::Prototype qw(use_as_prototype);
+my $CivilServant = use_as_prototype( Person->new(employer => 'HMG') );
+
+my $bob = $CivilServant->new(name => 'Bob');
+print Dumper $bob;

examples/method.pl

+use 5.010;
+use strict;
+use Data::Dumper;
+
+{
+	package Person;
+	use Moose;
+	with 'MooseX::Prototype::Role::UseAsPrototype';
+	has name     => (is => 'rw', isa => 'Str');
+	has employer => (is => 'rw', isa => 'Str');
+}
+
+Person->new(employer => 'HMG')->use_as_prototype('CivilServant');
+
+my $bob = CivilServant->new(name => 'Bob');
+print Dumper $bob;

examples/named.pl

+use 5.010;
+use strict;
+use Data::Dumper;
+
+{
+	package Person;
+	use Moose;
+	has name     => (is => 'rw', isa => 'Str');
+	has employer => (is => 'rw', isa => 'Str');
+}
+
+use MooseX::Prototype qw(use_as_prototype);
+use_as_prototype(Person->new(employer => 'HMG'), 'CivilServant');
+
+my $bob = CivilServant->new(name => 'Bob');
+print Dumper $bob;

lib/MooseX/Prototype.pm

+package MooseX::Prototype;
+
+use 5.010;
+use strict;
+use utf8;
+
+BEGIN {
+	$MooseX::Prototype::AUTHORITY = 'cpan:TOBYINK';
+	$MooseX::Prototype::VERSION   = '0.001';
+}
+
+use Sub::Exporter -setup => {
+	exports => [qw(use_as_prototype)],
+};
+
+my $cloned_attributes = sub
+{
+	my ($instance) = @_;
+	
+	my @attrs = map
+	{
+		my $attr = $_;
+		if ($attr->has_value($instance))
+		{
+			my $value = $attr->get_value($instance);
+			$attr->clone(default => sub { $value });
+		}
+		else
+		{
+			$attr->clone;
+		}
+	}
+	$instance->meta->get_all_attributes;
+	
+	return @attrs;
+};
+
+sub use_as_prototype
+{
+	my ($instance, $class) = @_;
+	
+	state $serial = 1;
+	$class //= join q{::}, 'MooseX::Prototype::__ANON__', sprintf q{%04d}, $serial++;
+	
+	Moose::Meta::Class->create(
+		$class,
+		version        => $instance->meta->version,
+		authority      => $instance->meta->authority,
+		superclasses   => [ ref $instance ],
+		attributes     => [ $instance->$cloned_attributes ],
+		);
+	
+	return $class;
+}
+
+__PACKAGE__
+__END__
+
+=head1 NAME
+
+MooseX::Prototype - use an existing object as the template for a class
+
+=head1 SYNOPSIS
+
+ {
+   package Person;
+   use Moose;
+   has name     => (is => 'rw', isa => 'Str');
+   has employer => (is => 'rw', isa => 'Str');
+ }
+ 
+ package main;
+ 
+ use MooseX::Prototype qw(use_as_prototype);
+ 
+ my $template     = Person->new(employer => 'Government');
+ my $CivilServant = use_as_prototype($template);
+ 
+ my $bob = $CivilServant->new(name => 'Bob');
+ say $bob->name;       # Bob
+ say $bob->employer;   # Government
+
+=head1 DESCRIPTION
+
+=head2 C<< use_as_prototype($object) >>
+
+Given a blessed object (must be from a Moose-based class), the
+C<use_as_prototype> function generates a new class such that:
+
+=over
+
+=item * the new class is a subclass of the class the original
+object was blessed into.
+
+=item * all methods available on the original object will be
+available to instances of the new class.
+
+=item * all attributes available on the original object will be
+available to instances of the new class, and the defaults for
+those attributes will reflect the values those attributes had on
+the original object.
+
+=back
+
+In short, it acts like a C<clone> method might, but rather than
+returning a single cloned object, returns a class of clones.
+
+The class name used is not necessarily very nice - it will be
+along the lines of C<< MooseX::Prototype::__ANON__::0007 >>.
+You can provide your own class name as a second parameter:
+
+ my $template = Person->new(employer => 'Government');
+ use_as_prototype($template, 'CivilServant');
+ 
+ my $bob = CivilServant->new(name => 'Bob');
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=MooseX-Prototype>.
+
+=head1 SEE ALSO
+
+L<Object::Prototype>, L<MooseX::Prototype::Role::UseAsPrototype>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

lib/MooseX/Prototype/Role/UseAsPrototype.pm

+package MooseX::Prototype::Role::UseAsPrototype;
+
+use 5.010;
+use strict;
+use utf8;
+
+BEGIN {
+	$MooseX::Prototype::Role::UseAsPrototype::AUTHORITY = 'cpan:TOBYINK';
+	$MooseX::Prototype::Role::UseAsPrototype::VERSION   = '0.001';
+}
+
+use Moose::Role;
+use MooseX::Prototype use_as_prototype => {-as => '___uap' };
+
+sub use_as_prototype
+{
+	goto \&___uap;
+}
+
+__PACKAGE__
+__END__
+
+=head1 NAME
+
+MooseX::Prototype::Role::UseAsPrototype - role providing a use_as_prototype method
+
+=head1 SYNOPSIS
+
+ {
+   package Person;
+   use Moose;
+   with 'MooseX::Prototype::Role::UseAsPrototype';
+   has name     => (is => 'rw', isa => 'Str');
+   has employer => (is => 'rw', isa => 'Str');
+ }
+ 
+ package main;
+ 
+ my $template     = Person->new(employer => 'Government');
+ my $CivilServant = $template->use_as_prototype;
+ 
+ my $bob = $CivilServant->new(name => 'Bob');
+ say $bob->name;       # Bob
+ say $bob->employer;   # Government
+
+=head1 DESCRIPTION
+
+=head2 C<< $object->use_as_prototype >>
+
+Works as per the function of the same name in L<MooseX::Prototype>,
+but should be called as a method.
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=MooseX-Prototype>.
+
+=head1 SEE ALSO
+
+L<Object::Prototype>, L<MooseX::Prototype>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+# This file acts as the project's changelog.
+
+@prefix :        <http://usefulinc.com/ns/doap#> .
+@prefix dcs:     <http://ontologi.es/doap-changeset#> .
+@prefix dc:      <http://purl.org/dc/terms/> .
+@prefix dist:    <http://purl.org/NET/cpan-uri/dist/MooseX-Prototype/> .
+@prefix rdfs:    <http://www.w3.org/2000/01/rdf-schema#> .
+@prefix xsd:     <http://www.w3.org/2001/XMLSchema#> .
+
+dist:project :release dist:v_0-001 .
+dist:v_0-001
+	a               :Version ;
+	dc:issued       "2012-04-20"^^xsd:date ;
+	:revision       "0.001"^^xsd:string ;
+	:file-release   <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/MooseX-Prototype-0.001.tar.gz> ;
+	rdfs:label      "Initial release" .
+
+# This file contains general metadata about the project.
+
+@prefix :        <http://usefulinc.com/ns/doap#> .
+@prefix dc:      <http://purl.org/dc/terms/> .
+@prefix foaf:    <http://xmlns.com/foaf/0.1/> .
+@prefix rdfs:    <http://www.w3.org/2000/01/rdf-schema#> .
+@prefix xsd:     <http://www.w3.org/2001/XMLSchema#> .
+
+<http://purl.org/NET/cpan-uri/dist/MooseX-Prototype/project>
+	a               :Project ;
+	:programming-language "Perl" ;
+	:name           "MooseX-Prototype" ;
+	:shortdesc      "use an existing object as the template for a class" ;
+	:homepage       <https://metacpan.org/release/MooseX-Prototype> ;
+	:download-page  <https://metacpan.org/release/MooseX-Prototype> ;
+	:bug-database   <http://rt.cpan.org/Dist/Display.html?Queue=MooseX-Prototype> ;
+	:created        "2012-04-20"^^xsd:date ;
+	:license        <http://dev.perl.org/licenses/> ;
+	:developer      [ a foaf:Person ; foaf:name "Toby Inkster" ; foaf:mbox <mailto:tobyink@cpan.org> ] .
+
+<http://dev.perl.org/licenses/>
+	dc:title        "the same terms as the perl 5 programming language system itself" .
+

meta/makefile.ttl

+# This file provides instructions for packaging.
+
+@prefix : <http://purl.org/NET/cpan-uri/terms#> .
+
+<http://purl.org/NET/cpan-uri/dist/MooseX-Prototype/project>
+	:perl_version_from _:main ;
+	:version_from _:main ;
+	:readme_from _:main ;
+	:requires "Moose 2.00", "Moose::Role", "strict", "Sub::Exporter", "utf8";
+	:test_requires "Test::More 0.61"  .
+
+_:main <http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#fileName> "lib/MooseX/Prototype.pm" .
+
+use Test::More tests => 1;
+BEGIN { use_ok('MooseX::Prototype') };
+
+{
+	package Local::EmailAddress;
+	use Moose;
+	has [qw/local_part domain_part/] => (is => 'rw', isa => 'Str');
+	sub to_string {
+		my ($self) = @_;
+		join '@', $self->local_part, $self->domain_part;
+	}
+}
+
+use Test::More tests => 5;
+use MooseX::Prototype qw(use_as_prototype);
+
+my $GmailAddress = use_as_prototype(
+	Local::EmailAddress->new( domain_part => 'gmail.com' )
+	);
+ok(defined $GmailAddress);
+
+my $HotmailAddress = use_as_prototype(
+	Local::EmailAddress->new( domain_part => 'hotmail.com' ),
+	'HotmailAddress',
+	);
+is($HotmailAddress, 'HotmailAddress');
+
+my $alice = $GmailAddress->new(local_part => 'alice');
+is($alice->to_string, 'alice@gmail.com');
+
+my $bob = $HotmailAddress->new(local_part => 'bob');
+is($bob->to_string, 'bob@hotmail.com');
+
+my $carol = $HotmailAddress->new(local_part => 'carol', domain_part => 'hotmail.co.uk');
+is($carol->to_string, 'carol@hotmail.co.uk');
+{
+	package Local::EmailAddress;
+	use Moose;
+	with 'MooseX::Prototype::Role::UseAsPrototype';
+	has [qw/local_part domain_part/] => (is => 'rw', isa => 'Str');
+	sub to_string {
+		my ($self) = @_;
+		join '@', $self->local_part, $self->domain_part;
+	}
+}
+
+use Test::More tests => 5;
+
+my $GmailAddress = Local::EmailAddress
+	-> new( domain_part => 'gmail.com' )
+	-> use_as_prototype;
+ok(defined $GmailAddress);
+
+my $HotmailAddress = Local::EmailAddress
+	-> new( domain_part => 'hotmail.com' )
+	-> use_as_prototype('HotmailAddress');
+is($HotmailAddress, 'HotmailAddress');
+
+my $alice = $GmailAddress->new(local_part => 'alice');
+is($alice->to_string, 'alice@gmail.com');
+
+my $bob = $HotmailAddress->new(local_part => 'bob');
+is($bob->to_string, 'bob@hotmail.com');
+
+my $carol = $HotmailAddress->new(local_part => 'carol', domain_part => 'hotmail.co.uk');
+is($carol->to_string, 'carol@hotmail.co.uk');
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+

xt/02pod_coverage.t

+use Test::More;
+use Test::Pod::Coverage;
+
+my @modules = qw(MooseX::Prototype);
+pod_coverage_ok($_, "$_ is covered")
+	foreach @modules;
+done_testing(scalar @modules);
+

xt/03meta_uptodate.t

+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok('MooseX-Prototype', 'MooseX::Prototype');
+
+use Test::EOL;
+all_perl_files_ok();
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.