1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Exception;
{
package Elk;
use strict;
use warnings;
sub new {
my $class = shift;
bless { no_moose => "Elk" } => $class;
}
sub no_moose { $_[0]->{no_moose} }
package Foo::Moose;
use Moose;
extends 'Elk';
has 'moose' => ( is => 'ro', default => 'Foo' );
sub new {
my $class = shift;
my $super = $class->SUPER::new(@_);
return $class->meta->new_object( '__INSTANCE__' => $super, @_ );
}
__PACKAGE__->meta->make_immutable( inline_constructor => 0, debug => 0 );
package Bucket;
use metaclass 'Class::MOP::Class';
__PACKAGE__->meta->add_attribute(
'squeegee' => ( accessor => 'squeegee' ) );
package Old::Bucket::Nose;
# see http://www.moosefoundation.org/moose_facts.htm
use Moose;
extends 'Bucket';
package MyBase;
sub foo { }
package Custom::Meta1;
use base qw(Moose::Meta::Class);
package Custom::Meta2;
use base qw(Moose::Meta::Class);
package SubClass1;
use metaclass 'Custom::Meta1';
use Moose;
extends 'MyBase';
package SubClass2;
use metaclass 'Custom::Meta2';
use Moose;
# XXX FIXME subclassing meta-attrs and immutable-ing the subclass fails
}
my $foo_moose = Foo::Moose->new();
isa_ok( $foo_moose, 'Foo::Moose' );
isa_ok( $foo_moose, 'Elk' );
is( $foo_moose->no_moose, 'Elk',
'... got the right value from the Elk method' );
is( $foo_moose->moose, 'Foo',
'... got the right value from the Foo::Moose method' );
lives_ok {
Old::Bucket::Nose->meta->make_immutable( debug => 0 );
}
'Immutability on Moose class extending Class::MOP class ok';
lives_ok {
SubClass2->meta->superclasses('MyBase');
}
'Can subclass the same non-Moose class twice with different metaclasses';
done_testing;
|
