Commits

Toby Inkster committed 887cb7e

100% on Devel::Cover

Comments (0)

Files changed (10)

lib/MooX/Struct.pm

 			} 0 .. $#values
 		}
 	}
-	
+
+	elsif (@_ == 1 and does($_[0], 'HASH') and not ref($_[0]) eq 'HASH')
+	{
+		# help Moo::Object!
+		@_ = +{ %{$_[0]} };
+	}
+
 	my $hashref = $class->SUPER::BUILDARGS(@_);
 	
 #	my %tmp = map { $_ => 1 } keys %$hashref;
 sub EXTEND
 {
 	my ($invocant, @args) = @_;
-	my $base = ref($invocant) || $invocant;
+	my $base = $invocant;
+	$base = ref $invocant if ref $invocant;
 	
 	my $processor = 'MooX::Struct::Processor'->new;
-	while (@args and $args[0] =~ /^-(.+)$/) {
+	while (@args) {
+		last unless $args[0] =~ /^-(.+)$/;
 		$processor->flags->{ lc($1) } = !!shift @args;
 	}
 
 	my $self   = shift;
 	
 	my @values = map { scalar &Data::Printer::p(\$_) } @$self;
+	my $label  = Term::ANSIColor::colored($self->TYPE||'struct', 'bright_yellow');
 
 	if (grep /\n/, @values)
 	{
 		return sprintf(
 			"%s[\n\t%s,\n]",
-			Term::ANSIColor::colored($self->TYPE||'struct', 'bright_yellow'),
+			$label,
 			join(qq[,\n\t], map { s/\n/\n\t/gm; $_ } @values),
 		);
 	}
-	else
-	{
-		return sprintf(
-			'%s[ %s ]',
-			Term::ANSIColor::colored($self->TYPE||'struct', 'bright_yellow'),
-			join(q[, ], @values),
-		);
-	}
+	
+	sprintf('%s[ %s ]', $label, join q[, ], @values);
 }
 
 BEGIN {
 			$klass = ref($o->[1]) eq 'ARRAY' ? join('::', @{$o->[1]}) : ${$o->[1]};
 			last;
 		}
-		$klass ||= sprintf('%s::__ANON__::%04d', $self->base, ++$counter);
+		$klass = sprintf('%s::__ANON__::%04d', $self->base, ++$counter) unless defined $klass;
 		"Moo"->_set_superclasses($klass, $self->base);
 		"Moo"->_maybe_reset_handlemoose($klass);
 		if ($self->trace)
 		my ($self, $subname, $proto) = @_;
 		return sub (;$)
 		{
-			1 if $] < 5.014; # bizarre, but necessary!
+			1; # bizarre, but necessary if $] < 5.014
 			if (ref $proto)  # inflate!
 			{
 				my $opts   = Data::OptList::mkopt($proto);
 =cut
 
 use Test::More;
-use Scalar::Does;
+use Scalar::Does qw( does looks_like_number );
 use MooX::Struct
 	Structure => [
 		qw( $value %dict @list ),
-		'%list2' => [ isa => sub { die unless does $_[0], 'ARRAY' } ],
+		'@value2' => { isa => sub { die if ref $_[0] } },
+		'%list2'  => [ isa => sub { die unless does $_[0], 'ARRAY' } ],
+		'$dict2'  => [ isa => sub { die unless does $_[0], 'HASH' } ],
 	],
 	OtherStructure => [qw( id! ego )],
+	Point    => ['+x', '+y' => [default => sub { 101 }]],
+	Point3D  => [-extends => ['Point'], '+z' => [isa => sub { die unless looks_like_number($_[0]) || !defined $_[0] }]],
+	PointReq => ['+x!', '+y!'],
 ;
 
 ok eval {
 };
 
 ok eval {
+	Structure->new( value2 => "Hello World" );
+};
+
+ok eval {
 	Structure->new( list2 => [] );
 };
 
+ok eval {
+	Structure->new( dict2 => {foo => 42} );
+};
+
 ok !eval {
 	Structure->new( value => [] )
 };
 };
 
 ok !eval {
+	Structure->new( value2 => [] );
+};
+
+ok !eval {
 	Structure->new( list2 => +{} );
 };
 
+ok !eval {
+	Structure->new( dict2 => 42 );
+};
+
 ok eval {
 	OtherStructure->new(id => undef);
 };
 	OtherStructure->new(ego => undef);
 };
 
