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 # the original class of the metaclass instance
  12 sub _get_mutable_metaclass_name { $_[0]{__immutable}{original_class} }
  13
  14 sub is_mutable   { 0 }
  15 sub is_immutable { 1 }
  16
  17 sub _immutable_metaclass { ref $_[1] }
  18
  19 sub superclasses {
  20     my $orig = shift;
  21     my $self = shift;
  22     confess "This method is read-only" if @_;
  23     $self->$orig;
  24 }
  25
  26 sub _immutable_cannot_call {
  27     my $name = shift;
  28     Carp::confess "The '$name' method cannot be called on an immutable instance";
  29 }
  30
  31 for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol add_package_symbol/) {
  32     no strict 'refs';
  33     *{__PACKAGE__."::$name"} = sub { _immutable_cannot_call($name) };
  34 }
  35
  36 sub class_precedence_list {
  37     my $orig = shift;
  38     my $self = shift;
  39     @{ $self->{__immutable}{class_precedence_list}
  40             ||= [ $self->$orig ] };
  41 }
  42
  43 sub linearized_isa {
  44     my $orig = shift;
  45     my $self = shift;
  46     @{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] };
  47 }
  48
  49 sub get_all_methods {
  50     my $orig = shift;
  51     my $self = shift;
  52     @{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] };
  53 }
  54
  55 sub get_all_method_names {
  56     my $orig = shift;
  57     my $self = shift;
  58     @{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] };
  59 }
  60
  61 sub get_all_attributes {
  62     my $orig = shift;
  63     my $self = shift;
  64     @{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] };
  65 }
  66
  67 sub get_meta_instance {
  68     my $orig = shift;
  69     my $self = shift;
  70     $self->{__immutable}{get_meta_instance} ||= $self->$orig;
  71 }
  72
  73 sub _method_map {
  74     my $orig = shift;
  75     my $self = shift;
  76     $self->{__immutable}{_method_map} ||= $self->$orig;
  77 }
  78
  79 1;
  80
  81 # ABSTRACT: Implements immutability for metaclass objects
  82
  83 __END__
  84
  85 =pod
  86
  87 =head1 DESCRIPTION
  88
  89 This class provides a pseudo-trait that is applied to immutable metaclass
  90 objects. In reality, it is simply a parent class.
  91
  92 It implements caching and read-only-ness for various metaclass methods.
  93
  94 =cut
  95