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