Commits

Toby Inkster committed c7fef7a

isa support; major refactor

Comments (0)

Files changed (2)

lib/MooX/Struct.pm

 }
 
 use Moo             1.000000;
-use Data::OptList   0         qw();
-use Sub::Install    0         qw();
-use Scalar::Does    0         qw( does );
 use Object::ID      0         qw( object_id );
 
-my $counter = 0;
-my $generate_class_name = sub
-{
-	return sprintf('%s::__ANON__::%04d', __PACKAGE__, ++$counter);
+BEGIN {
+	package MooX::Struct::Processor;
+	
+	use Moo             1.000000;
+	use Carp            0         qw( confess      );
+	use Data::OptList   0         qw(              );
+	use Sub::Install    0         qw( install_sub  );
+	use Scalar::Does    0         qw( does blessed );
+	
+	has flags => (
+		is       => 'ro',
+		isa      => does('HASH'),
+		default  => sub { +{} },
+	);
+	
+	has class_map => (
+		is       => 'ro',
+		isa      => does('HASH'),
+		default  => sub { +{} },
+	);
+	
+	has base => (
+		is       => 'ro',
+		default  => sub { 'MooX::Struct' },
+	);
+	
+	has 'caller' => (
+		is       => 'ro',
+		required => 1,
+	);
+	
+	my $counter = 0;
+	sub create_class
+	{
+		my $self  = shift;
+		my $klass = sprintf('%s::__ANON__::%04d', $self->base, ++$counter);
+		Moo->_set_superclasses($klass, $self->base);
+		Moo->_maybe_reset_handlemoose($klass);
+		return $klass;
+	}
+	
+	sub process_meta
+	{
+		my ($self, $klass, $name, $val) = @_;
+		
+		my @parents = map {
+			exists $self->class_map->{$_}
+				? $self->class_map->{$_}->()
+				: $_
+		} @$val;
+		
+		Moo->_set_superclasses($klass, @parents);
+		Moo->_maybe_reset_handlemoose($klass);
+		return;
+	}
+	
+	sub process_method
+	{
+		my ($self, $klass, $name, $coderef) = @_;
+		Sub::Install::install_sub {
+			into   => $klass,
+			as     => $name,
+			code   => $coderef,
+		};
+		return;
+	}
+	
+	sub process_spec
+	{
+		my ($self, $klass, $name, $val) = @_;
+		my $accessor_type = $self->flags->{rw} ? 'rw' : 'ro';
+		
+		my %spec = (
+			is => $accessor_type,
+			( does($val, 'ARRAY')
+				? @$val
+				: ( does($val,'HASH') ? %$val : () )
+			),
+		);
+		
+		if ($name =~ /^\@(.+)/)
+		{
+			$name = $1;
+			$spec{isa} ||= does('ARRAY');
+		}
+		elsif ($name =~ /^\%(.+)/)
+		{
+			$name = $1;
+			$spec{isa} ||= does('HASH');
+		}
+		elsif ($name =~ /^\$(.+)/)
+		{
+			$name = $1;
+			$spec{isa} ||= sub { blessed($_[0]) or not ref($_[0]) };
+		}
+		
+		return \%spec;
+	}
+	
+	sub process_attribute
+	{
+		my ($self, $klass, $name, $val) = @_;
+		
+		my $spec = $self->process_spec($klass, $name, $val);
+		
+		Moo
+			->_constructor_maker_for($klass)
+			->register_attribute_specs($name, $spec);
+			
+		Moo
+			->_accessor_maker_for($klass)
+			->generate_method($klass, $name, $spec);
+			
+		Moo
+			->_maybe_reset_handlemoose($klass);
+		
+		return;
+	}
+	
+	sub process_argument
+	{
+		my $self = shift;
+		my ($klass, $name, $val) = @_;
+		
+		confess("attribute '$name' seems to private")
+			if $name =~ /^___/; # these are reserved for now!
+		
+		return $self->process_meta(@_)      if $name =~ /^-/;
+		return $self->process_method(@_)    if does($val, 'CODE');
+		return $self->process_attribute(@_);
+	}
+	
+	sub make_sub
+	{
+		my ($self, $subname, $proto) = @_;
+		return sub ()
+		{
+			if (ref $proto) # inflate!
+			{
+				my $klass = $self->create_class;
+				$self->process_argument($klass, @$_)
+					for @{ Data::OptList::mkopt($proto) };
+				$proto = $klass;
+			}
+			return $proto;
+		}
+	}
+	
+	sub process
+	{
+		my $self = shift;
+		
+		while ($_[0] =~ /^-(.+)$/) {
+			$self->flags->{ lc($1) } = 1;
+		}
+		
+		foreach my $arg (@{ Data::OptList::mkopt(\@_) })
+		{
+			my ($subname, $details) = @$arg;
+			$details = [] unless defined $details;
+			
+			$self->class_map->{ $subname } = $self->make_sub($subname, $details);
+			Sub::Install::install_sub {
+				into   => $self->caller,
+				as     => $subname,
+				code   => $self->class_map->{ $subname },
+			};
+		}
+	}
 };
 
 sub import
 {
 	my $caller = caller;
-	my $me     = shift;
-	my @args   = @{ Data::OptList::mkopt(\@_) };
-	
-	foreach my $arg (@args)
-	{
-		my ($subname, $class) = @$arg;
-		$class = [] unless defined $class;
-		
-		Sub::Install::install_sub {
-			into   => $caller,
-			as     => $subname,
-			code   => sub ()
-			{
-				if (ref $class) # inflate!
-				{
-					my @attrs = @{ Data::OptList::mkopt($class) };
-					$class = $generate_class_name->();
-					Moo->_set_superclasses($class, __PACKAGE__);
-					Moo->_maybe_reset_handlemoose($class);
-					foreach my $attr (@attrs)
-					{
-						my ($name, $val) = @$attr;
-						if (does $val, 'CODE')
-						{
-							Sub::Install::install_sub {
-								into   => $class,
-								as     => $name,
-								code   => $val,
-							};
-						}
-						else
-						{
-							my %spec = (
-								is => 'ro',
-								( does($val, 'ARRAY')
-									? @$val
-									: ( does($val,'HASH') ? %$val : () )
-								),
-							);
-							Moo->_constructor_maker_for($class)
-								->register_attribute_specs($name, \%spec);
-							Moo->_accessor_maker_for($class)
-								->generate_method($class, $name, \%spec);
-							Moo->_maybe_reset_handlemoose($class);
-						}
-					}
-				}
-				return $class;
-			},
-		};
-	}
+	my $class  = shift;
+	"$class\::Processor"->new(caller => scalar caller)->process(@_);
 }
 
 no Moo;
 
 =head1 SYNOPSIS
 
+ use MooX::Struct
+    Point   => [ 'x', 'y' ],
+    Point3D => [ -isa => ['Point'], 'z' ],
+ ;
+ 
+ my $origin = Point3D->new(x => 0, y => 0, z => 0);
+
 =head1 DESCRIPTION
 
+MooX::Struct allows you to create cheap struct-like classes for your data
+using L<Moo>.
+
+While similar in spirit to L<MooseX::Struct> and L<Class::Struct>, 
+MooX::Struct has a somewhat different usage pattern. Rather than providing
+you with a C<struct> keyword which can be used to define structs, you
+define all the structs as part of the C<use> statement. This means they
+happen at compile time.
+
+A struct is just an "anonymous" Moo class. MooX::Struct creates this class
+for you, and installs an alias for it in your namespace (like L<aliased>
+does). Thus your module can create a "Point3D" struct, and some other module
+can too, and they won't interfere with each other.
+
+
+
 =head1 BUGS
 
 Please report any bugs to
 
 =head1 SEE ALSO
 
+L<Moo>, L<MooseX::Struct>, L<Class::Struct>.
+
 =head1 AUTHOR
 
 Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
 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
+use strict;
+use Test::More tests => 20;
+use MooX::Struct
+	Agent        => [ name => undef ],
+	Organisation => [ -isa => ['Agent'], employees => undef, company_number => [is => 'rw']],
+	Person       => [ -isa => ['Agent'] ];
+
+my $alice = Person->new(name => 'Alice');
+my $bob   = Person->new(name => 'Bob');
+my $acme  = Organisation->new(name => 'ACME', employees => [$alice, $bob]);
+
+note sprintf("Agent class:         %s", Agent);
+note sprintf("Person class:        %s", Person);
+note sprintf("Organisation class:  %s", Organisation);
+
+is(
+	ref($alice),
+	ref($bob),
+	'Alice and Bob are in the same class',
+);
+
+isnt(
+	ref($alice),
+	ref($acme),
+	'Alice and ACME are not in the same class',
+);
+
+isa_ok($_, 'MooX::Struct', '$'.lc($_->name)) for ($alice, $bob, $acme);
+
+isa_ok($alice, Agent);
+isa_ok($bob, Agent);
+isa_ok($acme, Agent);
+isa_ok($alice, Person);
+isa_ok($bob, Person);
+isa_ok($acme, Organisation);
+isa_ok(Organisation, Agent);
+isa_ok(Person, Agent);
+
+is($alice->name, 'Alice', '$alice is called Alice');
+is($bob->name, 'Bob', '$bob is called Bob');
+is($acme->name, 'ACME', '$acme is called ACME');
+
+ok !eval {
+	$acme->name('Acme Inc'); 1
+}, 'accessors are read-only by default';
+
+$acme->company_number(12345);
+is($acme->company_number, 12345, 'accessors can be made read-write');
+
+can_ok $alice => 'object_id';
+isnt($alice->object_id, $bob->object_id, 'object_id is unique identifier');
+
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.