IT WORKS NOWrun_testsrun_testsrun_testsrun_tests

[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.01';
our $AUTHORITY = 'cpan:STEVAN';

sub new { 
    my ($class, $metaclass, $options) = @_;
    
    my $self = bless {
        metaclass           => $metaclass,
        options             => $options,
        immutable_metaclass => undef,
    } => $class;
    
    # NOTE:
    # we initialize the immutable 
    # version of the metaclass here
    $self->create_immutable_metaclass;
    
    return $self;
}

sub immutable_metaclass { (shift)->{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 = (
    meta => sub { 
        my $self = shift;
        # if it is not blessed, then someone is asking 
        # for the meta of Class::MOP::Class::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
        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) = @_;
    
    $options{inline_accessors}   = 1     unless exists $options{inline_accessors};
    $options{inline_constructor} = 1     unless exists $options{inline_constructor};
    $options{constructor_name}   = 'new' unless exists $options{constructor_name};
    $options{debug}              = 0     unless exists $options{debug};    
    
    if ($options{inline_accessors}) {
        foreach my $attr_name ($metaclass->get_attribute_list) {
            # inline the accessors
            $metaclass->get_attribute($attr_name)
                      ->install_accessors(1); 
        }      
    }

    if ($options{inline_constructor}) {       
        my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
        
        my $constructor = $constructor_class->new(
            options       => \%options, 
            meta_instance => $metaclass->get_meta_instance, 
            attributes    => [ $metaclass->compute_all_applicable_attributes ]
        );
        
        $metaclass->add_method(
            $options{constructor_name},
            $constructor
        );
    }    
    
    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;        
    
        my $memoized_method;
        if ($type eq 'ARRAY') {
            $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
        }
        elsif ($type eq 'HASH') {
            $metaclass->{'___' . $method_name} = { $metaclass->$method_name };                       
        }
        elsif ($type eq 'SCALAR') {
            $metaclass->{'___' . $method_name} = $metaclass->$method_name;
        }
    }  
    $metaclass->{'___original_class'} = blessed($metaclass);    

    bless $metaclass => $self->immutable_metaclass->name;
}

sub create_methods_for_immutable_metaclass {
    my $self = shift;
    
    my %methods = %DEFAULT_METHODS;
    
    foreach my $read_only_method (@{$self->options->{read_only}}) {
        my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
        
        (defined $method)
            || confess "Could not find the method '$read_only_method' in " . $self->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 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};
        if ($type eq 'ARRAY') {
            $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
        }
        elsif ($type eq 'HASH') {
            $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
        }
        elsif ($type eq 'SCALAR') {
            $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
        }        
    }       
    
    $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };     
    
    return \%methods;
}

1;

__END__

=pod

=head1 NAME 

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

=head1 SYNOPSIS

=head1 DESCRIPTION

=head1 METHODS

=over 4

=item B<new>
 
=item B<options>

=item B<metaclass>

=item B<immutable_metaclass>

=back

=over 4

=item B<create_immutable_metaclass>

=item B<create_methods_for_immutable_metaclass>

=item B<make_metaclass_immutable>

=back

=head1 AUTHORS

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

=head1 COPYRIGHT AND LICENSE

Copyright 2006 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