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::Class;
  48
  49 sub _immutable_options { }
  50
  51 package Mouse::Meta::Role;
  52
  53 for my $modifier_type (qw/before after around/) {
  54     my $modifier = "${modifier_type}_method_modifiers";
  55     my $has_method_modifiers = sub{
  56         my($self, $method_name) = @_;
  57         my $m = $self->{$modifier}->{$method_name};
  58         return $m && @{$m} != 0;
  59     };
  60
  61     no strict 'refs';
  62     *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
  63 }
  64
  65
  66 sub has_override_method_modifier {
  67     my ($self, $method_name) = @_;
  68     return exists $self->{override_method_modifiers}->{$method_name};
  69 }
  70
  71 sub get_method_modifier_list {
  72     my($self, $modifier_type) = @_;
  73
  74     return keys %{ $self->{$modifier_type . '_method_modifiers'} };
  75 }
  76
  77 package Mouse::Meta::Method;
  78
  79 sub get_original_method { Mouse::Meta::Method->wrap(sub { }) }
  80
  81 sub associated_attribute { undef }
  82
  83 package Mouse::Meta::Method::Constructor;
  84
  85 sub _generate_BUILDALL { }
  86
  87 package Mouse::Meta::Method::Constructor::XS;
  88
  89 sub _generate_BUILDALL { }
  90
  91 package Mouse::Util::TypeConstraints;
  92
  93 use Mouse::Util::TypeConstraints ();
  94
  95 sub export_type_constraints_as_functions { # TEST ONLY
  96     my $into = caller;
  97
  98     foreach my $type( list_all_type_constraints() ) {
  99         my $tc = find_type_constraint($type)->_compiled_type_constraint;
 100         my $as = $into . '::' . $type;
 101
 102         no strict 'refs';
 103         *{$as} = sub{ &{$tc} || undef };
 104     }
 105     return;
 106 }
 107
 108 package Mouse::Meta::Attribute;
 109
 110 sub applied_traits{            $_[0]->{traits} } # TEST ONLY
 111 sub has_applied_traits{ exists $_[0]->{traits} } # TEST ONLY
 112
 113 sub get_raw_value { undef } # not supported
 114 sub set_raw_value { undef } # not supported
 115
 116 package Mouse::Meta::TypeConstraint;
 117
 118 sub has_message { exists $_[0]->{message} }
 119
 120 sub validate {
 121     my($self, $value) = @_;
 122     return $self->check($value) ? undef : $self->get_message($value);
 123 }
 124
 125 sub is_subtype_of {
 126     my($self, $other) = @_;
 127     return undef; # not supported
 128 }
 129
 130 sub equals {
 131     my($self, $other) = @_;
 132     return undef; # not supported
 133 }
 134
 135 sub class { undef }
 136 sub role  { undef }
 137 1;