[gitmo/Class-MOP.git] / lib / Class / MOP / Immutable.pm


package Class::MOP::Immutable;

use strict;
use warnings;

use Class::MOP::Method::Constructor;

use Carp         'confess';
use Scalar::Util 'blessed';

our $VERSION   = '0.71_01';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';

use base 'Class::MOP::Object';

sub new {
    my ($class, @args) = @_;

    my ( $metaclass, $options );

    if ( @args == 2 ) {
        # compatibility args
        ( $metaclass, $options ) = @args;
    } else {
        unshift @args, "metaclass" if @args % 2 == 1;

        # default named args
        my %options = @args;
        $options = \%options;
        $metaclass = $options{metaclass};
    }

    my $self = $class->_new(
        'metaclass'           => $metaclass,
        'options'             => $options,
        'immutable_metaclass' => undef,
    );

    return $self;
}

sub _new {
    my $class = shift;
    my $options = @_ == 1 ? $_[0] : {@_};

    bless $options, $class;
}

sub immutable_metaclass {
    my $self = shift;

    $self->create_immutable_metaclass unless $self->{'immutable_metaclass'};

    return $self->{'immutable_metaclass'};
}

sub metaclass           { (shift)->{'metaclass'}           }
sub options             { (shift)->{'options'}             }

sub create_immutable_metaclass {
    my $self = shift;

    # NOTE:
    # The immutable version of the
    # metaclass is just a anon-class
    # which shadows the methods
    # appropriately
    $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
        superclasses => [ blessed($self->metaclass) ],
        methods      => $self->create_methods_for_immutable_metaclass,
    );
}


my %DEFAULT_METHODS = (
    # I don't really understand this, but removing it breaks tests (groditi)
    meta => sub {
        my $self = shift;
        # if it is not blessed, then someone is asking
        # for the meta of Class::MOP::Immutable
        return Class::MOP::Class->initialize($self) unless blessed($self);
        # otherwise, they are asking for the metaclass
        # which has been made immutable, which is itself
        # except in the cases where it is a metaclass itself
        # that has been made immutable and for that we need 
        # to dig a bit ...
        if ($self->isa('Class::MOP::Class')) {
            return $self->{'___original_class'}->meta;
        }
        else {
            return $self;
        }
    },
    is_mutable     => sub { 0  },
    is_immutable   => sub { 1  },
    make_immutable => sub { () },
);

