Commits

Toby Inkster  committed ef548d8

EXTENDS

  • Participants
  • Parent commits dd8a7a8

Comments (0)

Files changed (3)

File lib/MooX/Struct.pm

 	return $hashref;
 }
 
+sub EXTEND
+{
+	my ($invocant, @args) = @_;
+	my $base = ref($invocant) || $invocant;
+	
+	my $processor = 'MooX::Struct::Processor'->new;
+	while (@args and $args[0] =~ /^-(.+)$/) {
+		$processor->flags->{ lc($1) } = !!shift;
+	}
+
+	my $subname = undef;
+	$subname = ${ shift @args } if ref($args[0]) eq 'SCALAR';	
+
+	my $new_class = $processor->make_sub(
+		$subname,
+		[ -extends => [$base], @args ],
+	)->();
+	return $new_class unless ref $invocant;
+	
+	bless $invocant => $new_class;
+}
+
 # This could do with some improvement from a Data::Printer expert.
 #
 my $done = 0;
 	{
 		return sprintf(
 			"%s[\n\t%s,\n]",
-			Term::ANSIColor::colored($self->TYPE, 'bright_yellow'),
+			Term::ANSIColor::colored($self->TYPE||'struct', 'bright_yellow'),
 			join(qq[,\n\t], map { s/\n/\n\t/gm; $_ } @values),
 		);
 	}
 	{
 		return sprintf(
 			'%s[ %s ]',
-			Term::ANSIColor::colored($self->TYPE, 'bright_yellow'),
+			Term::ANSIColor::colored($self->TYPE||'struct', 'bright_yellow'),
 			join(q[, ], @values),
 		);
 	}
 		default  => sub { 'MooX::Struct' },
 	);
 	
-	has 'caller' => (
-		is       => 'ro',
-		required => 1,
-	);
-	
 	has trace => (
 		is       => 'lazy',
 	);
 					$self->process_argument($klass, @$_)
 				} @{ Data::OptList::mkopt($proto) };
 				$self->process_method($klass, FIELDS => sub { @fields });
-				$self->process_method($klass, TYPE   => sub { $subname });
+				$self->process_method($klass, TYPE   => sub { $subname }) if defined $subname;
 				$proto = $klass;
 			}
 			return $proto->new(@_) if @_;
 	
 	sub process
 	{
-		my $self = shift;
+		my $self   = shift;
+		my $caller = shift;
 		
 		while (@_ and $_[0] =~ /^-(.+)$/) {
 			$self->flags->{ lc($1) } = !!shift;
 			
 			$self->class_map->{ $subname } = $self->make_sub($subname, $details);
 			install_sub {
-				into   => $self->caller,
+				into   => $caller,
 				as     => $subname,
 				code   => $self->class_map->{ $subname },
 			};
 		}
 		on_scope_end {
 			namespace::clean->clean_subroutines(
-				$self->caller,
+				$caller,
 				keys %{ $self->class_map },
 			);
 		};
 {
 	my $caller = caller;
 	my $class  = shift;
-	"$class\::Processor"->new(caller => scalar caller)->process(@_);
+	"$class\::Processor"->new->process($caller, @_);
 }
 
 no Moo;
 
 Creates a shallow clone of the object. 
 
+=item C<EXTEND>
+
+An exverimental feature.
+
+Extend a class or object with additional attributes, methods, etc. This method
+takes almost all the same arguments as C<use MooX::Struct>, albeit with some
+slight differences.
+
+ use MooX::Struct Point => [qw/ +x +y /];
+ my $point = Point[2, 3];
+ $point->EXTEND(-rw, q/+z/);  # extend an object
+ $point->can('z');   # true
+ 
+ my $new_class = Point->EXTEND('+z');  # extend a class
+ my $point_3d  = $new_class->new( x => 1, y => 2, z => 3 );
+ $point_3d->TYPE;  # Point !
+ 
+ my $point_4d = $new_class->EXTEND(\"Point4D", '+t');
+ $point_4d->TYPE;  # Point4D
+ 
+ my $origin = Point[]->EXTEND(-with => [qw/ Math::Role::Origin /]);
+
+This feature has been included mostly because it's easy to implement on top
+of the existing code for processing C<use MooX::Struct>. Some subsets of
+this functionality are sane, such as the ability to add traits to an object.
+Others (like the ability to add a new uninitialized, read-only attribute to
+an existing object) are less sensible.
+
 =item C<BUILDARGS>
 
 Moo internal fu.

File meta/changes.pret

 		item "Bundle MooX::Struct::Util."^^Addition;
 		item "Allow structs to consume roles using '-with' option."^^Addition;		
 		item "Constructor is now strict; it will croak if passed hash keys it doesn't recognise."^^Change;
+		item "New experimental method 'EXTEND'."^^Addition;
 	].

File t/11extend.t

+use Test::More;
+use MooX::Struct Point => [qw( +x +y )];
+
+my $point = Point[];
+
+is($point->TYPE, 'Point');
+is_deeply([$point->FIELDS], ['x', 'y']);
+ok( $point->can('x'));
+ok( $point->can('y'));
+ok(!$point->can('z'));
+
+$point->EXTEND(\"Point3D", '+z');
+
+is($point->TYPE, 'Point3D');
+is_deeply([$point->FIELDS], ['x', 'y', 'z']);
+ok( $point->can('x'));
+ok( $point->can('y'));
+ok( $point->can('z'));
+
+
+my $new = $point->CLONE(z => 0)->EXTEND(\"Point4D", '+w');
+is_deeply([$point->FIELDS], ['x', 'y', 'z']);
+is_deeply([$new->FIELDS], ['x', 'y', 'z', 'w']);
+
+done_testing;