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