# NOTE:
# this will actually convert the
# existing metaclass to an immutable
# version of itself
sub make_metaclass_immutable {
    my ($self, $metaclass, $options) = @_;

    my %options = (
        inline_accessors   => 1,
        inline_constructor => 1,
        inline_destructor  => 0,
        constructor_name   => 'new',
        debug              => 0,
        %$options,
    );

    %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(

    $self->_inline_accessors( $metaclass, \%options );
    $self->_inline_constructor( $metaclass, \%options );
    $self->_inline_destructor( $metaclass, \%options );
    $self->_memoize_methods( $metaclass, \%options );

    $metaclass->{'___original_class'} = blessed($metaclass);
    bless $metaclass => $self->immutable_metaclass->name;
}

sub _inline_accessors {
    my ( $self, $metaclass, $options ) = @_;

    return unless $options->{inline_accessors};

    foreach my $attr_name ( $metaclass->get_attribute_list ) {
        $metaclass->get_attribute($attr_name)->install_accessors(1);
    }
}

sub _inline_constructor {
    my ( $self, $metaclass, $options ) = @_;

    return unless $options->{inline_constructor};

    my $constructor_class = $options->{constructor_class}
        || 'Class::MOP::Method::Constructor';
    $metaclass->add_method(
        $options->{constructor_name},
        $constructor_class->new(
            options      => $options,
            metaclass    => $metaclass,
            is_inline    => 1,
            package_name => $metaclass->name,
            name         => $options->{constructor_name}
        )
        )
        if $options->{replace_constructor}
            or !$metaclass->has_method( $options->{constructor_name} );
}

sub _inline_destructor {
    my ( $self, $metaclass, $options ) = @_;

    return unless $options->{inline_destructor};

    ( exists $options->{destructor_class} )
        || confess "The 'inline_destructor' option is present, but "
        . "no destructor class was specified";

    my $destructor_class = $options->{destructor_class};

    if ( $destructor_class->is_needed($metaclass) ) {
        my $destructor = $destructor_class->new(
            options      => $options,
            metaclass    => $metaclass,
            package_name => $metaclass->name,
            name         => 'DESTROY'
        );

        $metaclass->add_method( 'DESTROY' => $destructor )
            if $destructor->is_needed;
    }
}

sub _memoize_methods {
    my ( $self, $metaclass, $options ) = @_;

    my $memoized_methods = $self->options->{memoize};
    foreach my $method_name ( keys %{$memoized_methods} ) {
        my $type = $memoized_methods->{$method_name};

        ( $metaclass->can($method_name) )
            || confess "Could not find the method '$method_name' in "
            . $metaclass->name;
    }
}

sub make_metaclass_mutable {
    my ($self, $immutable, $options) = @_;

    my %options = %$options;

    my $original_class = $immutable->get_mutable_metaclass_name;
    delete $immutable->{'___original_class'} ;
    bless $immutable => $original_class;

    my $memoized_methods = $self->options->{memoize};
    foreach my $method_name (keys %{$memoized_methods}) {
        my $type = $memoized_methods->{$method_name};

        ($immutable->can($method_name))
          || confess "Could not find the method '$method_name' in " . $immutable->name;
        if ($type eq 'SCALAR' || $type eq 'ARRAY' ||  $type eq 'HASH' ) {
            delete $immutable->{'___' . $method_name};
        }
    }

    if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
        $immutable->remove_method('DESTROY')
          if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
    }

    # NOTE:
    # 14:01 <@stevan> nah,. you shouldnt
    # 14:01 <@stevan> they are just inlined
    # 14:01 <@stevan> which is the default in Moose anyway
    # 14:02 <@stevan> and adding new attributes will just DWIM
    # 14:02 <@stevan> and you really cant change an attribute anyway
    # if ($options{inline_accessors}) {
    #     foreach my $attr_name ($immutable->get_attribute_list) {
    #         my $attr = $immutable->get_attribute($attr_name);
    #         $attr->remove_accessors;
    #         $attr->install_accessors(0);
    #     }
    # }

    # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
    # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
    # 14:27 <@stevan> so I am not worried
    if ($options{inline_constructor}  && $immutable->has_method($options{constructor_name})) {
        my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
        $immutable->remove_method( $options{constructor_name}  )
          if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
    }
}

sub create_methods_for_immutable_metaclass {
    my $self = shift;

    my %methods = %DEFAULT_METHODS;
    my $metaclass = $self->metaclass;
    my $meta = $metaclass->meta;

    foreach my $read_only_method (@{$self->options->{read_only}}) {
        my $method = $meta->find_method_by_name($read_only_method);

        (defined $method)
            || confess "Could not find the method '$read_only_method' in " . $metaclass->name;

        $methods{$read_only_method} = sub {
            confess "This method is read-only" if scalar @_ > 1;
            goto &{$method->body}
        };
    }

    foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
        $methods{$cannot_call_method} = sub {
            confess "This method ($cannot_call_method) cannot be called on an immutable instance";
        };
    }

    my $memoized_methods = $self->options->{memoize};
    foreach my $method_name (keys %{$memoized_methods}) {
        my $type = $memoized_methods->{$method_name};
        my $key = '___' . $method_name;
        my $method = $meta->find_method_by_name($method_name);

        if ($type eq 'ARRAY') {
            $methods{$method_name} = sub {
                @{$_[0]->{$key}} = $method->execute($_[0])
                    if !exists $_[0]->{$key};
                return @{$_[0]->{$key}};
            };
        }
        elsif ($type eq 'HASH') {
            $methods{$method_name} = sub {
                %{$_[0]->{$key}} = $method->execute($_[0])
                    if !exists $_[0]->{$key};
                return %{$_[0]->{$key}};
            };
        }
        elsif ($type eq 'SCALAR') {
            $methods{$method_name} = sub {
                $_[0]->{$key} = $method->execute($_[0])
                    if !exists $_[0]->{$key};
                return $_[0]->{$key};
            };
        }
    }
    
    my $wrapped_methods = $self->options->{wrapped};
    
    foreach my $method_name (keys %{ $wrapped_methods }) {
        my $method = $meta->find_method_by_name($method_name);

        (defined $method)
            || confess "Could not find the method '$method_name' in " . $metaclass->name;

        my $wrapper = $wrapped_methods->{$method_name};

        $methods{$method_name} = sub { $wrapper->($method, @_) };
    }

    $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };

    $methods{immutable_transformer} = sub { $self };

    return \%methods;
}

