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