t/lib/MooseCompat.pm

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