1;

__END__

=pod

=head1 NAME

Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses

=head1 SYNOPSIS

    use Class::MOP::Immutable;

    my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
        read_only   => [qw/superclasses/],
        cannot_call => [qw/
            add_method
            alias_method
            remove_method
            add_attribute
            remove_attribute
            add_package_symbol
            remove_package_symbol
        /],
        memoize     => {
            class_precedence_list             => 'ARRAY',
            compute_all_applicable_attributes => 'ARRAY',
            get_meta_instance                 => 'SCALAR',
            get_method_map                    => 'SCALAR',
        }
    });

    $immutable_metaclass->make_metaclass_immutable(@_)

=head1 DESCRIPTION

This is basically a module for applying a transformation on a given
metaclass. Current features include making methods read-only,
making methods un-callable and memoizing methods (in a type specific
way too).

This module is not for the feint of heart, it does some whacky things
to the metaclass in order to make it immutable. If you are just curious, 
I suggest you turn back now, there is nothing to see here.

=head1 METHODS

=over 4

=item B<new ($metaclass, \%options)>

Given a C<$metaclass> and a set of C<%options> this module will
prepare an immutable version of the C<$metaclass>, which can then
be applied to the C<$metaclass> using the C<make_metaclass_immutable>
method.

=item B<options>

Returns the options HASH set in C<new>.

=item B<metaclass>

Returns the metaclass set in C<new>.

=item B<immutable_metaclass>

Returns the immutable metaclass created within C<new>.

=back

=over 4

=item B<create_immutable_metaclass>

This will create the immutable version of the C<$metaclass>, but will
not actually change the original metaclass.

=item B<create_methods_for_immutable_metaclass>

This will create all the methods for the immutable metaclass based
on the C<%options> passed into C<new>.

=item B<make_metaclass_immutable (%options)>

This will actually change the C<$metaclass> into the immutable version.

=item B<make_metaclass_mutable (%options)>

This will change the C<$metaclass> into the mutable version by reversing
the immutable process. C<%options> should be the same options that were
given to make_metaclass_immutable.

=back

=head1 AUTHORS

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006-2008 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
Commit	Line	Data
c23184fc	1
	2	package Class::MOP::Immutable;
	3
	4	use strict;
	5	use warnings;
	6
	7	use Class::MOP::Method::Constructor;
	8
	9	use Carp 'confess';
	10	use Scalar::Util 'blessed';
	11
