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