t/type_constraints/name_conflicts.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Fatal;
   6
   7 use Moose::Util::TypeConstraints;
   8
   9 {
  10     package Types;
  11     use Moose::Util::TypeConstraints;
  12
  13     type 'Foo1';
  14     subtype 'Foo2', as 'Str';
  15     class_type 'Foo3';
  16     role_type 'Foo4';
  17
  18     { package Foo5;     use Moose; }
  19     { package Foo6;     use Moose::Role; }
  20     { package IsaAttr;  use Moose; has foo => (is => 'ro', isa  => 'Foo7'); }
  21     { package DoesAttr; use Moose; has foo => (is => 'ro', does => 'Foo8'); }
  22 }
  23
  24 {
  25     my $anon = 0;
  26     my @checks = (
  27         [1, sub { type $_[0] }, 'type'],
  28         [1, sub { subtype $_[0], as 'Str' }, 'subtype'],
  29         [1, sub { class_type $_[0] }, 'class_type'],
  30         [1, sub { role_type $_[0] }, 'role_type'],
  31         # should these two die?
  32         [0, sub { eval "package $_[0]; use Moose; 1" || die $@ }, 'use Moose'],
  33         [0, sub { eval "package $_[0]; use Moose::Role; 1" || die $@ }, 'use Moose::Role'],
  34         [0, sub {
  35             $anon++;
  36             eval <<CLASS || die $@;
  37             package Anon$anon;
  38             use Moose;
  39             has foo => (is => 'ro', isa => '$_[0]');
  40             1
  41 CLASS
  42         }, 'isa => "Thing"'],
  43         [0, sub {
  44             $anon++;
  45             eval <<CLASS || die $@;
  46             package Anon$anon;
  47             use Moose;
  48             has foo => (is => 'ro', does => '$_[0]');
  49             1
  50 CLASS
  51         }, 'does => "Thing"'],
  52     );
  53
  54     sub check_conflicts {
  55         my ($type_name) = @_;
  56         my $type = find_type_constraint($type_name);
  57         for my $check (@checks) {
  58             my ($should_fail, $code, $desc) = @$check;
  59
  60             $should_fail = 0
  61                 if overriding_with_equivalent_type($type, $desc);
  62             unload_class($type_name);
  63
  64             if ($should_fail) {
  65                 like(
  66                     exception { $code->($type_name) },
  67                     qr/^The type constraint '$type_name' has already been created in [\w:]+ and cannot be created again in [\w:]+/,
  68                     "trying to override $type_name via '$desc' should die"
  69                 );
  70             }
  71             else {
  72                 is(
  73                     exception { $code->($type_name) },
  74                     undef,
  75                     "trying to override $type_name via '$desc' should do nothing"
  76                 );
  77             }
  78             is($type, find_type_constraint($type_name), "type didn't change");
  79         }
  80     }
  81
  82     sub unload_class {
  83         my ($class) = @_;
  84         my $meta = Class::MOP::class_of($class);
  85         return unless $meta;
  86         $meta->add_package_symbol('@ISA', []);
  87         $meta->remove_package_symbol('&'.$_)
  88             for $meta->list_all_package_symbols('CODE');
  89         undef $meta;
  90         Class::MOP::remove_metaclass_by_name($class);
  91     }
  92
  93     sub overriding_with_equivalent_type {
  94         my ($type, $desc) = @_;
  95         if ($type->isa('Moose::Meta::TypeConstraint::Class')) {
  96             return 1 if $desc eq 'use Moose'
  97                      || $desc eq 'class_type'
  98                      || $desc eq 'isa => "Thing"';
  99         }
 100         if ($type->isa('Moose::Meta::TypeConstraint::Role')) {
 101             return 1 if $desc eq 'use Moose::Role'
 102                      || $desc eq 'role_type'
 103                      || $desc eq 'does => "Thing"';
 104         }
 105         return;
 106     }
 107 }
 108
 109 {
 110     check_conflicts($_) for map { "Foo$_" } 1..8;
 111 }
 112
 113 done_testing;