34147f49	12	our $VERSION = '0.71_01';
d519662a	13	$VERSION = eval $VERSION;
c23184fc	14	our $AUTHORITY = 'cpan:STEVAN';
c23184fc	15
d7b2249e	16	use base 'Class::MOP::Object';
d7b2249e	17
0ac992ee	18	sub new {
1ae8e211	19	my ($class, @args) = @_;
0ac992ee	20
1ae8e211	21	my ( $metaclass, $options );
	22
	23	if ( @args == 2 ) {
	24	# compatibility args
	25	( $metaclass, $options ) = @args;
	26	} else {
	27	unshift @args, "metaclass" if @args % 2 == 1;
	28
	29	# default named args
	30	my %options = @args;
	31	$options = \%options;
	32	$metaclass = $options{metaclass};
	33	}
	34
0bfc85b8	35	my $self = $class->_new(
8683db0e	36	'metaclass' => $metaclass,
	37	'options' => $options,
	38	'immutable_metaclass' => undef,
0bfc85b8	39	);
0ac992ee	40
c23184fc	41	return $self;
	42	}
	43
0bfc85b8	44	sub _new {
	45	my $class = shift;
	46	my $options = @_ == 1 ? $_[0] : {@_};
	47
	48	bless $options, $class;
	49	}
	50
76c20e30	51	sub immutable_metaclass {
	52	my $self = shift;
	53
	54	$self->create_immutable_metaclass unless $self->{'immutable_metaclass'};
	55
	56	return $self->{'immutable_metaclass'};
	57	}
	58
8683db0e	59	sub metaclass { (shift)->{'metaclass'} }
8683db0e	60	sub options { (shift)->{'options'} }
c23184fc	61
	62	sub create_immutable_metaclass {
	63	my $self = shift;
	64
	65	# NOTE:
0ac992ee	66	# The immutable version of the
c23184fc	67	# metaclass is just a anon-class
0ac992ee	68	# which shadows the methods
c23184fc	69	# appropriately
8683db0e	70	$self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
c23184fc	71	superclasses => [ blessed($self->metaclass) ],
c23184fc	72	methods => $self->create_methods_for_immutable_metaclass,
0ac992ee	73	);
c23184fc	74	}
c23184fc	75
d9586da2	76
c23184fc	77	my %DEFAULT_METHODS = (
d9586da2	78	# I don't really understand this, but removing it breaks tests (groditi)
0ac992ee	79	meta => sub {
c23184fc	80	my $self = shift;
0ac992ee	81	# if it is not blessed, then someone is asking
127d39a7	82	# for the meta of Class::MOP::Immutable
c23184fc	83	return Class::MOP::Class->initialize($self) unless blessed($self);
0ac992ee	84	# otherwise, they are asking for the metaclass
c23184fc	85	# which has been made immutable, which is itself
84bc89b3	86	# except in the cases where it is a metaclass itself
	87	# that has been made immutable and for that we need
	88	# to dig a bit ...
	89	if ($self->isa('Class::MOP::Class')) {
	90	return $self->{'___original_class'}->meta;
	91	}
	92	else {
	93	return $self;
	94	}
c23184fc	95	},
d9586da2	96	is_mutable => sub { 0 },
	97	is_immutable => sub { 1 },
	98	make_immutable => sub { () },
c23184fc	99	);
	100
	101	# NOTE:
0ac992ee	102	# this will actually convert the
0ac992ee	103	# existing metaclass to an immutable
c23184fc	104	# version of itself
c23184fc	105	sub make_metaclass_immutable {
229910b5	106	my ($self, $metaclass, $options) = @_;
229910b5	107
1a84e3f3	108	my %options = (
	109	inline_accessors => 1,
	110	inline_constructor => 1,
	111	inline_destructor => 0,
	112	constructor_name => 'new',
	113	debug => 0,
	114	%$options,
	115	);
	116
	117	%$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
0ac992ee	118
75f173e5	119	$self->_inline_accessors( $metaclass, \%options );
	120	$self->_inline_constructor( $metaclass, \%options );
	121	$self->_inline_destructor( $metaclass, \%options );
	122	$self->_memoize_methods( $metaclass, \%options );
	123
	124	$metaclass->{'___original_class'} = blessed($metaclass);
	125	bless $metaclass => $self->immutable_metaclass->name;
	126	}
