t/001_mouse/100-meta-class.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Exception;
   6 {
   7     package Class;
   8     use Mouse;
   9     use Scalar::Util qw(blessed weaken); # import external functions
  10
  11     has pawn => (
  12         is        => 'rw',
  13         predicate => 'has_pawn',
  14     );
  15
  16     use constant MY_CONST => 42;
  17
  18     sub stub;
  19     sub stub_with_attr :method;
  20
  21     sub king { 'king' }
  22
  23     no Mouse;
  24 }
  25 {
  26     package Child;
  27     use Mouse;
  28     use Carp qw(carp croak); # import extenral functions
  29
  30     extends 'Class';
  31
  32     has bishop => (
  33         is => 'rw',
  34     );
  35
  36     sub child_method{ }
  37 }
  38
  39 my $meta = Class->meta;
  40 isa_ok($meta, 'Mouse::Meta::Class');
  41
  42 is_deeply([$meta->superclasses], ['Mouse::Object'], "correctly inherting from Mouse::Object");
  43
  44 my $meta2 = Class->meta;
  45 is($meta, $meta2, "same metaclass instance");
  46
  47 can_ok($meta, qw(
  48     name meta
  49     has_attribute get_attribute get_attribute_list get_all_attributes
  50     has_method    get_method    get_method_list    get_all_methods
  51 ));
  52
  53 ok($meta->has_attribute('pawn'));
  54 my $attr = $meta->get_attribute('pawn');
  55 isa_ok($attr, 'Mouse::Meta::Attribute');
  56 is($attr->name, 'pawn', 'got the correct attribute');
  57
  58 my $list = [$meta->get_attribute_list];
  59 is_deeply($list, [ 'pawn' ], "attribute list");
  60
  61 ok(!$meta->has_attribute('nonexistent_attribute'));
  62
  63 ok($meta->has_method('pawn'));
  64 lives_and{
  65     my $pawn = $meta->get_method('pawn');
  66     ok($pawn);
  67     is($pawn->name, 'pawn');
  68     is($pawn->package_name, 'Class');
  69     is($pawn->fully_qualified_name, 'Class::pawn');
  70
  71     is $pawn, $pawn;
  72
  73     my $king = $meta->get_method('king');
  74     isnt $pawn, $king;
  75
  76     $meta->add_method(king => sub{ 'fool' });
  77     isnt $king, $meta->get_method('king');
  78 };
  79
  80 is( join(' ', sort $meta->get_method_list),
  81     join(' ', sort qw(meta pawn king has_pawn MY_CONST stub stub_with_attr))
  82 );
  83
  84 eval q{
  85     package Class;
  86     use Mouse;
  87     no Mouse;
  88 };
  89
  90 my $meta3 = Class->meta;
  91 is($meta, $meta3, "same metaclass instance, even if use Mouse is performed again");
  92
  93 is($meta->name, 'Class', "name for the metaclass");
  94
  95
  96 my $child_meta = Child->meta;
  97 isa_ok($child_meta, 'Mouse::Meta::Class');
  98
  99 isnt($meta, $child_meta, "different metaclass instances for the two classes");
 100
 101 is_deeply([$child_meta->superclasses], ['Class'], "correct superclasses");
 102
 103
 104 ok($child_meta->has_attribute('bishop'));
 105 ok($child_meta->has_method('child_method'));
 106
 107
 108 is( join(' ', sort $child_meta->get_method_list),
 109     join(' ', sort qw(meta bishop child_method))
 110 );
 111
 112 can_ok($child_meta, 'find_method_by_name');
 113 is $child_meta->find_method_by_name('child_method')->fully_qualified_name, 'Child::child_method';
 114 is $child_meta->find_method_by_name('pawn')->fully_qualified_name,         'Class::pawn';
 115
 116
 117 is( join(' ', sort map{ $_->fully_qualified_name } grep{ $_->package_name ne 'Mouse::Object' } $child_meta->get_all_methods),
 118     join(' ', sort qw(
 119         Child::bishop Child::child_method Child::meta
 120
 121         Class::MY_CONST Class::has_pawn Class::pawn Class::king Class::stub Class::stub_with_attr
 122     ))
 123 );
 124
 125 done_testing;
 126