Update Changes, bump version to 0.97_01, make copyright 2006-2010
[gitmo/Class-MOP.git] / 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.97_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