c23184fc	127
75f173e5	128	sub _inline_accessors {
	129	my ( $self, $metaclass, $options ) = @_;
	130
	131	return unless $options->{inline_accessors};
	132
	133	foreach my $attr_name ( $metaclass->get_attribute_list ) {
	134	$metaclass->get_attribute($attr_name)->install_accessors(1);
0ac992ee	135	}
75f173e5	136	}
0ac992ee	137
75f173e5	138	sub _inline_constructor {
	139	my ( $self, $metaclass, $options ) = @_;
	140
	141	return unless $options->{inline_constructor};
	142
	143	my $constructor_class = $options->{constructor_class}
	144	\|\| 'Class::MOP::Method::Constructor';
	145	$metaclass->add_method(
	146	$options->{constructor_name},
	147	$constructor_class->new(
	148	options => $options,
	149	metaclass => $metaclass,
	150	is_inline => 1,
	151	package_name => $metaclass->name,
	152	name => $options->{constructor_name}
	153	)
	154	)
	155	if $options->{replace_constructor}
	156	or !$metaclass->has_method( $options->{constructor_name} );
	157	}
	158
	159	sub _inline_destructor {
	160	my ( $self, $metaclass, $options ) = @_;
	161
	162	return unless $options->{inline_destructor};
	163
	164	( exists $options->{destructor_class} )
	165	\|\| confess "The 'inline_destructor' option is present, but "
	166	. "no destructor class was specified";
	167
	168	my $destructor_class = $options->{destructor_class};
	169
	170	if ( $destructor_class->is_needed($metaclass) ) {
	171	my $destructor = $destructor_class->new(
	172	options => $options,
	173	metaclass => $metaclass,
	174	package_name => $metaclass->name,
	175	name => 'DESTROY'
	176	);
	177
	178	$metaclass->add_method( 'DESTROY' => $destructor )
	179	if $destructor->is_needed;
0ac992ee	180	}
75f173e5	181	}
	182
	183	sub _memoize_methods {
	184	my ( $self, $metaclass, $options ) = @_;
0ac992ee	185
c23184fc	186	my $memoized_methods = $self->options->{memoize};
75f173e5	187	foreach my $method_name ( keys %{$memoized_methods} ) {
c23184fc	188	my $type = $memoized_methods->{$method_name};
0ac992ee	189
75f173e5	190	( $metaclass->can($method_name) )
	191	\|\| confess "Could not find the method '$method_name' in "
	192	. $metaclass->name;
0ac992ee	193	}
c23184fc	194	}
c23184fc	195
0ac992ee	196	sub make_metaclass_mutable {
229910b5	197	my ($self, $immutable, $options) = @_;
	198
	199	my %options = %$options;
0ac992ee	200
	201	my $original_class = $immutable->get_mutable_metaclass_name;
	202	delete $immutable->{'___original_class'} ;
	203	bless $immutable => $original_class;
	204
	205	my $memoized_methods = $self->options->{memoize};
	206	foreach my $method_name (keys %{$memoized_methods}) {
	207	my $type = $memoized_methods->{$method_name};
	208
	209	($immutable->can($method_name))
	210	\|\| confess "Could not find the method '$method_name' in " . $immutable->name;
	211	if ($type eq 'SCALAR' \|\| $type eq 'ARRAY' \|\| $type eq 'HASH' ) {
	212	delete $immutable->{'___' . $method_name};
	213	}
	214	}
	215
	216	if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
	217	$immutable->remove_method('DESTROY')
11b56828	218	if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
0ac992ee	219	}
0ac992ee	220
b817e248	221	# NOTE:
	222	# 14:01 <@stevan> nah,. you shouldnt
	223	# 14:01 <@stevan> they are just inlined
	224	# 14:01 <@stevan> which is the default in Moose anyway
	225	# 14:02 <@stevan> and adding new attributes will just DWIM
	226	# 14:02 <@stevan> and you really cant change an attribute anyway
	227	# if ($options{inline_accessors}) {
	228	# foreach my $attr_name ($immutable->get_attribute_list) {
	229	# my $attr = $immutable->get_attribute($attr_name);
	230	# $attr->remove_accessors;
	231	# $attr->install_accessors(0);
	232	# }
	233	# }
	234
	235	# 14:26 <@stevan> the only user of ::Method::Constructor is immutable
	236	# 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
	237	# 14:27 <@stevan> so I am not worried
