t/030_method.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More tests => 46;
   5 use Test::Exception;
   6
   7 use Class::MOP;
   8 use Class::MOP::Method;
   9
  10
  11 my $method = Class::MOP::Method->wrap(
  12     sub { 1 },
  13     package_name => 'main',
  14     name         => '__ANON__',
  15 );
  16 is($method->meta, Class::MOP::Method->meta, '... instance and class both lead to the same meta');
  17
  18 is($method->package_name, 'main', '... our package is main::');
  19 is($method->name, '__ANON__', '... our sub name is __ANON__');
  20 is($method->fully_qualified_name, 'main::__ANON__', '... our subs full name is main::__ANON__');
  21 is($method->original_method, undef, '... no original_method ');
  22 is($method->original_package_name, 'main', '... the original_package_name is the same as package_name');
  23 is($method->original_name, '__ANON__', '... the original_name is the same as name');
  24 is($method->original_fully_qualified_name, 'main::__ANON__', '... the original_fully_qualified_name is the same as fully_qualified_name');
  25
  26 dies_ok { Class::MOP::Method->wrap } q{... can't call wrap() without some code};
  27 dies_ok { Class::MOP::Method->wrap([]) } q{... can't call wrap() without some code};
  28 dies_ok { Class::MOP::Method->wrap(bless {} => 'Fail') } q{... can't call wrap() without some code};
  29
  30 dies_ok { Class::MOP::Method->name } q{... can't call name() as a class method};
  31 dies_ok { Class::MOP::Method->body } q{... can't call body() as a class method};
  32 dies_ok { Class::MOP::Method->package_name } q{... can't call package_name() as a class method};
  33 dies_ok { Class::MOP::Method->fully_qualified_name } q{... can't call fully_qualified_name() as a class method};
  34
  35 my $meta = Class::MOP::Method->meta;
  36 isa_ok($meta, 'Class::MOP::Class');
  37
  38 foreach my $method_name (qw(
  39     wrap
  40         package_name
  41         name
  42     )) {
  43     ok($meta->has_method($method_name), '... Class::MOP::Method->has_method(' . $method_name . ')');
  44         my $method = $meta->get_method($method_name);
  45         is($method->package_name, 'Class::MOP::Method', '... our package is Class::MOP::Method');
  46         is($method->name, $method_name, '... our sub name is "' . $method_name . '"');
  47 }
  48
  49 dies_ok {
  50     Class::MOP::Method->wrap()
  51 } '... bad args for &wrap';
  52
  53 dies_ok {
  54     Class::MOP::Method->wrap('Fail')
  55 } '... bad args for &wrap';
  56
  57 dies_ok {
  58     Class::MOP::Method->wrap([])
  59 } '... bad args for &wrap';
  60
  61 dies_ok {
  62     Class::MOP::Method->wrap(sub { 'FAIL' })
  63 } '... bad args for &wrap';
  64
  65 dies_ok {
  66     Class::MOP::Method->wrap(sub { 'FAIL' }, package_name => 'main')
  67 } '... bad args for &wrap';
  68
  69 dies_ok {
  70     Class::MOP::Method->wrap(sub { 'FAIL' }, name => '__ANON__')
  71 } '... bad args for &wrap';
  72
  73 my $clone = $method->clone(
  74     package_name => 'NewPackage',
  75     name         => 'new_name',
  76 );
  77
  78 isa_ok($clone, 'Class::MOP::Method');
  79 is($clone->package_name, 'NewPackage', '... cloned method has new package name');
  80 is($clone->name, 'new_name', '... cloned method has new sub name');
  81 is($clone->fully_qualified_name, 'NewPackage::new_name', '... cloned method has new fq name');
  82 is($clone->original_method, $method, '... cloned method has correct original_method');
  83 is($clone->original_package_name, 'main', '... cloned method has correct original_package_name');
  84 is($clone->original_name, '__ANON__', '... cloned method has correct original_name');
  85 is($clone->original_fully_qualified_name, 'main::__ANON__', '... cloned method has correct original_fully_qualified_name');
  86
  87 my $clone2 = $clone->clone(
  88     package_name => 'NewerPackage',
  89     name         => 'newer_name',
  90 );
  91
  92 is($clone2->package_name, 'NewerPackage', '... clone of clone has new package name');
  93 is($clone2->name, 'newer_name', '... clone of clone has new sub name');
  94 is($clone2->fully_qualified_name, 'NewerPackage::newer_name', '... clone of clone new fq name');
  95 is($clone2->original_method, $clone, '... cloned method has correct original_method');
  96 is($clone2->original_package_name, 'main', '... original_package_name follows clone chain');
  97 is($clone2->original_name, '__ANON__', '... original_name follows clone chain');
  98 is($clone2->original_fully_qualified_name, 'main::__ANON__', '... original_fully_qualified_name follows clone chain');