lib/Class/MOP/Class/Immutable/Trait.pm

   1 package Class::MOP::Class::Immutable::Trait;
   2
   3 use strict;
   4 use warnings;
   5
   6 use MRO::Compat;
   7
   8 use Carp         'confess';
   9 use Scalar::Util 'blessed', 'weaken';
  10
  11 sub meta {
  12     my $self = shift;
  13
  14     # if it is not blessed, then someone is asking
  15     # for the meta of Class::MOP::Class:;Immutable::Trait
  16     return Class::MOP::Class->initialize($self) unless blessed($self);
  17
  18     # otherwise, they are asking for the metaclass
  19     # which has been made immutable, which is itself
  20     # except in the cases where it is a metaclass itself
  21     # that has been made immutable and for that we need
  22     # to dig a bit ...
  23
  24     if ( $self->isa('Class::MOP::Class') ) {
  25         # except this is a lie... oh well
  26         return Class::MOP::class_of( $self->get_mutable_metaclass_name );
  27     }
  28     else {
  29         return $self;
  30     }
  31 }
  32
  33 # the original class of the metaclass instance
  34 sub get_mutable_metaclass_name { $_[0]{__immutable}{original_class} }
  35
  36 sub immutable_options { %{ $_[0]{__immutable}{options} } }
  37
  38 sub is_mutable { 0 }
  39 sub is_immutable { 1 }
  40
  41 sub superclasses {
  42     confess "This method is read-only" if @_ > 1;
  43     $_[0]->next::method;
  44 }
  45
  46 sub _immutable_cannot_call { Carp::confess "This method cannot be called on an immutable instance" }
  47
  48 sub add_method            { shift->_immutable_cannot_call }
  49 sub alias_method          { shift->_immutable_cannot_call }
  50 sub remove_method         { shift->_immutable_cannot_call }
  51 sub add_attribute         { shift->_immutable_cannot_call }
  52 sub remove_attribute      { shift->_immutable_cannot_call }
  53 sub remove_package_symbol { shift->_immutable_cannot_call }
  54
  55 sub class_precedence_list { @{ $_[0]{__immutable}{class_precedence_list} ||= [ shift->next::method ] } }
  56 sub linearized_isa        { @{ $_[0]{__immutable}{linearized_isa}        ||= [ shift->next::method ] } }
  57 sub get_all_methods       { @{ $_[0]{__immutable}{get_all_methods}       ||= [ shift->next::method ] } }
  58 sub get_all_method_names  { @{ $_[0]{__immutable}{get_all_method_names}  ||= [ shift->next::method ] } }
  59 sub get_all_attributes    { @{ $_[0]{__immutable}{get_all_attributes}    ||= [ shift->next::method ] } }
  60
  61 sub get_meta_instance     { $_[0]{__immutable}{get_meta_instance} ||= shift->next::method }
  62 sub get_method_map        { $_[0]{__immutable}{get_method_map} ||= shift->next::method }
  63
  64 sub add_package_symbol {
  65     confess "Cannot add package symbols to an immutable metaclass"
  66         unless ( caller(1) )[3] eq
  67         'Class::MOP::Package::get_package_symbol';
  68
  69     shift->next::method(@_);
  70 }
  71
  72 1;