t/lib/MooseCompat.pm

   1 package MooseCompat;
   2 # Moose compatible methods/functions
   3
   4 use Test::Builder (); # should load Test::Builder first
   5
   6 use Mouse ();
   7 use Mouse::Util::MetaRole;
   8 use Mouse::Meta::Method;
   9 use Mouse::Meta::Role::Method;
  10
  11 $INC{'Mouse/Meta.pm'}          = __FILE__;
  12 $INC{'Mouse/Meta/Instance.pm'} = __FILE__;
  13 $INC{'Mouse/Deprecated.pm'}    = __FILE__;
  14
  15 *UNIVERSAL::DOES = sub {
  16     my($thing, $role) = @_;
  17     $thing->isa($role);
  18 } unless UNIVERSAL->can('DOES');
  19
  20 $Mouse::Deprecated::deprecated = $Mouse::Deprecated::deprecated = undef; # -w
  21
  22 package Mouse::Util;
  23
  24 sub resolve_metatrait_alias {
  25     return resolve_metaclass_alias( @_, trait => 1);
  26 }
  27
  28 sub ensure_all_roles {
  29     my $consumer = shift;
  30     apply_all_roles($consumer, grep { !does_role($appicant, $_) } @_);
  31     return;
  32 }
  33
  34 package Mouse::Meta::Module;
  35
  36 sub version   { no strict 'refs'; ${shift->name.'::VERSION'}   }
  37 sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
  38 sub identifier {
  39     my $self = shift;
  40     return join '-' => (
  41        $self->name,
  42         ($self->version   || ()),
  43         ($self->authority || ()),
  44     );
  45 }
  46
  47 sub role_applications { }
  48
  49 package Mouse::Meta::Role;
  50
  51 for my $modifier_type (qw/before after around/) {
  52     my $modifier = "${modifier_type}_method_modifiers";
  53     my $has_method_modifiers = sub{
  54         my($self, $method_name) = @_;
  55         my $m = $self->{$modifier}->{$method_name};
  56         return $m && @{$m} != 0;
  57     };
  58
  59     no strict 'refs';
  60     *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
  61 }
  62
  63
  64 sub has_override_method_modifier {
  65     my ($self, $method_name) = @_;
  66     return exists $self->{override_method_modifiers}->{$method_name};
  67 }
  68
  69 sub get_method_modifier_list {
  70     my($self, $modifier_type) = @_;
  71
  72     return keys %{ $self->{$modifier_type . '_method_modifiers'} };
  73 }
  74
  75 package Mouse::Meta::Method;
  76
  77 sub get_original_method { Mouse::Meta::Method->wrap(sub { }) }
  78
  79 sub associated_attribute { undef }
  80
  81 package Mouse::Util::TypeConstraints;
  82
  83 use Mouse::Util::TypeConstraints ();
  84
  85 sub export_type_constraints_as_functions { # TEST ONLY
  86     my $into = caller;
  87
  88     foreach my $type( list_all_type_constraints() ) {
  89         my $tc = find_type_constraint($type)->_compiled_type_constraint;
  90         my $as = $into . '::' . $type;
  91
  92         no strict 'refs';
  93         *{$as} = sub{ &{$tc} || undef };
  94     }
  95     return;
  96 }
  97
  98 package Mouse::Meta::Attribute;
  99
 100 sub applied_traits{            $_[0]->{traits} } # TEST ONLY
 101 sub has_applied_traits{ exists $_[0]->{traits} } # TEST ONLY
 102
 103 sub get_raw_value { undef } # not supported
 104 sub set_raw_value { undef } # not supported
 105
 106 package Mouse::Meta::TypeConstraint;
 107
 108 sub has_message { exists $_[0]->{message} }
 109
 110 sub validate {
 111     my($self, $value) = @_;
 112     return $self->check($value) ? undef : $self->get_message($value);
 113 }
 114
 115 sub is_subtype_of {
 116     my($self, $other) = @_;
 117     return undef; # not supported
 118 }
 119
 120 sub equals {
 121     my($self, $other) = @_;
 122     return undef; # not supported
 123 }
 124
 125 sub class { undef }
 126 sub role  { undef }
 127 1;