+my $point = Point->new;
+ok defined $point->x;
+ok defined $point->y;
+is($point->x, 0);
+is($point->y, 101);
+
+ok eval {
+	Point[ 42, 42 ];
+	Point[ 42.1, 42.2 ];
+	Point[ "99", "999" ];
+	Point[ "+Inf", "-Inf" ];
+};
+
+ok not eval {
+	Point[ "Hello", "World" ];
+};
+
+ok not eval {
+	Point[ "", "" ];
+};
+
+ok not eval {
+	Point[ "Hello", "99" ];
+};
+
+ok eval {
+	Point3D[ 1, 2 ];
+	Point3D[ 1, 2, 3 ];
+	Point3D[ 1, 2, undef ];
+};
+
+is_deeply(
+	Point3D->new->TO_ARRAY,
+	[ 0, 101, 0 ],
+);
+
+ok not eval {
+	Point3D[ 1, 2, "Hello" ];
+};
+
+ok eval {
+	PointReq[ 1, 2 ];
+	PointReq[ 0, '-Inf' ];
+	PointReq[ 0, 0 ];
+};
+
+ok not eval {
+	PointReq[ ];
+};
+
+ok not eval {
+	PointReq[ "abc", 0 ];
+};
+
 done_testing();

t/08alt-constructor.t

 is("$point2", "3 4 5");
 is("$point3", "3 4 0");
 
+is(
+	Point3D->new([3, 4, 5])->TO_STRING,
+	"3 4 5",
+);
+
+is(
+	Point3D->new({ z=>1, y=>2, x=>3, y=>4, z=>5 })->TO_STRING,
+	"3 4 5",
+);
+
+ok not eval {
+	Point3D->new( \*STDERR )
+};
+
+ok not eval {
+	Point3D[1, 2, 3, 4]
+};
+
+{
+	package Local::WeirdHash;
+	use overload '@{}' => 'TO_ARRAY';
+	sub TO_ARRAY {
+		my $self = shift;
+		[ sort keys %$self ];
+	}
+}
+
+my $weird = bless { z=>1, y=>2, x=>3, y=>4, z=>5 }, 'Local::WeirdHash';
+is(
+	Point3D->new($weird)->TO_STRING,
+	"3 4 5",
+	'if constructed with an object that "does" array and hash, hash is preferred',
+);
+
 done_testing();
 
 isnt($new->OBJECT_ID, $old_id, 'OBJECT_ID does change during CLONE+EXTEND');
 
+use MooX::Struct Person => ['$name'];
+
+my $Employee = Person->EXTEND(\"Employee", '$title');
+isa_ok($Employee, Person);
+
+my $bob = $Employee->new(['Robert', 'Staff']);
+isa_ok($bob, $Employee);
+isa_ok($bob, Person);
+is($bob->TYPE, 'Employee');
+is_deeply([$bob->FIELDS], [qw/ name title /]);
+is($bob->name, 'Robert');
+is($bob->title, 'Staff');
+ok !eval { $bob->title('Manager') };  # read-only
+
+my $PromotableEmployee = Person->EXTEND(-rw, \"PromotableEmployee", '$title');
+isa_ok($PromotableEmployee, Person);
+my $alice = $PromotableEmployee->new(['Alice', 'Staff']);
+isa_ok($alice, $PromotableEmployee);
+isa_ok($alice, Person);
+is($alice->TYPE, 'PromotableEmployee');
+is_deeply([$alice->FIELDS], [qw/ name title /]);
+is($alice->name, 'Alice');
+is($alice->title, 'Staff');
+$alice->title('Manager');  # read-write
+is($alice->title, 'Manager');
+
 done_testing;

t/13baseclass.t

-use strict;
-use warnings;
-use Test::More;
-
-use MooX::Struct;
-
-my $obj = MooX::Struct->new;
-is($obj->TYPE, undef);
-is_deeply([$obj->FIELDS], []);
-
-done_testing;
+use strict;
+use warnings;
+use Test::More;
+
+use MooX::Struct;
+
+my $obj = MooX::Struct->new;
+is($obj->TYPE, undef);
+is_deeply([$obj->FIELDS], []);
+
+done_testing;
 use strict;
 use warnings;
 