11b56828	238	if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
0ac992ee	239	my $constructor_class = $options{constructor_class} \|\| 'Class::MOP::Method::Constructor';
0ac992ee	240	$immutable->remove_method( $options{constructor_name} )
11b56828	241	if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
0ac992ee	242	}
	243	}
	244
c23184fc	245	sub create_methods_for_immutable_metaclass {
c23184fc	246	my $self = shift;
0ac992ee	247
c23184fc	248	my %methods = %DEFAULT_METHODS;
41885bab	249	my $metaclass = $self->metaclass;
41885bab	250	my $meta = $metaclass->meta;
0ac992ee	251
c23184fc	252	foreach my $read_only_method (@{$self->options->{read_only}}) {
41885bab	253	my $method = $meta->find_method_by_name($read_only_method);
0ac992ee	254
c23184fc	255	(defined $method)
41885bab	256	\|\| confess "Could not find the method '$read_only_method' in " . $metaclass->name;
0ac992ee	257
c23184fc	258	$methods{$read_only_method} = sub {
	259	confess "This method is read-only" if scalar @_ > 1;
	260	goto &{$method->body}
	261	};
	262	}
0ac992ee	263
c23184fc	264	foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
	265	$methods{$cannot_call_method} = sub {
	266	confess "This method ($cannot_call_method) cannot be called on an immutable instance";
	267	};
0ac992ee	268	}
0ac992ee	269
c23184fc	270	my $memoized_methods = $self->options->{memoize};
c23184fc	271	foreach my $method_name (keys %{$memoized_methods}) {
c23184fc	272	my $type = $memoized_methods->{$method_name};
9ec62360	273	my $key = '___' . $method_name;
	274	my $method = $meta->find_method_by_name($method_name);
	275
c23184fc	276	if ($type eq 'ARRAY') {
9ec62360	277	$methods{$method_name} = sub {
	278	@{$_[0]->{$key}} = $method->execute($_[0])
	279	if !exists $_[0]->{$key};
	280	return @{$_[0]->{$key}};
	281	};
c23184fc	282	}
c23184fc	283	elsif ($type eq 'HASH') {
9ec62360	284	$methods{$method_name} = sub {
	285	%{$_[0]->{$key}} = $method->execute($_[0])
	286	if !exists $_[0]->{$key};
	287	return %{$_[0]->{$key}};
	288	};
c23184fc	289	}
c23184fc	290	elsif ($type eq 'SCALAR') {
9ec62360	291	$methods{$method_name} = sub {
	292	$_[0]->{$key} = $method->execute($_[0])
	293	if !exists $_[0]->{$key};
	294	return $_[0]->{$key};
	295	};
0ac992ee	296	}
0ac992ee	297	}
53299a7b	298
5f3efd66	299	my $wrapped_methods = $self->options->{wrapped};
	300
	301	foreach my $method_name (keys %{ $wrapped_methods }) {
41885bab	302	my $method = $meta->find_method_by_name($method_name);
5f3efd66	303
5f3efd66	304	(defined $method)
41885bab	305	\|\| confess "Could not find the method '$method_name' in " . $metaclass->name;
5f3efd66	306
	307	my $wrapper = $wrapped_methods->{$method_name};
	308
	309	$methods{$method_name} = sub { $wrapper->($method, @_) };
53299a7b	310	}
0ac992ee	311
	312	$methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
	313
9f3ff885	314	$methods{immutable_transformer} = sub { $self };
9f3ff885	315
c23184fc	316	return \%methods;
	317	}
	318
	319	1;
	320
	321	__END__
	322
	323	=pod
	324
