t/compat/foreign_inheritence.t

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