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 sub meta {
  12     my $self = shift;
  13
  14     # if it is not blessed, then someone is asking
  15     # for the meta of Class::MOP::Class:;Immutable::Trait
  16     return Class::MOP::Class->initialize($self) unless blessed($self);
  17
  18     # otherwise, they are asking for the metaclass
  19     # which has been made immutable, which is itself
  20     # except in the cases where it is a metaclass itself
  21     # that has been made immutable and for that we need
  22     # to dig a bit ...
  23
  24     if ( $self->isa('Class::MOP::Class') ) {
  25
  26         # except this is a lie... oh well
  27         return Class::MOP::class_of( $self->get_mutable_metaclass_name );
  28     }
  29     else {
  30         return $self;
  31     }
  32 }
  33
  34 # the original class of the metaclass instance
  35 sub get_mutable_metaclass_name { $_[0]{__immutable}{original_class} }
  36
  37 sub immutable_options { %{ $_[0]{__immutable}{options} } }
  38
  39 sub is_mutable   {0}
  40 sub is_immutable {1}
  41
  42 sub superclasses {
  43     confess "This method is read-only" if @_ > 1;
  44     $_[0]->next::method;
  45 }
  46
  47 sub _immutable_cannot_call {
  48     Carp::confess "This method cannot be called on an immutable instance";
  49 }
  50
  51 sub add_method            { shift->_immutable_cannot_call }
  52 sub alias_method          { shift->_immutable_cannot_call }
  53 sub remove_method         { shift->_immutable_cannot_call }
  54 sub add_attribute         { shift->_immutable_cannot_call }
  55 sub remove_attribute      { shift->_immutable_cannot_call }
  56 sub remove_package_symbol { shift->_immutable_cannot_call }
  57
  58 sub class_precedence_list {
  59     @{ $_[0]{__immutable}{class_precedence_list}
  60             ||= [ shift->next::method ] };
  61 }
  62
  63 sub linearized_isa {
  64     @{ $_[0]{__immutable}{linearized_isa} ||= [ shift->next::method ] };
  65 }
  66
  67 sub get_all_methods {
  68     @{ $_[0]{__immutable}{get_all_methods} ||= [ shift->next::method ] };
  69 }
  70
  71 sub get_all_method_names {
  72     @{ $_[0]{__immutable}{get_all_method_names} ||= [ shift->next::method ] };
  73 }
  74
  75 sub get_all_attributes {
  76     @{ $_[0]{__immutable}{get_all_attributes} ||= [ shift->next::method ] };
  77 }
  78
  79 sub get_meta_instance {
  80     $_[0]{__immutable}{get_meta_instance} ||= shift->next::method;
  81 }
  82
  83 sub get_method_map {
  84     $_[0]{__immutable}{get_method_map} ||= shift->next::method;
  85 }
  86
  87 sub add_package_symbol {
  88     confess "Cannot add package symbols to an immutable metaclass"
  89         unless ( caller(1) )[3] eq 'Class::MOP::Package::get_package_symbol';
  90
  91     shift->next::method(@_);
  92 }
  93
  94 1;
  95
  96 __END__
  97
  98 =pod
  99
 100 =head1 NAME
 101
 102 Class::MOP::Class::Immutable::Trait - Implements immutability for metaclass objects
 103
 104 =head1 DESCRIPTION
 105
 106 This class provides a trait that is applied to immutable metaclass
 107 objects. This is deep guts.
 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