0ac992ee	325	=head1 NAME
c23184fc	326
	327	Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
	328
	329	=head1 SYNOPSIS
	330
96e38ba6	331	use Class::MOP::Immutable;
0ac992ee	332
96e38ba6	333	my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
	334	read_only => [qw/superclasses/],
	335	cannot_call => [qw/
	336	add_method
	337	alias_method
	338	remove_method
	339	add_attribute
	340	remove_attribute
	341	add_package_symbol
0ac992ee	342	remove_package_symbol
96e38ba6	343	/],
	344	memoize => {
	345	class_precedence_list => 'ARRAY',
0ac992ee	346	compute_all_applicable_attributes => 'ARRAY',
	347	get_meta_instance => 'SCALAR',
	348	get_method_map => 'SCALAR',
96e38ba6	349	}
0ac992ee	350	});
96e38ba6	351
	352	$immutable_metaclass->make_metaclass_immutable(@_)
	353
c23184fc	354	=head1 DESCRIPTION
c23184fc	355
0ac992ee	356	This is basically a module for applying a transformation on a given
0ac992ee	357	metaclass. Current features include making methods read-only,
96e38ba6	358	making methods un-callable and memoizing methods (in a type specific
0ac992ee	359	way too).
96e38ba6	360
127d39a7	361	This module is not for the feint of heart, it does some whacky things
	362	to the metaclass in order to make it immutable. If you are just curious,
	363	I suggest you turn back now, there is nothing to see here.
96e38ba6	364
c23184fc	365	=head1 METHODS
	366
	367	=over 4
	368
96e38ba6	369	=item B<new ($metaclass, \%options)>
96e38ba6	370
0ac992ee	371	Given a C<$metaclass> and a set of C<%options> this module will
	372	prepare an immutable version of the C<$metaclass>, which can then
	373	be applied to the C<$metaclass> using the C<make_metaclass_immutable>
96e38ba6	374	method.
96e38ba6	375
c23184fc	376	=item B<options>
c23184fc	377
96e38ba6	378	Returns the options HASH set in C<new>.
96e38ba6	379
c23184fc	380	=item B<metaclass>
c23184fc	381
96e38ba6	382	Returns the metaclass set in C<new>.
96e38ba6	383
c23184fc	384	=item B<immutable_metaclass>
c23184fc	385
96e38ba6	386	Returns the immutable metaclass created within C<new>.
96e38ba6	387
c23184fc	388	=back
	389
	390	=over 4
	391
	392	=item B<create_immutable_metaclass>
	393
0ac992ee	394	This will create the immutable version of the C<$metaclass>, but will
0ac992ee	395	not actually change the original metaclass.
96e38ba6	396
c23184fc	397	=item B<create_methods_for_immutable_metaclass>
c23184fc	398
0ac992ee	399	This will create all the methods for the immutable metaclass based
96e38ba6	400	on the C<%options> passed into C<new>.
96e38ba6	401
0ac992ee	402	=item B<make_metaclass_immutable (%options)>
c23184fc	403
96e38ba6	404	This will actually change the C<$metaclass> into the immutable version.
96e38ba6	405
0ac992ee	406	=item B<make_metaclass_mutable (%options)>
	407
	408	This will change the C<$metaclass> into the mutable version by reversing
	409	the immutable process. C<%options> should be the same options that were
	410	given to make_metaclass_immutable.
	411
c23184fc	412	=back
	413
	414	=head1 AUTHORS
	415
	416	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	417
	418	=head1 COPYRIGHT AND LICENSE
	419
69e3ab0a	420	Copyright 2006-2008 by Infinity Interactive, Inc.
c23184fc	421
	422	L<http://www.iinteractive.com>
	423
	424	This library is free software; you can redistribute it and/or modify
0ac992ee	425	it under the same terms as Perl itself.
c23184fc	426
c23184fc	427	=cut