-use Test::More (
-	$] < 5.010
-		? (skip_all => 'need Perl 5.10')
-		: ()
-);
+use if ($] < 5.010), 'Test::More', skip_all => 'need Perl 5.10';
+use Test::More;
 
 use 5.010;
-use Test::More;
 use MooX::Struct ();
 use IO::Handle;
 
+my $default = "MooX::Struct::Processor"->new(trace => 1);
+is($default->trace_handle, \*STDERR);
+
 my $output;
 open my $handle, '>', \$output;
 my $proc = "MooX::Struct::Processor"->new(trace => 1, trace_handle => $handle);
 
-
 $proc->process(
 	__PACKAGE__,
 	Something => ['$foo', announce_foo => sub { say shift->foo } ],
 		-isa         => [Something()],
 		-with        => ['Local::Role'],
 		announce_foo => sub { my $self = shift; print $self->foo, "\n" },
+		'+number', 'random',
 	],
 );
 
 like($output, qr{package Something::Else});
 like($output, qr{with qw.Local::Role.});
 like($output, qr{print \$self->foo});
+like($output, qr{looks_like_number});
+
+{
+	local $ENV{PERL_MOOX_STRUCT_TRACE} = 1;
+	ok "MooX::Struct::Processor"->new->trace;
+}
+ok not "MooX::Struct::Processor"->new->trace;
 
 done_testing;
+use strict;
+use warnings;
+use Test::More;
+use MooX::Struct ();
+
+ok not eval {
+	"MooX::Struct::Processor"->new(flags => 1);
+};
+
+ok not eval {
+	"MooX::Struct::Processor"->new(class_map => 1);
+};
+
+ok not eval {
+	"MooX::Struct::Processor"->new->process(
+		__PACKAGE__,
+		Foo => [ -monkey => ['Albert'] ],
+	);
+	Foo();
+};
+like($@, qr{option '-monkey' unknown});
+
+done_testing;

t/97dataprinter.t

 use Test::More;
 
 use Data::Printer colored => 0;
-use MooX::Struct Something => [qw( $foo $bar )];
+use MooX::Struct Something => [qw( $foo bar )];
 
 my $obj = Something->new(foo => 1, bar => 2);
 my $str = p $obj;
 
 is($str, 'Something[ 1, 2 ]');
 
+my $ob2 = Something->new(foo => "Hello\nWorld", bar => ["A","B\nC","D"]);
+my $st2 = p $ob2;
+like("$st2\n", qr{^Something\[\n}s, 'dump including line breaks');
+
+my $ext = Something->EXTEND('$baz')->new([1, 2, 3]);
+my $pxt = p $ext;
+
+is($pxt, 'Something[ 1, 2, 3 ]');
+
+my $bas = MooX::Struct->new;
+my $pas = p $bas;
+
+is($pas, 'struct[  ]');
+
 done_testing;
 is($bar->foo, 1);
 is($bar->bar, 2);
 
+# The "interesting" thing about this package is that it provides
+# no FIELDS method.
+BEGIN {
+	package Quux;
+	use Moo;
+	has bumf => (is => 'rw');
+};
+
+BEGIN {
+	"MooX::Struct::Processor"
+		-> new(
+			base  => 'Quux',
+			flags => { retain => 1 },
+		)
+		-> process(
+			main => (
+				Quuux => ['$xyzzy'],
+				Quuuux => (),
+			),
+		)
+	;
+};
+
+my $quuux = Quuux->new(xyzzy => 4, bumf => 2);
+is_deeply([$quuux->FIELDS], ['xyzzy']);
+is($quuux->xyzzy, 4);
+is($quuux->bumf, 2);
+like(ref $quuux, qr{^Quux::__ANON__::});
+
+my $quuuux = Quuuux->new(bumf => 2);
+is_deeply([$quuuux->FIELDS], []);
+is($quuuux->bumf, 2);
+like(ref $quuuux, qr{^Quux::__ANON__::});
+
+
+BEGIN {
+	"MooX::Struct::Processor"
+		-> new(
+			flags => { retain => 1 },
+		)
+		-> process(
+			main => (
+				Quux2 => [ -extends=>['Quux'], '$xyzzy' ],
+			),
+		)
+	;
+};
+is_deeply([Quux2->FIELDS], ['xyzzy']);
+
 done_testing;