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 $VERSION   = '0.92_01';
  12 $VERSION = eval $VERSION;
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 # the original class of the metaclass instance
  16 sub _get_mutable_metaclass_name { $_[0]{__immutable}{original_class} }
  17
  18 sub is_mutable   { 0 }
  19 sub is_immutable { 1 }
  20
  21 sub _immutable_metaclass { ref $_[1] }
  22
  23 sub superclasses {
  24     my $orig = shift;
  25     my $self = shift;
  26     confess "This method is read-only" if @_;
  27     $self->$orig;
  28 }
  29
  30 sub _immutable_cannot_call {
  31     my $name = shift;
  32     Carp::confess "The '$name' method cannot be called on an immutable instance";
  33 }
  34
  35 for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol/) {
  36     no strict 'refs';
  37     *{__PACKAGE__."::$name"} = sub { _immutable_cannot_call($name) };
  38 }
  39
  40 sub class_precedence_list {
  41     my $orig = shift;
  42     my $self = shift;
  43     @{ $self->{__immutable}{class_precedence_list}
  44             ||= [ $self->$orig ] };
  45 }
  46
  47 sub linearized_isa {
  48     my $orig = shift;
  49     my $self = shift;
  50     @{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] };
  51 }
  52
  53 sub get_all_methods {
  54     my $orig = shift;
  55     my $self = shift;
  56     @{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] };
  57 }
  58
  59 sub get_all_method_names {
  60     my $orig = shift;
  61     my $self = shift;
  62     @{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] };
  63 }
  64
  65 sub get_all_attributes {
  66     my $orig = shift;
  67     my $self = shift;
  68     @{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] };
  69 }
  70
  71 sub get_meta_instance {
  72     my $orig = shift;
  73     my $self = shift;
  74     $self->{__immutable}{get_meta_instance} ||= $self->$orig;
  75 }
  76
  77 sub get_method_map {
  78     my $orig = shift;
  79     my $self = shift;
  80     $self->{__immutable}{get_method_map} ||= $self->$orig;
  81 }
  82
  83 sub add_package_symbol {
  84     my $orig = shift;
  85     my $self = shift;
  86     confess "Cannot add package symbols to an immutable metaclass"
  87         unless ( caller(3) )[3] eq 'Class::MOP::Package::get_package_symbol';
  88
  89     $self->$orig(@_);
  90 }
  91
  92 1;
  93
  94 __END__
  95
  96 =pod
  97
  98 =head1 NAME
  99
 100 Class::MOP::Class::Immutable::Trait - Implements immutability for metaclass objects
 101
 102 =head1 DESCRIPTION
 103
 104 This class provides a pseudo-trait that is applied to immutable metaclass
 105 objects. In reality, it is simply a parent class.
 106
 107 It implements caching and read-only-ness for various metaclass methods.
 108
 109 =head1 AUTHOR
 110
 111 Yuval Kogman E<lt>nothingmuch@cpan.orgE<gt>
 112
 113 =head1 COPYRIGHT AND LICENSE
 114
 115 Copyright 2009 by Infinity Interactive, Inc.
 116
 117 L<http://www.iinteractive.com>
 118
 119 This library is free software; you can redistribute it and/or modify
 120 it under the same terms as Perl itself.
 121
 122 =cut
 123