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';
  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 sub add_package_symbol    { _immutable_cannot_call() }
  43
  44 sub class_precedence_list {
  45     my $orig = shift;
  46     my $self = shift;
  47     @{ $self->{__immutable}{class_precedence_list}
  48             ||= [ $self->$orig ] };
  49 }
  50
  51 sub linearized_isa {
  52     my $orig = shift;
  53     my $self = shift;
  54     @{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] };
  55 }
  56
  57 sub get_all_methods {
  58     my $orig = shift;
  59     my $self = shift;
  60     @{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] };
  61 }
  62
  63 sub get_all_method_names {
  64     my $orig = shift;
  65     my $self = shift;
  66     @{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] };
  67 }
  68
  69 sub get_all_attributes {
  70     my $orig = shift;
  71     my $self = shift;
  72     @{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] };
  73 }
  74
  75 sub get_meta_instance {
  76     my $orig = shift;
  77     my $self = shift;
  78     $self->{__immutable}{get_meta_instance} ||= $self->$orig;
  79 }
  80
  81 sub get_method_map {
  82     my $orig = shift;
  83     my $self = shift;
  84     $self->{__immutable}{get_method_map} ||= $self->$orig;
  85 }
  86
  87 1;
  88
  89 __END__
  90
  91 =pod
  92
  93 =head1 NAME
  94
  95 Class::MOP::Class::Immutable::Trait - Implements immutability for metaclass objects
  96
  97 =head1 DESCRIPTION
  98
  99 This class provides a pseudo-trait that is applied to immutable metaclass
 100 objects. In reality, it is simply a parent class.
 101
 102 It implements caching and read-only-ness for various metaclass methods.
 103
 104 =head1 AUTHOR
 105
 106 Yuval Kogman E<lt>nothingmuch@cpan.orgE<gt>
 107
 108 =head1 COPYRIGHT AND LICENSE
 109
 110 Copyright 2009 by Infinity Interactive, Inc.
 111
 112 L<http://www.iinteractive.com>
 113
 114 This library is free software; you can redistribute it and/or modify
 115 it under the same terms as Perl itself.
 116
 117 =cut
 118