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