diff options
Diffstat (limited to 'lib/Class')
| -rw-r--r-- | lib/Class/MOP.pm | 1232 | ||||
| -rw-r--r-- | lib/Class/MOP/Attribute.pm | 1100 | ||||
| -rw-r--r-- | lib/Class/MOP/Class.pm | 2312 | ||||
| -rw-r--r-- | lib/Class/MOP/Class/Immutable/Trait.pm | 172 | ||||
| -rw-r--r-- | lib/Class/MOP/Deprecated.pm | 95 | ||||
| -rw-r--r-- | lib/Class/MOP/Instance.pm | 533 | ||||
| -rw-r--r-- | lib/Class/MOP/Method.pm | 343 | ||||
| -rw-r--r-- | lib/Class/MOP/Method/Accessor.pm | 409 | ||||
| -rw-r--r-- | lib/Class/MOP/Method/Constructor.pm | 251 | ||||
| -rw-r--r-- | lib/Class/MOP/Method/Generated.pm | 142 | ||||
| -rw-r--r-- | lib/Class/MOP/Method/Inlined.pm | 195 | ||||
| -rw-r--r-- | lib/Class/MOP/Method/Meta.pm | 169 | ||||
| -rw-r--r-- | lib/Class/MOP/Method/Wrapped.pm | 331 | ||||
| -rw-r--r-- | lib/Class/MOP/MiniTrait.pm | 113 | ||||
| -rw-r--r-- | lib/Class/MOP/Mixin.pm | 111 | ||||
| -rw-r--r-- | lib/Class/MOP/Mixin/AttributeCore.pm | 125 | ||||
| -rw-r--r-- | lib/Class/MOP/Mixin/HasAttributes.pm | 171 | ||||
| -rw-r--r-- | lib/Class/MOP/Mixin/HasMethods.pm | 304 | ||||
| -rw-r--r-- | lib/Class/MOP/Mixin/HasOverloads.pm | 237 | ||||
| -rw-r--r-- | lib/Class/MOP/Module.pm | 213 | ||||
| -rw-r--r-- | lib/Class/MOP/Object.pm | 200 | ||||
| -rw-r--r-- | lib/Class/MOP/Overload.pm | 342 | ||||
| -rw-r--r-- | lib/Class/MOP/Package.pm | 464 |
23 files changed, 9564 insertions, 0 deletions
diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm new file mode 100644 index 0000000..e55527d --- /dev/null +++ b/lib/Class/MOP.pm @@ -0,0 +1,1232 @@ +package Class::MOP; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use 5.008003; + +use MRO::Compat; +use Class::Load 0.07 (); +use Scalar::Util 'weaken', 'isweak', 'blessed'; +use Data::OptList; + +use Class::MOP::Mixin::AttributeCore; +use Class::MOP::Mixin::HasAttributes; +use Class::MOP::Mixin::HasMethods; +use Class::MOP::Mixin::HasOverloads; +use Class::MOP::Class; +use Class::MOP::Attribute; +use Class::MOP::Method; + +BEGIN { + *IS_RUNNING_ON_5_10 = ($] < 5.009_005) + ? sub () { 0 } + : sub () { 1 }; + + # this is either part of core or set up appropriately by MRO::Compat + *check_package_cache_flag = \&mro::get_pkg_gen; +} + +XSLoader::load( + 'Moose', + $VERSION, +); + +{ + # Metaclasses are singletons, so we cache them here. + # there is no need to worry about destruction though + # because they should die only when the program dies. + # After all, do package definitions even get reaped? + # Anonymous classes manage their own destruction. + my %METAS; + + sub get_all_metaclasses { %METAS } + sub get_all_metaclass_instances { values %METAS } + sub get_all_metaclass_names { keys %METAS } + sub get_metaclass_by_name { $METAS{$_[0]} } + sub store_metaclass_by_name { $METAS{$_[0]} = $_[1] } + sub weaken_metaclass { weaken($METAS{$_[0]}) } + sub metaclass_is_weak { isweak($METAS{$_[0]}) } + sub does_metaclass_exist { exists $METAS{$_[0]} && defined $METAS{$_[0]} } + sub remove_metaclass_by_name { delete $METAS{$_[0]}; return } + + # This handles instances as well as class names + sub class_of { + return unless defined $_[0]; + my $class = blessed($_[0]) || $_[0]; + return $METAS{$class}; + } + + # NOTE: + # We only cache metaclasses, meaning instances of + # Class::MOP::Class. We do not cache instance of + # Class::MOP::Package or Class::MOP::Module. Mostly + # because I don't yet see a good reason to do so. +} + +sub load_class { + Class::MOP::Deprecated::deprecated( + message => 'Class::MOP::load_class is deprecated', + feature => 'Class::Load wrapper functions', + ); + require Class::Load; + goto &Class::Load::load_class; +} + +sub load_first_existing_class { + Class::MOP::Deprecated::deprecated( + message => 'Class::MOP::load_first_existing_class is deprecated', + feature => 'Class::Load wrapper functions', + ); + require Class::Load; + goto &Class::Load::load_first_existing_class; +} + +sub is_class_loaded { + Class::MOP::Deprecated::deprecated( + message => 'Class::MOP::is_class_loaded is deprecated', + feature => 'Class::Load wrapper functions', + ); + require Class::Load; + goto &Class::Load::is_class_loaded; +} + +sub _definition_context { + my %context; + @context{qw(package file line)} = caller(1); + + return ( + definition_context => \%context, + ); +} + +## ---------------------------------------------------------------------------- +## Setting up our environment ... +## ---------------------------------------------------------------------------- +## Class::MOP needs to have a few things in the global perl environment so +## that it can operate effectively. Those things are done here. +## ---------------------------------------------------------------------------- + +# ... nothing yet actually ;) + +## ---------------------------------------------------------------------------- +## Bootstrapping +## ---------------------------------------------------------------------------- +## The code below here is to bootstrap our MOP with itself. This is also +## sometimes called "tying the knot". By doing this, we make it much easier +## to extend the MOP through subclassing and such since now you can use the +## MOP itself to extend itself. +## +## Yes, I know, that's weird and insane, but it's a good thing, trust me :) +## ---------------------------------------------------------------------------- + +# We need to add in the meta-attributes here so that +# any subclass of Class::MOP::* will be able to +# inherit them using _construct_instance + +## -------------------------------------------------------- +## Class::MOP::Mixin::HasMethods + +Class::MOP::Mixin::HasMethods->meta->add_attribute( + Class::MOP::Attribute->new('_methods' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + '_method_map' => \&Class::MOP::Mixin::HasMethods::_method_map + }, + default => sub { {} }, + _definition_context(), + )) +); + +Class::MOP::Mixin::HasMethods->meta->add_attribute( + Class::MOP::Attribute->new('method_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass + }, + default => 'Class::MOP::Method', + _definition_context(), + )) +); + +Class::MOP::Mixin::HasMethods->meta->add_attribute( + Class::MOP::Attribute->new('wrapped_method_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass + }, + default => 'Class::MOP::Method::Wrapped', + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Mixin::HasAttributes + +Class::MOP::Mixin::HasAttributes->meta->add_attribute( + Class::MOP::Attribute->new('attributes' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map + }, + default => sub { {} }, + _definition_context(), + )) +); + +Class::MOP::Mixin::HasAttributes->meta->add_attribute( + Class::MOP::Attribute->new('attribute_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass + }, + default => 'Class::MOP::Attribute', + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Mixin::HasOverloads + +Class::MOP::Mixin::HasOverloads->meta->add_attribute( + Class::MOP::Attribute->new('_overload_map' => ( + reader => { + '_overload_map' => \&Class::MOP::Mixin::HasOverloads::_overload_map + }, + clearer => '_clear_overload_map', + default => sub { {} }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Package + +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('package' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'name' => \&Class::MOP::Package::name + }, + _definition_context(), + )) +); + +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('namespace' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'namespace' => \&Class::MOP::Package::namespace + }, + init_arg => undef, + default => sub { \undef }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Module + +# NOTE: +# yeah this is kind of stretching things a bit, +# but truthfully the version should be an attribute +# of the Module, the weirdness comes from having to +# stick to Perl 5 convention and store it in the +# $VERSION package variable. Basically if you just +# squint at it, it will look how you want it to look. +# Either as a package variable, or as a attribute of +# the metaclass, isn't abstraction great :) + +Class::MOP::Module->meta->add_attribute( + Class::MOP::Attribute->new('version' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'version' => \&Class::MOP::Module::version + }, + init_arg => undef, + default => sub { \undef }, + _definition_context(), + )) +); + +# NOTE: +# By following the same conventions as version here, +# we are opening up the possibility that people can +# use the $AUTHORITY in non-Class::MOP modules as +# well. + +Class::MOP::Module->meta->add_attribute( + Class::MOP::Attribute->new('authority' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'authority' => \&Class::MOP::Module::authority + }, + init_arg => undef, + default => sub { \undef }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Class + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('superclasses' => ( + accessor => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'superclasses' => \&Class::MOP::Class::superclasses + }, + init_arg => undef, + default => sub { \undef }, + _definition_context(), + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('instance_metaclass' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass + }, + default => 'Class::MOP::Instance', + _definition_context(), + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('immutable_trait' => ( + reader => { + 'immutable_trait' => \&Class::MOP::Class::immutable_trait + }, + default => "Class::MOP::Class::Immutable::Trait", + _definition_context(), + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('constructor_name' => ( + reader => { + 'constructor_name' => \&Class::MOP::Class::constructor_name, + }, + default => "new", + _definition_context(), + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('constructor_class' => ( + reader => { + 'constructor_class' => \&Class::MOP::Class::constructor_class, + }, + default => "Class::MOP::Method::Constructor", + _definition_context(), + )) +); + + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('destructor_class' => ( + reader => { + 'destructor_class' => \&Class::MOP::Class::destructor_class, + }, + _definition_context(), + )) +); + +# NOTE: +# we don't actually need to tie the knot with +# Class::MOP::Class here, it is actually handled +# within Class::MOP::Class itself in the +# _construct_class_instance method. + +## -------------------------------------------------------- +## Class::MOP::Mixin::AttributeCore +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('name' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'name' => \&Class::MOP::Mixin::AttributeCore::name + }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('accessor' => ( + reader => { 'accessor' => \&Class::MOP::Mixin::AttributeCore::accessor }, + predicate => { 'has_accessor' => \&Class::MOP::Mixin::AttributeCore::has_accessor }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('reader' => ( + reader => { 'reader' => \&Class::MOP::Mixin::AttributeCore::reader }, + predicate => { 'has_reader' => \&Class::MOP::Mixin::AttributeCore::has_reader }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('initializer' => ( + reader => { 'initializer' => \&Class::MOP::Mixin::AttributeCore::initializer }, + predicate => { 'has_initializer' => \&Class::MOP::Mixin::AttributeCore::has_initializer }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('definition_context' => ( + reader => { 'definition_context' => \&Class::MOP::Mixin::AttributeCore::definition_context }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('writer' => ( + reader => { 'writer' => \&Class::MOP::Mixin::AttributeCore::writer }, + predicate => { 'has_writer' => \&Class::MOP::Mixin::AttributeCore::has_writer }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('predicate' => ( + reader => { 'predicate' => \&Class::MOP::Mixin::AttributeCore::predicate }, + predicate => { 'has_predicate' => \&Class::MOP::Mixin::AttributeCore::has_predicate }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('clearer' => ( + reader => { 'clearer' => \&Class::MOP::Mixin::AttributeCore::clearer }, + predicate => { 'has_clearer' => \&Class::MOP::Mixin::AttributeCore::has_clearer }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('builder' => ( + reader => { 'builder' => \&Class::MOP::Mixin::AttributeCore::builder }, + predicate => { 'has_builder' => \&Class::MOP::Mixin::AttributeCore::has_builder }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('init_arg' => ( + reader => { 'init_arg' => \&Class::MOP::Mixin::AttributeCore::init_arg }, + predicate => { 'has_init_arg' => \&Class::MOP::Mixin::AttributeCore::has_init_arg }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('default' => ( + # default has a custom 'reader' method ... + predicate => { 'has_default' => \&Class::MOP::Mixin::AttributeCore::has_default }, + _definition_context(), + )) +); + +Class::MOP::Mixin::AttributeCore->meta->add_attribute( + Class::MOP::Attribute->new('insertion_order' => ( + reader => { 'insertion_order' => \&Class::MOP::Mixin::AttributeCore::insertion_order }, + writer => { '_set_insertion_order' => \&Class::MOP::Mixin::AttributeCore::_set_insertion_order }, + predicate => { 'has_insertion_order' => \&Class::MOP::Mixin::AttributeCore::has_insertion_order }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Attribute +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('associated_class' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'associated_class' => \&Class::MOP::Attribute::associated_class + }, + _definition_context(), + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('associated_methods' => ( + reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods }, + default => sub { [] }, + _definition_context(), + )) +); + +Class::MOP::Attribute->meta->add_method('clone' => sub { + my $self = shift; + $self->meta->clone_object($self, @_); +}); + +## -------------------------------------------------------- +## Class::MOP::Method +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('body' => ( + reader => { 'body' => \&Class::MOP::Method::body }, + _definition_context(), + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('associated_metaclass' => ( + reader => { 'associated_metaclass' => \&Class::MOP::Method::associated_metaclass }, + _definition_context(), + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('package_name' => ( + reader => { 'package_name' => \&Class::MOP::Method::package_name }, + _definition_context(), + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('name' => ( + reader => { 'name' => \&Class::MOP::Method::name }, + _definition_context(), + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('original_method' => ( + reader => { 'original_method' => \&Class::MOP::Method::original_method }, + writer => { '_set_original_method' => \&Class::MOP::Method::_set_original_method }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Wrapped + +# NOTE: +# the way this item is initialized, this +# really does not follow the standard +# practices of attributes, but we put +# it here for completeness +Class::MOP::Method::Wrapped->meta->add_attribute( + Class::MOP::Attribute->new('modifier_table' => ( + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Generated + +Class::MOP::Method::Generated->meta->add_attribute( + Class::MOP::Attribute->new('is_inline' => ( + reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline }, + default => 0, + _definition_context(), + )) +); + +Class::MOP::Method::Generated->meta->add_attribute( + Class::MOP::Attribute->new('definition_context' => ( + reader => { 'definition_context' => \&Class::MOP::Method::Generated::definition_context }, + _definition_context(), + )) +); + + +## -------------------------------------------------------- +## Class::MOP::Method::Inlined + +Class::MOP::Method::Inlined->meta->add_attribute( + Class::MOP::Attribute->new('_expected_method_class' => ( + reader => { '_expected_method_class' => \&Class::MOP::Method::Inlined::_expected_method_class }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Accessor + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('attribute' => ( + reader => { + 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute + }, + _definition_context(), + )) +); + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('accessor_type' => ( + reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Constructor + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('options' => ( + reader => { + 'options' => \&Class::MOP::Method::Constructor::options + }, + default => sub { +{} }, + _definition_context(), + )) +); + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('associated_metaclass' => ( + init_arg => "metaclass", # FIXME alias and rename + reader => { + 'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass + }, + _definition_context(), + )) +); + +## -------------------------------------------------------- +## Class::MOP::Overload + +Class::MOP::Overload->meta->add_attribute( + Class::MOP::Attribute->new( + 'operator' => ( + reader => { 'operator' => \&Class::MOP::Overload::operator }, + required => 1, + _definition_context(), + ) + ) +); + +for my $attr (qw( method_name coderef coderef_package coderef_name method )) { + Class::MOP::Overload->meta->add_attribute( + Class::MOP::Attribute->new( + $attr => ( + reader => { $attr => Class::MOP::Overload->can($attr) }, + predicate => { + 'has_' + . $attr => Class::MOP::Overload->can( 'has_' . $attr ) + }, + _definition_context(), + ) + ) + ); +} + +Class::MOP::Overload->meta->add_attribute( + Class::MOP::Attribute->new( + 'associated_metaclass' => ( + reader => { + 'associated_metaclass' => + \&Class::MOP::Overload::associated_metaclass + }, + _definition_context(), + ) + ) +); + +## -------------------------------------------------------- +## Class::MOP::Instance + +# NOTE: +# these don't yet do much of anything, but are just +# included for completeness + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('associated_metaclass', + reader => { associated_metaclass => \&Class::MOP::Instance::associated_metaclass }, + _definition_context(), + ), +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('_class_name', + init_arg => undef, + reader => { _class_name => \&Class::MOP::Instance::_class_name }, + #lazy => 1, # not yet supported by Class::MOP but out our version does it anyway + #default => sub { $_[0]->associated_metaclass->name }, + _definition_context(), + ), +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('attributes', + reader => { attributes => \&Class::MOP::Instance::get_all_attributes }, + _definition_context(), + ), +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('slots', + reader => { slots => \&Class::MOP::Instance::slots }, + _definition_context(), + ), +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('slot_hash', + reader => { slot_hash => \&Class::MOP::Instance::slot_hash }, + _definition_context(), + ), +); + +## -------------------------------------------------------- +## Class::MOP::Object + +# need to replace the meta method there with a real meta method object +Class::MOP::Object->meta->_add_meta_method('meta'); + +## -------------------------------------------------------- +## Class::MOP::Mixin + +# need to replace the meta method there with a real meta method object +Class::MOP::Mixin->meta->_add_meta_method('meta'); + +require Class::MOP::Deprecated unless our $no_deprecated; + +# we need the meta instance of the meta instance to be created now, in order +# for the constructor to be able to use it +Class::MOP::Instance->meta->get_meta_instance; + +# pretend the add_method never happened. it hasn't yet affected anything +undef Class::MOP::Instance->meta->{_package_cache_flag}; + +## -------------------------------------------------------- +## Now close all the Class::MOP::* classes + +# NOTE: we don't need to inline the accessors this only lengthens the compile +# time of the MOP, and gives us no actual benefits. + +$_->meta->make_immutable( + inline_constructor => 0, + constructor_name => "_new", + inline_accessors => 0, +) for qw/ + Class::MOP::Package + Class::MOP::Module + Class::MOP::Class + + Class::MOP::Attribute + Class::MOP::Method + Class::MOP::Instance + + Class::MOP::Object + + Class::MOP::Method::Generated + Class::MOP::Method::Inlined + + Class::MOP::Method::Accessor + Class::MOP::Method::Constructor + Class::MOP::Method::Wrapped + + Class::MOP::Method::Meta + + Class::MOP::Overload +/; + +$_->meta->make_immutable( + inline_constructor => 0, + constructor_name => undef, + inline_accessors => 0, +) for qw/ + Class::MOP::Mixin + Class::MOP::Mixin::AttributeCore + Class::MOP::Mixin::HasAttributes + Class::MOP::Mixin::HasMethods + Class::MOP::Mixin::HasOverloads +/; + +1; + +# ABSTRACT: A Meta Object Protocol for Perl 5 + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP - A Meta Object Protocol for Perl 5 + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This module is a fully functioning meta object protocol for the +Perl 5 object system. It makes no attempt to change the behavior or +characteristics of the Perl 5 object system, only to create a +protocol for its manipulation and introspection. + +That said, it does attempt to create the tools for building a rich set +of extensions to the Perl 5 object system. Every attempt has been made +to abide by the spirit of the Perl 5 object system that we all know +and love. + +This documentation is sparse on conceptual details. We suggest looking +at the items listed in the L<SEE ALSO> section for more +information. In particular the book "The Art of the Meta Object +Protocol" was very influential in the development of this system. + +=head2 What is a Meta Object Protocol? + +A meta object protocol is an API to an object system. + +To be more specific, it abstracts the components of an object system +(classes, object, methods, object attributes, etc.). These +abstractions can then be used to inspect and manipulate the object +system which they describe. + +It can be said that there are two MOPs for any object system; the +implicit MOP and the explicit MOP. The implicit MOP handles things +like method dispatch or inheritance, which happen automatically as +part of how the object system works. The explicit MOP typically +handles the introspection/reflection features of the object system. + +All object systems have implicit MOPs. Without one, they would not +work. Explicit MOPs are much less common, and depending on the +language can vary from restrictive (Reflection in Java or C#) to wide +open (CLOS is a perfect example). + +=head2 Yet Another Class Builder! Why? + +This is B<not> a class builder so much as a I<class builder +B<builder>>. The intent is that an end user will not use this module +directly, but instead this module is used by module authors to build +extensions and features onto the Perl 5 object system. + +This system is used by L<Moose>, which supplies a powerful class +builder system built entirely on top of C<Class::MOP>. + +=head2 Who is this module for? + +This module is for anyone who has ever created or wanted to create a +module for the Class:: namespace. The tools which this module provides +make doing complex Perl 5 wizardry simpler, by removing such barriers +as the need to hack symbol tables, or understand the fine details of +method dispatch. + +=head2 What changes do I have to make to use this module? + +This module was designed to be as unobtrusive as possible. Many of its +features are accessible without B<any> change to your existing +code. It is meant to be a complement to your existing code and not an +intrusion on your code base. Unlike many other B<Class::> modules, +this module B<does not> require you subclass it, or even that you +C<use> it in within your module's package. + +The only features which require additions to your code are the +attribute handling and instance construction features, and these are +both completely optional features. The only reason for this is because +Perl 5's object system does not actually have these features built +in. More information about this feature can be found below. + +=head2 About Performance + +It is a common misconception that explicit MOPs are a performance hit. +This is not a universal truth, it is a side-effect of some specific +implementations. For instance, using Java reflection is slow because +the JVM cannot take advantage of any compiler optimizations, and the +JVM has to deal with much more runtime type information as well. + +Reflection in C# is marginally better as it was designed into the +language and runtime (the CLR). In contrast, CLOS (the Common Lisp +Object System) was built to support an explicit MOP, and so +performance is tuned for it. + +This library in particular does its absolute best to avoid putting +B<any> drain at all upon your code's performance. In fact, by itself +it does nothing to affect your existing code. So you only pay for what +you actually use. + +=head2 About Metaclass compatibility + +This module makes sure that all metaclasses created are both upwards +and downwards compatible. The topic of metaclass compatibility is +highly esoteric and is something only encountered when doing deep and +involved metaclass hacking. There are two basic kinds of metaclass +incompatibility; upwards and downwards. + +Upwards metaclass compatibility means that the metaclass of a +given class is either the same as (or a subclass of) all of the +metaclasses of the class's ancestors. + +Downward metaclass compatibility means that the metaclasses of a +given class's ancestors are all the same as (or a subclass of) that +class's metaclass. + +Here is a diagram showing a set of two classes (C<A> and C<B>) and +two metaclasses (C<Meta::A> and C<Meta::B>) which have correct +metaclass compatibility both upwards and downwards. + + +---------+ +---------+ + | Meta::A |<----| Meta::B | <....... (instance of ) + +---------+ +---------+ <------- (inherits from) + ^ ^ + : : + +---------+ +---------+ + | A |<----| B | + +---------+ +---------+ + +In actuality, I<all> of a class's metaclasses must be compatible, +not just the class metaclass. That includes the instance, attribute, +and method metaclasses, as well as the constructor and destructor +classes. + +C<Class::MOP> will attempt to fix some simple types of +incompatibilities. If all the metaclasses for the parent class are +I<subclasses> of the child's metaclasses then we can simply replace +the child's metaclasses with the parent's. In addition, if the child +is missing a metaclass that the parent has, we can also just make the +child use the parent's metaclass. + +As I said this is a highly esoteric topic and one you will only run +into if you do a lot of subclassing of L<Class::MOP::Class>. If you +are interested in why this is an issue see the paper I<Uniform and +safe metaclass composition> linked to in the L<SEE ALSO> section of +this document. + +=head2 Using custom metaclasses + +Always use the L<metaclass> pragma when using a custom metaclass, this +will ensure the proper initialization order and not accidentally +create an incorrect type of metaclass for you. This is a very rare +problem, and one which can only occur if you are doing deep metaclass +programming. So in other words, don't worry about it. + +Note that if you're using L<Moose> we encourage you to I<not> use the +L<metaclass> pragma, and instead use L<Moose::Util::MetaRole> to apply +roles to a class's metaclasses. This topic is covered at length in +various L<Moose::Cookbook> recipes. + +=head1 PROTOCOLS + +The meta-object protocol is divided into 4 main sub-protocols: + +=head2 The Class protocol + +This provides a means of manipulating and introspecting a Perl 5 +class. It handles symbol table hacking for you, and provides a rich +set of methods that go beyond simple package introspection. + +See L<Class::MOP::Class> for more details. + +=head2 The Attribute protocol + +This provides a consistent representation for an attribute of a Perl 5 +class. Since there are so many ways to create and handle attributes in +Perl 5 OO, the Attribute protocol provide as much of a unified +approach as possible. Of course, you are always free to extend this +protocol by subclassing the appropriate classes. + +See L<Class::MOP::Attribute> for more details. + +=head2 The Method protocol + +This provides a means of manipulating and introspecting methods in the +Perl 5 object system. As with attributes, there are many ways to +approach this topic, so we try to keep it pretty basic, while still +making it possible to extend the system in many ways. + +See L<Class::MOP::Method> for more details. + +=head2 The Instance protocol + +This provides a layer of abstraction for creating object instances. +Since the other layers use this protocol, it is relatively easy to +change the type of your instances from the default hash reference to +some other type of reference. Several examples are provided in the +F<examples/> directory included in this distribution. + +See L<Class::MOP::Instance> for more details. + +=head1 FUNCTIONS + +Note that this module does not export any constants or functions. + +=head2 Utility functions + +Note that these are all called as B<functions, not methods>. + +=over 4 + +=item B<Class::MOP::get_code_info($code)> + +This function returns two values, the name of the package the C<$code> +is from and the name of the C<$code> itself. This is used by several +elements of the MOP to determine where a given C<$code> reference is +from. + +=item B<Class::MOP::class_of($instance_or_class_name)> + +This will return the metaclass of the given instance or class name. If the +class lacks a metaclass, no metaclass will be initialized, and C<undef> will be +returned. + +You should almost certainly be using +L<C<Moose::Util::find_meta>|Moose::Util/find_meta> instead. + +=back + +=head2 Metaclass cache functions + +C<Class::MOP> holds a cache of metaclasses. The following are functions +(B<not methods>) which can be used to access that cache. It is not +recommended that you mess with these. Bad things could happen, but if +you are brave and willing to risk it: go for it! + +=over 4 + +=item B<Class::MOP::get_all_metaclasses> + +This will return a hash of all the metaclass instances that have +been cached by L<Class::MOP::Class>, keyed by the package name. + +=item B<Class::MOP::get_all_metaclass_instances> + +This will return a list of all the metaclass instances that have +been cached by L<Class::MOP::Class>. + +=item B<Class::MOP::get_all_metaclass_names> + +This will return a list of all the metaclass names that have +been cached by L<Class::MOP::Class>. + +=item B<Class::MOP::get_metaclass_by_name($name)> + +This will return a cached L<Class::MOP::Class> instance, or nothing +if no metaclass exists with that C<$name>. + +=item B<Class::MOP::store_metaclass_by_name($name, $meta)> + +This will store a metaclass in the cache at the supplied C<$key>. + +=item B<Class::MOP::weaken_metaclass($name)> + +In rare cases (e.g. anonymous metaclasses) it is desirable to +store a weakened reference in the metaclass cache. This +function will weaken the reference to the metaclass stored +in C<$name>. + +=item B<Class::MOP::metaclass_is_weak($name)> + +Returns true if the metaclass for C<$name> has been weakened +(via C<weaken_metaclass>). + +=item B<Class::MOP::does_metaclass_exist($name)> + +This will return true of there exists a metaclass stored in the +C<$name> key, and return false otherwise. + +=item B<Class::MOP::remove_metaclass_by_name($name)> + +This will remove the metaclass stored in the C<$name> key. + +=back + +Some utility functions (such as C<Class::MOP::load_class>) that were +previously defined in C<Class::MOP> regarding loading of classes have been +extracted to L<Class::Load>. Please see L<Class::Load> for documentation. + +=head1 SEE ALSO + +=head2 Books + +There are very few books out on Meta Object Protocols and Metaclasses +because it is such an esoteric topic. The following books are really +the only ones I have found. If you know of any more, B<I<please>> +email me and let me know, I would love to hear about them. + +=over 4 + +=item I<The Art of the Meta Object Protocol> + +=item I<Advances in Object-Oriented Metalevel Architecture and Reflection> + +=item I<Putting MetaClasses to Work> + +=item I<Smalltalk: The Language> + +=back + +=head2 Papers + +=over 4 + +=item "Uniform and safe metaclass composition" + +An excellent paper by the people who brought us the original Traits paper. +This paper is on how Traits can be used to do safe metaclass composition, +and offers an excellent introduction section which delves into the topic of +metaclass compatibility. + +L<http://scg.unibe.ch/archive/papers/Duca05ySafeMetaclassTrait.pdf> + +=item "Safe Metaclass Programming" + +This paper seems to precede the above paper, and propose a mix-in based +approach as opposed to the Traits based approach. Both papers have similar +information on the metaclass compatibility problem space. + +L<http://citeseer.ist.psu.edu/37617.html> + +=back + +=head2 Prior Art + +=over 4 + +=item The Perl 6 MetaModel work in the Pugs project + +=over 4 + +=item L<http://svn.openfoundry.org/pugs/misc/Perl-MetaModel/> + +=item L<http://github.com/perl6/p5-modules/tree/master/Perl6-ObjectSpace/> + +=back + +=back + +=head2 Articles + +=over 4 + +=item CPAN Module Review of Class::MOP + +L<http://www.oreillynet.com/onlamp/blog/2006/06/cpan_module_review_classmop.html> + +=back + +=head1 SIMILAR MODULES + +As I have said above, this module is a class-builder-builder, so it is +not the same thing as modules like L<Class::Accessor> and +L<Class::MethodMaker>. That being said there are very few modules on CPAN +with similar goals to this module. The one I have found which is most +like this module is L<Class::Meta>, although its philosophy and the MOP it +creates are very different from this modules. + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. + +Please report any bugs to C<bug-class-mop@rt.cpan.org>, or through the +web interface at L<http://rt.cpan.org>. + +You can also discuss feature requests or possible bugs on the Moose +mailing list (moose@perl.org) or on IRC at +L<irc://irc.perl.org/#moose>. + +=head1 ACKNOWLEDGEMENTS + +=over 4 + +=item Rob Kinyon + +Thanks to Rob for actually getting the development of this module kick-started. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm new file mode 100644 index 0000000..c5c4995 --- /dev/null +++ b/lib/Class/MOP/Attribute.pm @@ -0,0 +1,1100 @@ +package Class::MOP::Attribute; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::Method::Accessor; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; + +use parent 'Class::MOP::Object', 'Class::MOP::Mixin::AttributeCore'; + +# NOTE: (meta-circularity) +# This method will be replaced in the +# boostrap section of Class::MOP, by +# a new version which uses the +# &Class::MOP::Class::construct_instance +# method to build an attribute meta-object +# which itself is described with attribute +# meta-objects. +# - Ain't meta-circularity grand? :) +sub new { + my ( $class, @args ) = @_; + + unshift @args, "name" if @args % 2 == 1; + my %options = @args; + + my $name = $options{name}; + + (defined $name) + || $class->_throw_exception( MOPAttributeNewNeedsAttributeName => class => $class, + params => \%options + ); + + $options{init_arg} = $name + if not exists $options{init_arg}; + if(exists $options{builder}){ + $class->_throw_exception( BuilderMustBeAMethodName => class => $class, + params => \%options + ) + if ref $options{builder} || !(defined $options{builder}); + $class->_throw_exception( BothBuilderAndDefaultAreNotAllowed => class => $class, + params => \%options + ) + if exists $options{default}; + } else { + ($class->is_default_a_coderef(\%options)) + || $class->_throw_exception( ReferencesAreNotAllowedAsDefault => class => $class, + params => \%options, + attribute_name => $options{name} + ) + if exists $options{default} && ref $options{default}; + } + + if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) { + $class->_throw_exception( RequiredAttributeLacksInitialization => class => $class, + params => \%options + ); + } + + $class->_new(\%options); +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $options = @_ == 1 ? $_[0] : {@_}; + + bless { + 'name' => $options->{name}, + 'accessor' => $options->{accessor}, + 'reader' => $options->{reader}, + 'writer' => $options->{writer}, + 'predicate' => $options->{predicate}, + 'clearer' => $options->{clearer}, + 'builder' => $options->{builder}, + 'init_arg' => $options->{init_arg}, + exists $options->{default} + ? ('default' => $options->{default}) + : (), + 'initializer' => $options->{initializer}, + 'definition_context' => $options->{definition_context}, + # keep a weakened link to the + # class we are associated with + 'associated_class' => undef, + # and a list of the methods + # associated with this attr + 'associated_methods' => [], + # this let's us keep track of + # our order inside the associated + # class + 'insertion_order' => undef, + }, $class; +} + +# NOTE: +# this is a primitive (and kludgy) clone operation +# for now, it will be replaced in the Class::MOP +# bootstrap with a proper one, however we know +# that this one will work fine for now. +sub clone { + my $self = shift; + my %options = @_; + (blessed($self)) + || confess "Can only clone an instance"; + # this implementation is overwritten by the bootstrap process, + # so this exception will never trigger. If it ever does occur, + # it indicates a gigantic problem with the most internal parts + # of Moose, so we wouldn't want a Moose-based exception object anyway + + return bless { %{$self}, %options } => ref($self); +} + +sub initialize_instance_slot { + my ($self, $meta_instance, $instance, $params) = @_; + my $init_arg = $self->{'init_arg'}; + + # try to fetch the init arg from the %params ... + + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if(defined $init_arg and exists $params->{$init_arg}){ + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $params->{$init_arg}, + ); + } + elsif (exists $self->{'default'}) { + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $self->default($instance), + ); + } + elsif (defined( my $builder = $self->{'builder'})) { + if ($builder = $instance->can($builder)) { + $self->_set_initial_slot_value( + $meta_instance, + $instance, + $instance->$builder, + ); + } + else { + $self->_throw_exception( BuilderMethodNotSupportedForAttribute => attribute => $self, + instance => $instance + ); + } + } +} + +sub _set_initial_slot_value { + my ($self, $meta_instance, $instance, $value) = @_; + + my $slot_name = $self->name; + + return $meta_instance->set_slot_value($instance, $slot_name, $value) + unless $self->has_initializer; + + my $callback = $self->_make_initializer_writer_callback( + $meta_instance, $instance, $slot_name + ); + + my $initializer = $self->initializer; + + # most things will just want to set a value, so make it first arg + $instance->$initializer($value, $callback, $self); +} + +sub _make_initializer_writer_callback { + my $self = shift; + my ($meta_instance, $instance, $slot_name) = @_; + + return sub { + $meta_instance->set_slot_value($instance, $slot_name, $_[0]); + }; +} + +sub get_read_method { + my $self = shift; + my $reader = $self->reader || $self->accessor; + # normal case ... + return $reader unless ref $reader; + # the HASH ref case + my ($name) = %$reader; + return $name; +} + +sub get_write_method { + my $self = shift; + my $writer = $self->writer || $self->accessor; + # normal case ... + return $writer unless ref $writer; + # the HASH ref case + my ($name) = %$writer; + return $name; +} + +sub get_read_method_ref { + my $self = shift; + if ((my $reader = $self->get_read_method) && $self->associated_class) { + return $self->associated_class->get_method($reader); + } + else { + my $code = sub { $self->get_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } + } +} + +sub get_write_method_ref { + my $self = shift; + if ((my $writer = $self->get_write_method) && $self->associated_class) { + return $self->associated_class->get_method($writer); + } + else { + my $code = sub { $self->set_value(@_) }; + if (my $class = $self->associated_class) { + return $class->method_metaclass->wrap( + $code, + package_name => $class->name, + name => '__ANON__' + ); + } + else { + return $code; + } + } +} + +# slots + +sub slots { (shift)->name } + +# class association + +sub attach_to_class { + my ($self, $class) = @_; + (blessed($class) && $class->isa('Class::MOP::Class')) + || $self->_throw_exception( AttachToClassNeedsAClassMOPClassInstanceOrASubclass => attribute => $self, + class => $class + ); + weaken($self->{'associated_class'} = $class); +} + +sub detach_from_class { + my $self = shift; + $self->{'associated_class'} = undef; +} + +# method association + +sub associate_method { + my ($self, $method) = @_; + push @{$self->{'associated_methods'}} => $method; +} + +## Slot management + +sub set_initial_value { + my ($self, $instance, $value) = @_; + $self->_set_initial_slot_value( + Class::MOP::Class->initialize(ref($instance))->get_meta_instance, + $instance, + $value + ); +} + +sub set_value { shift->set_raw_value(@_) } + +sub set_raw_value { + my $self = shift; + my ($instance, $value) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->set_slot_value($instance, $self->name, $value); +} + +sub _inline_set_value { + my $self = shift; + return $self->_inline_instance_set(@_) . ';'; +} + +sub _inline_instance_set { + my $self = shift; + my ($instance, $value) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_set_slot_value($instance, $self->name, $value); +} + +sub get_value { shift->get_raw_value(@_) } + +sub get_raw_value { + my $self = shift; + my ($instance) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->get_slot_value($instance, $self->name); +} + +sub _inline_get_value { + my $self = shift; + return $self->_inline_instance_get(@_) . ';'; +} + +sub _inline_instance_get { + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_get_slot_value($instance, $self->name); +} + +sub has_value { + my $self = shift; + my ($instance) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->is_slot_initialized($instance, $self->name); +} + +sub _inline_has_value { + my $self = shift; + return $self->_inline_instance_has(@_) . ';'; +} + +sub _inline_instance_has { + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_is_slot_initialized($instance, $self->name); +} + +sub clear_value { + my $self = shift; + my ($instance) = @_; + + my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; + return $mi->deinitialize_slot($instance, $self->name); +} + +sub _inline_clear_value { + my $self = shift; + return $self->_inline_instance_clear(@_) . ';'; +} + +sub _inline_instance_clear { + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + return $mi->inline_deinitialize_slot($instance, $self->name); +} + +## load em up ... + +sub accessor_metaclass { 'Class::MOP::Method::Accessor' } + +sub _process_accessors { + my ($self, $type, $accessor, $generate_as_inline_methods) = @_; + + my $method_ctx = { %{ $self->definition_context || {} } }; + + if (ref($accessor)) { + (ref($accessor) eq 'HASH') + || $self->_throw_exception( BadOptionFormat => attribute => $self, + option_value => $accessor, + option_name => $type + ); + + my ($name, $method) = %{$accessor}; + + $method_ctx->{description} = $self->_accessor_description($name, $type); + + $method = $self->accessor_metaclass->wrap( + $method, + attribute => $self, + package_name => $self->associated_class->name, + name => $name, + associated_metaclass => $self->associated_class, + definition_context => $method_ctx, + ); + $self->associate_method($method); + return ($name, $method); + } + else { + my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); + my $method; + try { + $method_ctx->{description} = $self->_accessor_description($accessor, $type); + + $method = $self->accessor_metaclass->new( + attribute => $self, + is_inline => $inline_me, + accessor_type => $type, + package_name => $self->associated_class->name, + name => $accessor, + associated_metaclass => $self->associated_class, + definition_context => $method_ctx, + ); + } + catch { + $self->_throw_exception( CouldNotCreateMethod => attribute => $self, + option_value => $accessor, + option_name => $type, + error => $_ + ); + }; + $self->associate_method($method); + return ($accessor, $method); + } +} + +sub _accessor_description { + my $self = shift; + my ($name, $type) = @_; + + my $desc = "$type " . $self->associated_class->name . "::$name"; + if ( $name ne $self->name ) { + $desc .= " of attribute " . $self->name; + } + + return $desc; +} + +sub install_accessors { + my $self = shift; + my $inline = shift; + my $class = $self->associated_class; + + $class->add_method( + $self->_process_accessors('accessor' => $self->accessor(), $inline) + ) if $self->has_accessor(); + + $class->add_method( + $self->_process_accessors('reader' => $self->reader(), $inline) + ) if $self->has_reader(); + + $class->add_method( + $self->_process_accessors('writer' => $self->writer(), $inline) + ) if $self->has_writer(); + + $class->add_method( + $self->_process_accessors('predicate' => $self->predicate(), $inline) + ) if $self->has_predicate(); + + $class->add_method( + $self->_process_accessors('clearer' => $self->clearer(), $inline) + ) if $self->has_clearer(); + + return; +} + +{ + my $_remove_accessor = sub { + my ($accessor, $class) = @_; + if (ref($accessor) && ref($accessor) eq 'HASH') { + ($accessor) = keys %{$accessor}; + } + my $method = $class->get_method($accessor); + $class->remove_method($accessor) + if (ref($method) && $method->isa('Class::MOP::Method::Accessor')); + }; + + sub remove_accessors { + my $self = shift; + # TODO: + # we really need to make sure to remove from the + # associates methods here as well. But this is + # such a slimly used method, I am not worried + # about it right now. + $_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor(); + $_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader(); + $_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer(); + $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate(); + $_remove_accessor->($self->clearer(), $self->associated_class()) if $self->has_clearer(); + return; + } + +} + +1; + +# ABSTRACT: Attribute Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Attribute - Attribute Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + Class::MOP::Attribute->new( + foo => ( + accessor => 'foo', # dual purpose get/set accessor + predicate => 'has_foo', # predicate check for defined-ness + init_arg => '-foo', # class->new will look for a -foo key + default => 'BAR IS BAZ!' # if no -foo key is provided, use this + ) + ); + + Class::MOP::Attribute->new( + bar => ( + reader => 'bar', # getter + writer => 'set_bar', # setter + predicate => 'has_bar', # predicate check for defined-ness + init_arg => ':bar', # class->new will look for a :bar key + # no default value means it is undef + ) + ); + +=head1 DESCRIPTION + +The Attribute Protocol is almost entirely an invention of +C<Class::MOP>. Perl 5 does not have a consistent notion of +attributes. There are so many ways in which this is done, and very few +(if any) are easily discoverable by this module. + +With that said, this module attempts to inject some order into this +chaos, by introducing a consistent API which can be used to create +object attributes. + +=head1 METHODS + +=head2 Creation + +=over 4 + +=item B<< Class::MOP::Attribute->new($name, ?%options) >> + +An attribute must (at the very least), have a C<$name>. All other +C<%options> are added as key-value pairs. + +=over 8 + +=item * init_arg + +This is a string value representing the expected key in an +initialization hash. For instance, if we have an C<init_arg> value of +C<-foo>, then the following code will Just Work. + + MyClass->meta->new_object( -foo => 'Hello There' ); + +If an init_arg is not assigned, it will automatically use the +attribute's name. If C<init_arg> is explicitly set to C<undef>, the +attribute cannot be specified during initialization. + +=item * builder + +This provides the name of a method that will be called to initialize +the attribute. This method will be called on the object after it is +constructed. It is expected to return a valid value for the attribute. + +=item * default + +This can be used to provide an explicit default for initializing the +attribute. If the default you provide is a subroutine reference, then +this reference will be called I<as a method> on the object. + +If the value is a simple scalar (string or number), then it can be +just passed as is. However, if you wish to initialize it with a HASH +or ARRAY ref, then you need to wrap that inside a subroutine +reference: + + Class::MOP::Attribute->new( + 'foo' => ( + default => sub { [] }, + ) + ); + + # or ... + + Class::MOP::Attribute->new( + 'foo' => ( + default => sub { {} }, + ) + ); + +If you wish to initialize an attribute with a subroutine reference +itself, then you need to wrap that in a subroutine as well: + + Class::MOP::Attribute->new( + 'foo' => ( + default => sub { + sub { print "Hello World" } + }, + ) + ); + +And lastly, if the value of your attribute is dependent upon some +other aspect of the instance structure, then you can take advantage of +the fact that when the C<default> value is called as a method: + + Class::MOP::Attribute->new( + 'object_identity' => ( + default => sub { Scalar::Util::refaddr( $_[0] ) }, + ) + ); + +Note that there is no guarantee that attributes are initialized in any +particular order, so you cannot rely on the value of some other +attribute when generating the default. + +=item * initializer + +This option can be either a method name or a subroutine +reference. This method will be called when setting the attribute's +value in the constructor. Unlike C<default> and C<builder>, the +initializer is only called when a value is provided to the +constructor. The initializer allows you to munge this value during +object construction. + +The initializer is called as a method with three arguments. The first +is the value that was passed to the constructor. The second is a +subroutine reference that can be called to actually set the +attribute's value, and the last is the associated +C<Class::MOP::Attribute> object. + +This contrived example shows an initializer that sets the attribute to +twice the given value. + + Class::MOP::Attribute->new( + 'doubled' => ( + initializer => sub { + my ( $self, $value, $set, $attr ) = @_; + $set->( $value * 2 ); + }, + ) + ); + +Since an initializer can be a method name, you can easily make +attribute initialization use the writer: + + Class::MOP::Attribute->new( + 'some_attr' => ( + writer => 'some_attr', + initializer => 'some_attr', + ) + ); + +Your writer (actually, a wrapper around the writer, using +L<method modifications|Moose::Manual::MethodModifiers>) will need to examine +C<@_> and determine under which +context it is being called: + + around 'some_attr' => sub { + my $orig = shift; + my $self = shift; + # $value is not defined if being called as a reader + # $setter and $attr are only defined if being called as an initializer + my ($value, $setter, $attr) = @_; + + # the reader behaves normally + return $self->$orig if not @_; + + # mutate $value as desired + # $value = <something($value); + + # if called as an initializer, set the value and we're done + return $setter->($row) if $setter; + + # otherwise, call the real writer with the new value + $self->$orig($row); + }; + +=back + +The C<accessor>, C<reader>, C<writer>, C<predicate> and C<clearer> +options all accept the same parameters. You can provide the name of +the method, in which case an appropriate default method will be +generated for you. Or instead you can also provide hash reference +containing exactly one key (the method name) and one value. The value +should be a subroutine reference, which will be installed as the +method itself. + +=over 8 + +=item * accessor + +An C<accessor> is a standard Perl-style read/write accessor. It will +return the value of the attribute, and if a value is passed as an +argument, it will assign that value to the attribute. + +Note that C<undef> is a legitimate value, so this will work: + + $object->set_something(undef); + +=item * reader + +This is a basic read-only accessor. It returns the value of the +attribute. + +=item * writer + +This is a basic write accessor, it accepts a single argument, and +assigns that value to the attribute. + +Note that C<undef> is a legitimate value, so this will work: + + $object->set_something(undef); + +=item * predicate + +The predicate method returns a boolean indicating whether or not the +attribute has been explicitly set. + +Note that the predicate returns true even if the attribute was set to +a false value (C<0> or C<undef>). + +=item * clearer + +This method will uninitialize the attribute. After an attribute is +cleared, its C<predicate> will return false. + +=item * definition_context + +Mostly, this exists as a hook for the benefit of Moose. + +This option should be a hash reference containing several keys which +will be used when inlining the attribute's accessors. The keys should +include C<line>, the line number where the attribute was created, and +either C<file> or C<description>. + +This information will ultimately be used when eval'ing inlined +accessor code so that error messages report a useful line and file +name. + +=back + +=item B<< $attr->clone(%options) >> + +This clones the attribute. Any options you provide will override the +settings of the original attribute. You can change the name of the new +attribute by passing a C<name> key in C<%options>. + +=back + +=head2 Informational + +These are all basic read-only accessors for the values passed into +the constructor. + +=over 4 + +=item B<< $attr->name >> + +Returns the attribute's name. + +=item B<< $attr->accessor >> + +=item B<< $attr->reader >> + +=item B<< $attr->writer >> + +=item B<< $attr->predicate >> + +=item B<< $attr->clearer >> + +The C<accessor>, C<reader>, C<writer>, C<predicate>, and C<clearer> +methods all return exactly what was passed to the constructor, so it +can be either a string containing a method name, or a hash reference. + +=item B<< $attr->initializer >> + +Returns the initializer as passed to the constructor, so this may be +either a method name or a subroutine reference. + +=item B<< $attr->init_arg >> + +=item B<< $attr->is_default_a_coderef >> + +=item B<< $attr->builder >> + +=item B<< $attr->default($instance) >> + +The C<$instance> argument is optional. If you don't pass it, the +return value for this method is exactly what was passed to the +constructor, either a simple scalar or a subroutine reference. + +If you I<do> pass an C<$instance> and the default is a subroutine +reference, then the reference is called as a method on the +C<$instance> and the generated value is returned. + +=item B<< $attr->slots >> + +Return a list of slots required by the attribute. This is usually just +one, the name of the attribute. + +A slot is the name of the hash key used to store the attribute in an +object instance. + +=item B<< $attr->get_read_method >> + +=item B<< $attr->get_write_method >> + +Returns the name of a method suitable for reading or writing the value +of the attribute in the associated class. + +If an attribute is read- or write-only, then these methods can return +C<undef> as appropriate. + +=item B<< $attr->has_read_method >> + +=item B<< $attr->has_write_method >> + +This returns a boolean indicating whether the attribute has a I<named> +read or write method. + +=item B<< $attr->get_read_method_ref >> + +=item B<< $attr->get_write_method_ref >> + +Returns the subroutine reference of a method suitable for reading or +writing the attribute's value in the associated class. These methods +always return a subroutine reference, regardless of whether or not the +attribute is read- or write-only. + +=item B<< $attr->insertion_order >> + +If this attribute has been inserted into a class, this returns a zero +based index regarding the order of insertion. + +=back + +=head2 Informational predicates + +These are all basic predicate methods for the values passed into C<new>. + +=over 4 + +=item B<< $attr->has_accessor >> + +=item B<< $attr->has_reader >> + +=item B<< $attr->has_writer >> + +=item B<< $attr->has_predicate >> + +=item B<< $attr->has_clearer >> + +=item B<< $attr->has_initializer >> + +=item B<< $attr->has_init_arg >> + +This will be I<false> if the C<init_arg> was set to C<undef>. + +=item B<< $attr->has_default >> + +This will be I<false> if the C<default> was set to C<undef>, since +C<undef> is the default C<default> anyway. + +=item B<< $attr->has_builder >> + +=item B<< $attr->has_insertion_order >> + +This will be I<false> if this attribute has not be inserted into a class + +=back + +=head2 Value management + +These methods are basically "back doors" to the instance, and can be +used to bypass the regular accessors, but still stay within the MOP. + +These methods are not for general use, and should only be used if you +really know what you are doing. + +=over 4 + +=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >> + +This method is used internally to initialize the attribute's slot in +the object C<$instance>. + +The C<$params> is a hash reference of the values passed to the object +constructor. + +It's unlikely that you'll need to call this method yourself. + +=item B<< $attr->set_value($instance, $value) >> + +Sets the value without going through the accessor. Note that this +works even with read-only attributes. + +=item B<< $attr->set_raw_value($instance, $value) >> + +Sets the value with no side effects such as a trigger. + +This doesn't actually apply to Class::MOP attributes, only to subclasses. + +=item B<< $attr->set_initial_value($instance, $value) >> + +Sets the value without going through the accessor. This method is only +called when the instance is first being initialized. + +=item B<< $attr->get_value($instance) >> + +Returns the value without going through the accessor. Note that this +works even with write-only accessors. + +=item B<< $attr->get_raw_value($instance) >> + +Returns the value without any side effects such as lazy attributes. + +Doesn't actually apply to Class::MOP attributes, only to subclasses. + +=item B<< $attr->has_value($instance) >> + +Return a boolean indicating whether the attribute has been set in +C<$instance>. This how the default C<predicate> method works. + +=item B<< $attr->clear_value($instance) >> + +This will clear the attribute's value in C<$instance>. This is what +the default C<clearer> calls. + +Note that this works even if the attribute does not have any +associated read, write or clear methods. + +=back + +=head2 Class association + +These methods allow you to manage the attributes association with +the class that contains it. These methods should not be used +lightly, nor are they very magical, they are mostly used internally +and by metaclass instances. + +=over 4 + +=item B<< $attr->associated_class >> + +This returns the L<Class::MOP::Class> with which this attribute is +associated, if any. + +=item B<< $attr->attach_to_class($metaclass) >> + +This method stores a weakened reference to the C<$metaclass> object +internally. + +This method does not remove the attribute from its old class, +nor does it create any accessors in the new class. + +It is probably best to use the L<Class::MOP::Class> C<add_attribute> +method instead. + +=item B<< $attr->detach_from_class >> + +This method removes the associate metaclass object from the attribute +it has one. + +This method does not remove the attribute itself from the class, or +remove its accessors. + +It is probably best to use the L<Class::MOP::Class> +C<remove_attribute> method instead. + +=back + +=head2 Attribute Accessor generation + +=over 4 + +=item B<< $attr->accessor_metaclass >> + +Accessor methods are generated using an accessor metaclass. By +default, this is L<Class::MOP::Method::Accessor>. This method returns +the name of the accessor metaclass that this attribute uses. + +=item B<< $attr->associate_method($method) >> + +This associates a L<Class::MOP::Method> object with the +attribute. Typically, this is called internally when an attribute +generates its accessors. + +=item B<< $attr->associated_methods >> + +This returns the list of methods which have been associated with the +attribute. + +=item B<< $attr->install_accessors >> + +This method generates and installs code the attributes various +accessors. It is typically called from the L<Class::MOP::Class> +C<add_attribute> method. + +=item B<< $attr->remove_accessors >> + +This method removes all of the accessors associated with the +attribute. + +This does not currently remove methods from the list returned by +C<associated_methods>. + +=item B<< $attr->inline_get >> + +=item B<< $attr->inline_set >> + +=item B<< $attr->inline_has >> + +=item B<< $attr->inline_clear >> + +These methods return a code snippet suitable for inlining the relevant +operation. They expect strings containing variable names to be used in the +inlining, like C<'$self'> or C<'$_[1]'>. + +=back + +=head2 Introspection + +=over 4 + +=item B<< Class::MOP::Attribute->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +It should also be noted that L<Class::MOP> will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm new file mode 100644 index 0000000..c5e1bae --- /dev/null +++ b/lib/Class/MOP/Class.pm @@ -0,0 +1,2312 @@ +package Class::MOP::Class; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::Instance; +use Class::MOP::Method::Wrapped; +use Class::MOP::Method::Accessor; +use Class::MOP::Method::Constructor; +use Class::MOP::MiniTrait; + +use Carp 'confess'; +use Module::Runtime 'use_package_optimistically'; +use Scalar::Util 'blessed'; +use Sub::Name 'subname'; +use Try::Tiny; +use List::Util 1.33 'all'; + +use parent 'Class::MOP::Module', + 'Class::MOP::Mixin::HasAttributes', + 'Class::MOP::Mixin::HasMethods', + 'Class::MOP::Mixin::HasOverloads'; + +# Creation + +sub initialize { + my $class = shift; + + my $package_name; + + if ( @_ % 2 ) { + $package_name = shift; + } else { + my %options = @_; + $package_name = $options{package}; + } + + ($package_name && !ref($package_name)) + || ($class||__PACKAGE__)->_throw_exception( InitializeTakesUnBlessedPackageName => package_name => $package_name ); + return Class::MOP::get_metaclass_by_name($package_name) + || $class->_construct_class_instance(package => $package_name, @_); +} + +sub reinitialize { + my ( $class, @args ) = @_; + unshift @args, "package" if @args % 2; + my %options = @args; + my $old_metaclass = blessed($options{package}) + ? $options{package} + : Class::MOP::get_metaclass_by_name($options{package}); + $options{weaken} = Class::MOP::metaclass_is_weak($old_metaclass->name) + if !exists $options{weaken} + && blessed($old_metaclass) + && $old_metaclass->isa('Class::MOP::Class'); + $old_metaclass->_remove_generated_metaobjects + if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); + my $new_metaclass = $class->SUPER::reinitialize(%options); + $new_metaclass->_restore_metaobjects_from($old_metaclass) + if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); + return $new_metaclass; +} + +# NOTE: (meta-circularity) +# this is a special form of _construct_instance +# (see below), which is used to construct class +# meta-object instances for any Class::MOP::* +# class. All other classes will use the more +# normal &construct_instance. +sub _construct_class_instance { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + my $package_name = $options->{package}; + (defined $package_name && $package_name) + || $class->_throw_exception("ConstructClassInstanceTakesPackageName"); + # NOTE: + # return the metaclass if we have it cached, + # and it is still defined (it has not been + # reaped by DESTROY yet, which can happen + # annoyingly enough during global destruction) + + if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) { + return $meta; + } + + $class + = ref $class + ? $class->_real_ref_name + : $class; + + # now create the metaclass + my $meta; + if ($class eq 'Class::MOP::Class') { + $meta = $class->_new($options); + } + else { + # NOTE: + # it is safe to use meta here because + # class will always be a subclass of + # Class::MOP::Class, which defines meta + $meta = $class->meta->_construct_instance($options) + } + + # and check the metaclass compatibility + $meta->_check_metaclass_compatibility(); + + Class::MOP::store_metaclass_by_name($package_name, $meta); + + # NOTE: + # we need to weaken any anon classes + # so that they can call DESTROY properly + Class::MOP::weaken_metaclass($package_name) if $options->{weaken}; + + $meta; +} + +sub _real_ref_name { + my $self = shift; + + # NOTE: we need to deal with the possibility of class immutability here, + # and then get the name of the class appropriately + return $self->is_immutable + ? $self->_get_mutable_metaclass_name() + : ref $self; +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $options = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Package + 'package' => $options->{package}, + + # NOTE: + # since the following attributes will + # actually be loaded from the symbol + # table, and actually bypass the instance + # entirely, we can just leave these things + # listed here for reference, because they + # should not actually have a value associated + # with the slot. + 'namespace' => \undef, + 'methods' => {}, + + # inherited from Class::MOP::Module + 'version' => \undef, + 'authority' => \undef, + + # defined in Class::MOP::Class + 'superclasses' => \undef, + + 'attributes' => {}, + 'attribute_metaclass' => + ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ), + 'method_metaclass' => + ( $options->{'method_metaclass'} || 'Class::MOP::Method' ), + 'wrapped_method_metaclass' => ( + $options->{'wrapped_method_metaclass'} + || 'Class::MOP::Method::Wrapped' + ), + 'instance_metaclass' => + ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ), + 'immutable_trait' => ( + $options->{'immutable_trait'} + || 'Class::MOP::Class::Immutable::Trait' + ), + 'constructor_name' => ( $options->{constructor_name} || 'new' ), + 'constructor_class' => ( + $options->{constructor_class} || 'Class::MOP::Method::Constructor' + ), + 'destructor_class' => $options->{destructor_class}, + }, $class; +} + +## Metaclass compatibility +{ + my %base_metaclass = ( + attribute_metaclass => 'Class::MOP::Attribute', + method_metaclass => 'Class::MOP::Method', + wrapped_method_metaclass => 'Class::MOP::Method::Wrapped', + instance_metaclass => 'Class::MOP::Instance', + constructor_class => 'Class::MOP::Method::Constructor', + destructor_class => 'Class::MOP::Method::Destructor', + ); + + sub _base_metaclasses { %base_metaclass } +} + +sub _check_metaclass_compatibility { + my $self = shift; + + my @superclasses = $self->superclasses + or return; + + $self->_fix_metaclass_incompatibility(@superclasses); + + my %base_metaclass = $self->_base_metaclasses; + + # this is always okay ... + return + if ref($self) eq 'Class::MOP::Class' + && all { + my $meta = $self->$_; + !defined($meta) || $meta eq $base_metaclass{$_}; + } + keys %base_metaclass; + + for my $superclass (@superclasses) { + $self->_check_class_metaclass_compatibility($superclass); + } + + for my $metaclass_type ( keys %base_metaclass ) { + next unless defined $self->$metaclass_type; + for my $superclass (@superclasses) { + $self->_check_single_metaclass_compatibility( $metaclass_type, + $superclass ); + } + } +} + +sub _check_class_metaclass_compatibility { + my $self = shift; + my ( $superclass_name ) = @_; + + if (!$self->_class_metaclass_is_compatible($superclass_name)) { + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name); + + my $super_meta_type = $super_meta->_real_ref_name; + + $self->_throw_exception( IncompatibleMetaclassOfSuperclass => class_name => $self->name, + class_meta_type => ref( $self ), + superclass_name => $superclass_name, + superclass_meta_type => $super_meta_type + ); + } +} + +sub _class_metaclass_is_compatible { + my $self = shift; + my ( $superclass_name ) = @_; + + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) + || return 1; + + my $super_meta_name = $super_meta->_real_ref_name; + + return $self->_is_compatible_with($super_meta_name); +} + +sub _check_single_metaclass_compatibility { + my $self = shift; + my ( $metaclass_type, $superclass_name ) = @_; + + if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) { + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name); + + $self->_throw_exception( MetaclassTypeIncompatible => class_name => $self->name, + superclass_name => $superclass_name, + metaclass_type => $metaclass_type + ); + } +} + +sub _single_metaclass_is_compatible { + my $self = shift; + my ( $metaclass_type, $superclass_name ) = @_; + + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) + || return 1; + + # for instance, Moose::Meta::Class has a error_class attribute, but + # Class::MOP::Class doesn't - this shouldn't be an error + return 1 unless $super_meta->can($metaclass_type); + # for instance, Moose::Meta::Class has a destructor_class, but + # Class::MOP::Class doesn't - this shouldn't be an error + return 1 unless defined $super_meta->$metaclass_type; + # if metaclass is defined in superclass but not here, it's not compatible + # this is a really odd case + return 0 unless defined $self->$metaclass_type; + + return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type); +} + +sub _fix_metaclass_incompatibility { + my $self = shift; + my @supers = map { Class::MOP::Class->initialize($_) } @_; + + my $necessary = 0; + for my $super (@supers) { + $necessary = 1 + if $self->_can_fix_metaclass_incompatibility($super); + } + return unless $necessary; + + for my $super (@supers) { + if (!$self->_class_metaclass_is_compatible($super->name)) { + $self->_fix_class_metaclass_incompatibility($super); + } + } + + my %base_metaclass = $self->_base_metaclasses; + for my $metaclass_type (keys %base_metaclass) { + for my $super (@supers) { + if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) { + $self->_fix_single_metaclass_incompatibility( + $metaclass_type, $super + ); + } + } + } +} + +sub _can_fix_metaclass_incompatibility { + my $self = shift; + my ($super_meta) = @_; + + return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta); + + my %base_metaclass = $self->_base_metaclasses; + for my $metaclass_type (keys %base_metaclass) { + return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type); + } + + return; +} + +sub _class_metaclass_can_be_made_compatible { + my $self = shift; + my ($super_meta) = @_; + + return $self->_can_be_made_compatible_with($super_meta->_real_ref_name); +} + +sub _single_metaclass_can_be_made_compatible { + my $self = shift; + my ($super_meta, $metaclass_type) = @_; + + my $specific_meta = $self->$metaclass_type; + + return unless $super_meta->can($metaclass_type); + my $super_specific_meta = $super_meta->$metaclass_type; + + # for instance, Moose::Meta::Class has a destructor_class, but + # Class::MOP::Class doesn't - this shouldn't be an error + return unless defined $super_specific_meta; + + # if metaclass is defined in superclass but not here, it's fixable + # this is a really odd case + return 1 unless defined $specific_meta; + + return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta); +} + +sub _fix_class_metaclass_incompatibility { + my $self = shift; + my ( $super_meta ) = @_; + + if ($self->_class_metaclass_can_be_made_compatible($super_meta)) { + ($self->is_pristine) + || $self->_throw_exception( CannotFixMetaclassCompatibility => class_name => $self->name, + superclass => $super_meta + ); + + my $super_meta_name = $super_meta->_real_ref_name; + + $self->_make_compatible_with($super_meta_name); + } +} + +sub _fix_single_metaclass_incompatibility { + my $self = shift; + my ( $metaclass_type, $super_meta ) = @_; + + if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { + ($self->is_pristine) + || $self->_throw_exception( CannotFixMetaclassCompatibility => class_name => $self->name, + superclass => $super_meta, + metaclass_type => $metaclass_type + ); + + my $new_metaclass = $self->$metaclass_type + ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type) + : $super_meta->$metaclass_type; + $self->{$metaclass_type} = $new_metaclass; + } +} + +sub _restore_metaobjects_from { + my $self = shift; + my ($old_meta) = @_; + + $self->_restore_metamethods_from($old_meta); + $self->_restore_metaattributes_from($old_meta); +} + +sub _remove_generated_metaobjects { + my $self = shift; + + for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) { + $attr->remove_accessors; + } +} + +# creating classes with MOP ... + +sub create { + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; + + (ref $options{superclasses} eq 'ARRAY') + || __PACKAGE__->_throw_exception( CreateMOPClassTakesArrayRefOfSuperclasses => class => $class, + params => \%options + ) + if exists $options{superclasses}; + + (ref $options{attributes} eq 'ARRAY') + || __PACKAGE__->_throw_exception( CreateMOPClassTakesArrayRefOfAttributes => class => $class, + params => \%options + ) + if exists $options{attributes}; + + (ref $options{methods} eq 'HASH') + || __PACKAGE__->_throw_exception( CreateMOPClassTakesHashRefOfMethods => class => $class, + params => \%options + ) + if exists $options{methods}; + + my $package = delete $options{package}; + my $superclasses = delete $options{superclasses}; + my $attributes = delete $options{attributes}; + my $methods = delete $options{methods}; + my $meta_name = exists $options{meta_name} + ? delete $options{meta_name} + : 'meta'; + + my $meta = $class->SUPER::create($package => %options); + + $meta->_add_meta_method($meta_name) + if defined $meta_name; + + $meta->superclasses(@{$superclasses}) + if defined $superclasses; + # NOTE: + # process attributes first, so that they can + # install accessors, but locally defined methods + # can then overwrite them. It is maybe a little odd, but + # I think this should be the order of things. + if (defined $attributes) { + foreach my $attr (@{$attributes}) { + $meta->add_attribute($attr); + } + } + if (defined $methods) { + foreach my $method_name (keys %{$methods}) { + $meta->add_method($method_name, $methods->{$method_name}); + } + } + return $meta; +} + +# XXX: something more intelligent here? +sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' } + +sub create_anon_class { shift->create_anon(@_) } +sub is_anon_class { shift->is_anon(@_) } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + # Makes something like Super::Class|Super::Class::2 + return join '=' => ( + join( '|', sort @{ $options{superclasses} || [] } ), + ); +} + +# Instance Construction & Cloning + +sub new_object { + my $class = shift; + + # NOTE: + # we need to protect the integrity of the + # Class::MOP::Class singletons here, so we + # delegate this to &construct_class_instance + # which will deal with the singletons + return $class->_construct_class_instance(@_) + if $class->name->isa('Class::MOP::Class'); + return $class->_construct_instance(@_); +} + +sub _construct_instance { + my $class = shift; + my $params = @_ == 1 ? $_[0] : {@_}; + my $meta_instance = $class->get_meta_instance(); + # FIXME: + # the code below is almost certainly incorrect + # but this is foreign inheritance, so we might + # have to kludge it in the end. + my $instance; + if (my $instance_class = blessed($params->{__INSTANCE__})) { + ($instance_class eq $class->name) + || $class->_throw_exception( InstanceBlessedIntoWrongClass => class_name => $class->name, + params => $params, + instance => $params->{__INSTANCE__} + ); + $instance = $params->{__INSTANCE__}; + } + elsif (exists $params->{__INSTANCE__}) { + $class->_throw_exception( InstanceMustBeABlessedReference => class_name => $class->name, + params => $params, + instance => $params->{__INSTANCE__} + ); + } + else { + $instance = $meta_instance->create_instance(); + } + foreach my $attr ($class->get_all_attributes()) { + $attr->initialize_instance_slot($meta_instance, $instance, $params); + } + if (Class::MOP::metaclass_is_weak($class->name)) { + $meta_instance->_set_mop_slot($instance, $class); + } + return $instance; +} + +sub _inline_new_object { + my $self = shift; + + return ( + 'my $class = shift;', + '$class = Scalar::Util::blessed($class) || $class;', + $self->_inline_fallback_constructor('$class'), + $self->_inline_params('$params', '$class'), + $self->_inline_generate_instance('$instance', '$class'), + $self->_inline_slot_initializers, + $self->_inline_preserve_weak_metaclasses, + $self->_inline_extra_init, + 'return $instance', + ); +} + +sub _inline_fallback_constructor { + my $self = shift; + my ($class) = @_; + return ( + 'return ' . $self->_generate_fallback_constructor($class), + 'if ' . $class . ' ne \'' . $self->name . '\';', + ); +} + +sub _generate_fallback_constructor { + my $self = shift; + my ($class) = @_; + return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)', +} + +sub _inline_params { + my $self = shift; + my ($params, $class) = @_; + return ( + 'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};', + ); +} + +sub _inline_generate_instance { + my $self = shift; + my ($inst, $class) = @_; + return ( + 'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';', + ); +} + +sub _inline_create_instance { + my $self = shift; + + return $self->get_meta_instance->inline_create_instance(@_); +} + +sub _inline_slot_initializers { + my $self = shift; + + my $idx = 0; + + return map { $self->_inline_slot_initializer($_, $idx++) } + sort { $a->name cmp $b->name } $self->get_all_attributes; +} + +sub _inline_slot_initializer { + my $self = shift; + my ($attr, $idx) = @_; + + if (defined(my $init_arg = $attr->init_arg)) { + my @source = ( + 'if (exists $params->{\'' . $init_arg . '\'}) {', + $self->_inline_init_attr_from_constructor($attr, $idx), + '}', + ); + if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) { + push @source, ( + 'else {', + @default, + '}', + ); + } + return @source; + } + elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) { + return ( + '{', + @default, + '}', + ); + } + else { + return (); + } +} + +sub _inline_init_attr_from_constructor { + my $self = shift; + my ($attr, $idx) = @_; + + my @initial_value = $attr->_inline_set_value( + '$instance', '$params->{\'' . $attr->init_arg . '\'}', + ); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_init_attr_from_default { + my $self = shift; + my ($attr, $idx) = @_; + + my $default = $self->_inline_default_value($attr, $idx); + return unless $default; + + my @initial_value = $attr->_inline_set_value('$instance', $default); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_default_value { + my $self = shift; + my ($attr, $index) = @_; + + if ($attr->has_default) { + # NOTE: + # default values can either be CODE refs + # in which case we need to call them. Or + # they can be scalars (strings/numbers) + # in which case we can just deal with them + # in the code we eval. + if ($attr->is_default_a_coderef) { + return '$defaults->[' . $index . ']->($instance)'; + } + else { + return '$defaults->[' . $index . ']'; + } + } + elsif ($attr->has_builder) { + return '$instance->' . $attr->builder; + } + else { + return; + } +} + +sub _inline_preserve_weak_metaclasses { + my $self = shift; + if (Class::MOP::metaclass_is_weak($self->name)) { + return ( + $self->_inline_set_mop_slot( + '$instance', 'Class::MOP::class_of($class)' + ) . ';' + ); + } + else { + return (); + } +} + +sub _inline_extra_init { } + +sub _eval_environment { + my $self = shift; + + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; + + my $defaults = [map { $_->default } @attrs]; + + return { + '$defaults' => \$defaults, + }; +} + + +sub get_meta_instance { + my $self = shift; + $self->{'_meta_instance'} ||= $self->_create_meta_instance(); +} + +sub _create_meta_instance { + my $self = shift; + + my $instance = $self->instance_metaclass->new( + associated_metaclass => $self, + attributes => [ $self->get_all_attributes() ], + ); + + $self->add_meta_instance_dependencies() + if $instance->is_dependent_on_superclasses(); + + return $instance; +} + +# TODO: this is actually not being used! +sub _inline_rebless_instance { + my $self = shift; + + return $self->get_meta_instance->inline_rebless_instance_structure(@_); +} + +sub _inline_get_mop_slot { + my $self = shift; + + return $self->get_meta_instance->_inline_get_mop_slot(@_); +} + +sub _inline_set_mop_slot { + my $self = shift; + + return $self->get_meta_instance->_inline_set_mop_slot(@_); +} + +sub _inline_clear_mop_slot { + my $self = shift; + + return $self->get_meta_instance->_inline_clear_mop_slot(@_); +} + +sub clone_object { + my $class = shift; + my $instance = shift; + (blessed($instance) && $instance->isa($class->name)) + || $class->_throw_exception( CloneObjectExpectsAnInstanceOfMetaclass => class_name => $class->name, + instance => $instance, + ); + # NOTE: + # we need to protect the integrity of the + # Class::MOP::Class singletons here, they + # should not be cloned. + return $instance if $instance->isa('Class::MOP::Class'); + $class->_clone_instance($instance, @_); +} + +sub _clone_instance { + my ($class, $instance, %params) = @_; + (blessed($instance)) + || $class->_throw_exception( OnlyInstancesCanBeCloned => class_name => $class->name, + instance => $instance, + params => \%params + ); + my $meta_instance = $class->get_meta_instance(); + my $clone = $meta_instance->clone_instance($instance); + foreach my $attr ($class->get_all_attributes()) { + if ( defined( my $init_arg = $attr->init_arg ) ) { + if (exists $params{$init_arg}) { + $attr->set_value($clone, $params{$init_arg}); + } + } + } + return $clone; +} + +sub _force_rebless_instance { + my ($self, $instance, %params) = @_; + my $old_metaclass = Class::MOP::class_of($instance); + + $old_metaclass->rebless_instance_away($instance, $self, %params) + if $old_metaclass; + + my $meta_instance = $self->get_meta_instance; + + if (Class::MOP::metaclass_is_weak($old_metaclass->name)) { + $meta_instance->_clear_mop_slot($instance); + } + + # rebless! + # we use $_[1] here because of t/cmop/rebless_overload.t regressions + # on 5.8.8 + $meta_instance->rebless_instance_structure($_[1], $self); + + $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params); + + if (Class::MOP::metaclass_is_weak($self->name)) { + $meta_instance->_set_mop_slot($instance, $self); + } +} + +sub rebless_instance { + my ($self, $instance, %params) = @_; + my $old_metaclass = Class::MOP::class_of($instance); + + my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance); + $self->name->isa($old_class) + || $self->_throw_exception( CanReblessOnlyIntoASubclass => class_name => $self->name, + instance => $instance, + instance_class => blessed( $instance ), + params => \%params, + ); + + $self->_force_rebless_instance($_[1], %params); + + return $instance; +} + +sub rebless_instance_back { + my ( $self, $instance ) = @_; + my $old_metaclass = Class::MOP::class_of($instance); + my $old_class + = $old_metaclass ? $old_metaclass->name : blessed($instance); + $old_class->isa( $self->name ) + || $self->_throw_exception( CanReblessOnlyIntoASuperclass => class_name => $self->name, + instance => $instance, + instance_class => blessed( $instance ), + ); + + $self->_force_rebless_instance($_[1]); + + return $instance; +} + +sub rebless_instance_away { + # this intentionally does nothing, it is just a hook +} + +sub _fixup_attributes_after_rebless { + my $self = shift; + my ($instance, $rebless_from, %params) = @_; + my $meta_instance = $self->get_meta_instance; + + for my $attr ( $rebless_from->get_all_attributes ) { + next if $self->find_attribute_by_name( $attr->name ); + $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots; + } + + foreach my $attr ( $self->get_all_attributes ) { + if ( $attr->has_value($instance) ) { + if ( defined( my $init_arg = $attr->init_arg ) ) { + $params{$init_arg} = $attr->get_value($instance) + unless exists $params{$init_arg}; + } + else { + $attr->set_value($instance, $attr->get_value($instance)); + } + } + } + + foreach my $attr ($self->get_all_attributes) { + $attr->initialize_instance_slot($meta_instance, $instance, \%params); + } +} + +sub _attach_attribute { + my ($self, $attribute) = @_; + $attribute->attach_to_class($self); +} + +sub _post_add_attribute { + my ( $self, $attribute ) = @_; + + $self->invalidate_meta_instances; + + # invalidate package flag here + try { + local $SIG{__DIE__}; + $attribute->install_accessors; + } + catch { + $self->remove_attribute( $attribute->name ); + die $_; + }; +} + +sub remove_attribute { + my $self = shift; + + my $removed_attribute = $self->SUPER::remove_attribute(@_) + or return; + + $self->invalidate_meta_instances; + + $removed_attribute->remove_accessors; + $removed_attribute->detach_from_class; + + return$removed_attribute; +} + +sub find_attribute_by_name { + my ( $self, $attr_name ) = @_; + + foreach my $class ( $self->linearized_isa ) { + # fetch the meta-class ... + my $meta = Class::MOP::Class->initialize($class); + return $meta->get_attribute($attr_name) + if $meta->has_attribute($attr_name); + } + + return; +} + +sub get_all_attributes { + my $self = shift; + my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } } + reverse $self->linearized_isa; + return values %attrs; +} + +# Inheritance + +sub superclasses { + my $self = shift; + + my $isa = $self->get_or_add_package_symbol('@ISA'); + + if (@_) { + my @supers = @_; + @{$isa} = @supers; + + # NOTE: + # on 5.8 and below, we need to call + # a method to get Perl to detect + # a cycle in the class hierarchy + my $class = $self->name; + $class->isa($class); + + # NOTE: + # we need to check the metaclass + # compatibility here so that we can + # be sure that the superclass is + # not potentially creating an issues + # we don't know about + + $self->_check_metaclass_compatibility(); + $self->_superclasses_updated(); + } + + return @{$isa}; +} + +sub _superclasses_updated { + my $self = shift; + $self->update_meta_instance_dependencies(); + # keep strong references to all our parents, so they don't disappear if + # they are anon classes and don't have any direct instances + $self->_superclass_metas( + map { Class::MOP::class_of($_) } $self->superclasses + ); +} + +sub _superclass_metas { + my $self = shift; + $self->{_superclass_metas} = [@_]; +} + +sub subclasses { + my $self = shift; + my $super_class = $self->name; + + return @{ $super_class->mro::get_isarev() }; +} + +sub direct_subclasses { + my $self = shift; + my $super_class = $self->name; + + return grep { + grep { + $_ eq $super_class + } Class::MOP::Class->initialize($_)->superclasses + } $self->subclasses; +} + +sub linearized_isa { + return @{ mro::get_linear_isa( (shift)->name ) }; +} + +sub class_precedence_list { + my $self = shift; + my $name = $self->name; + + unless (Class::MOP::IS_RUNNING_ON_5_10()) { + # NOTE: + # We need to check for circular inheritance here + # if we are not on 5.10, cause 5.8 detects it late. + # This will do nothing if all is well, and blow up + # otherwise. Yes, it's an ugly hack, better + # suggestions are welcome. + # - SL + ($name || return)->isa('This is a test for circular inheritance') + } + + # if our mro is c3, we can + # just grab the linear_isa + if (mro::get_mro($name) eq 'c3') { + return @{ mro::get_linear_isa($name) } + } + else { + # NOTE: + # we can't grab the linear_isa for dfs + # since it has all the duplicates + # already removed. + return ( + $name, + map { + Class::MOP::Class->initialize($_)->class_precedence_list() + } $self->superclasses() + ); + } +} + +sub _method_lookup_order { + return (shift->linearized_isa, 'UNIVERSAL'); +} + +## Methods + +{ + my $fetch_and_prepare_method = sub { + my ($self, $method_name) = @_; + my $wrapped_metaclass = $self->wrapped_method_metaclass; + # fetch it locally + my $method = $self->get_method($method_name); + # if we don't have local ... + unless ($method) { + # try to find the next method + $method = $self->find_next_method_by_name($method_name); + # die if it does not exist + (defined $method) + || $self->_throw_exception( MethodNameNotFoundInInheritanceHierarchy => class_name => $self->name, + method_name => $method_name + ); + # and now make sure to wrap it + # even if it is already wrapped + # because we need a new sub ref + $method = $wrapped_metaclass->wrap($method, + package_name => $self->name, + name => $method_name, + ); + } + else { + # now make sure we wrap it properly + $method = $wrapped_metaclass->wrap($method, + package_name => $self->name, + name => $method_name, + ) unless $method->isa($wrapped_metaclass); + } + $self->add_method($method_name => $method); + return $method; + }; + + sub add_before_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name ); + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_before_modifier( + subname(':before' => $method_modifier) + ); + } + + sub add_after_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name ); + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_after_modifier( + subname(':after' => $method_modifier) + ); + } + + sub add_around_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodModifierNeedsMethodName => class_name => $self->name ); + my $method = $fetch_and_prepare_method->($self, $method_name); + $method->add_around_modifier( + subname(':around' => $method_modifier) + ); + } + + # NOTE: + # the methods above used to be named like this: + # ${pkg}::${method}:(before|after|around) + # but this proved problematic when using one modifier + # to wrap multiple methods (something which is likely + # to happen pretty regularly IMO). So instead of naming + # it like this, I have chosen to just name them purely + # with their modifier names, like so: + # :(before|after|around) + # The fact is that in a stack trace, it will be fairly + # evident from the context what method they are attached + # to, and so don't need the fully qualified name. +} + +sub find_method_by_name { + my ($self, $method_name) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name ); + foreach my $class ($self->_method_lookup_order) { + my $method = Class::MOP::Class->initialize($class)->get_method($method_name); + return $method if defined $method; + } + return; +} + +sub get_all_methods { + my $self = shift; + + my %methods; + for my $class ( reverse $self->_method_lookup_order ) { + my $meta = Class::MOP::Class->initialize($class); + + $methods{ $_->name } = $_ for $meta->_get_local_methods; + } + + return values %methods; +} + +sub get_all_method_names { + my $self = shift; + map { $_->name } $self->get_all_methods; +} + +sub find_all_methods_by_name { + my ($self, $method_name) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name ); + my @methods; + foreach my $class ($self->_method_lookup_order) { + # fetch the meta-class ... + my $meta = Class::MOP::Class->initialize($class); + push @methods => { + name => $method_name, + class => $class, + code => $meta->get_method($method_name) + } if $meta->has_method($method_name); + } + return @methods; +} + +sub find_next_method_by_name { + my ($self, $method_name) = @_; + (defined $method_name && length $method_name) + || $self->_throw_exception( MethodNameNotGiven => class_name => $self->name ); + my @cpl = ($self->_method_lookup_order); + shift @cpl; # discard ourselves + foreach my $class (@cpl) { + my $method = Class::MOP::Class->initialize($class)->get_method($method_name); + return $method if defined $method; + } + return; +} + +sub update_meta_instance_dependencies { + my $self = shift; + + if ( $self->{meta_instance_dependencies} ) { + return $self->add_meta_instance_dependencies; + } +} + +sub add_meta_instance_dependencies { + my $self = shift; + + $self->remove_meta_instance_dependencies; + + my @attrs = $self->get_all_attributes(); + + my %seen; + my @classes = grep { not $seen{ $_->name }++ } + map { $_->associated_class } @attrs; + + foreach my $class (@classes) { + $class->add_dependent_meta_instance($self); + } + + $self->{meta_instance_dependencies} = \@classes; +} + +sub remove_meta_instance_dependencies { + my $self = shift; + + if ( my $classes = delete $self->{meta_instance_dependencies} ) { + foreach my $class (@$classes) { + $class->remove_dependent_meta_instance($self); + } + + return $classes; + } + + return; + +} + +sub add_dependent_meta_instance { + my ( $self, $metaclass ) = @_; + push @{ $self->{dependent_meta_instances} }, $metaclass; +} + +sub remove_dependent_meta_instance { + my ( $self, $metaclass ) = @_; + my $name = $metaclass->name; + @$_ = grep { $_->name ne $name } @$_ + for $self->{dependent_meta_instances}; +} + +sub invalidate_meta_instances { + my $self = shift; + $_->invalidate_meta_instance() + for $self, @{ $self->{dependent_meta_instances} }; +} + +sub invalidate_meta_instance { + my $self = shift; + undef $self->{_meta_instance}; +} + +# check if we can reinitialize +sub is_pristine { + my $self = shift; + + # if any local attr is defined + return if $self->get_attribute_list; + + # or any non-declared methods + for my $method ( map { $self->get_method($_) } $self->get_method_list ) { + return if $method->isa("Class::MOP::Method::Generated"); + # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass ); + } + + return 1; +} + +## Class closing + +sub is_mutable { 1 } +sub is_immutable { 0 } + +sub immutable_options { %{ $_[0]{__immutable}{options} || {} } } + +sub _immutable_options { + my ( $self, @args ) = @_; + + return ( + inline_accessors => 1, + inline_constructor => 1, + inline_destructor => 0, + debug => 0, + immutable_trait => $self->immutable_trait, + constructor_name => $self->constructor_name, + constructor_class => $self->constructor_class, + destructor_class => $self->destructor_class, + @args, + ); +} + +sub make_immutable { + my ( $self, @args ) = @_; + + return $self unless $self->is_mutable; + + my ($file, $line) = (caller)[1..2]; + + $self->_initialize_immutable( + file => $file, + line => $line, + $self->_immutable_options(@args), + ); + $self->_rebless_as_immutable(@args); + + return $self; +} + +sub make_mutable { + my $self = shift; + + if ( $self->is_immutable ) { + my @args = $self->immutable_options; + $self->_rebless_as_mutable(); + $self->_remove_inlined_code(@args); + delete $self->{__immutable}; + return $self; + } + else { + return; + } +} + +sub _rebless_as_immutable { + my ( $self, @args ) = @_; + + $self->{__immutable}{original_class} = ref $self; + + bless $self => $self->_immutable_metaclass(@args); +} + +sub _immutable_metaclass { + my ( $self, %args ) = @_; + + if ( my $class = $args{immutable_metaclass} ) { + return $class; + } + + my $trait = $args{immutable_trait} = $self->immutable_trait + || $self->_throw_exception( NoImmutableTraitSpecifiedForClass => class_name => $self->name, + params => \%args + ); + + my $meta = $self->meta; + my $meta_attr = $meta->find_attribute_by_name("immutable_trait"); + + my $class_name; + + if ( $meta_attr and $trait eq $meta_attr->default ) { + # if the trait is the same as the default we try and pick a + # predictable name for the immutable metaclass + $class_name = 'Class::MOP::Class::Immutable::' . ref($self); + } + else { + $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait', + $trait, 'ForMetaClass', ref($self); + } + + return $class_name + if Class::MOP::does_metaclass_exist($class_name); + + # If the metaclass is a subclass of CMOP::Class which has had + # metaclass roles applied (via Moose), then we want to make sure + # that we preserve that anonymous class (see Fey::ORM for an + # example of where this matters). + my $meta_name = $meta->_real_ref_name; + + my $immutable_meta = $meta_name->create( + $class_name, + superclasses => [ ref $self ], + ); + + Class::MOP::MiniTrait::apply( $immutable_meta, $trait ); + + $immutable_meta->make_immutable( + inline_constructor => 0, + inline_accessors => 0, + ); + + return $class_name; +} + +sub _remove_inlined_code { + my $self = shift; + + $self->remove_method( $_->name ) for $self->_inlined_methods; + + delete $self->{__immutable}{inlined_methods}; +} + +sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } } + +sub _add_inlined_method { + my ( $self, $method ) = @_; + + push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method; +} + +sub _initialize_immutable { + my ( $self, %args ) = @_; + + $self->{__immutable}{options} = \%args; + $self->_install_inlined_code(%args); +} + +sub _install_inlined_code { + my ( $self, %args ) = @_; + + # FIXME + $self->_inline_accessors(%args) if $args{inline_accessors}; + $self->_inline_constructor(%args) if $args{inline_constructor}; + $self->_inline_destructor(%args) if $args{inline_destructor}; +} + +sub _rebless_as_mutable { + my $self = shift; + + bless $self, $self->_get_mutable_metaclass_name; + + return $self; +} + +sub _inline_accessors { + my $self = shift; + + foreach my $attr_name ( $self->get_attribute_list ) { + $self->get_attribute($attr_name)->install_accessors(1); + } +} + +sub _inline_constructor { + my ( $self, %args ) = @_; + + my $name = $args{constructor_name}; + # A class may not even have a constructor, and that's okay. + return unless defined $name; + + if ( $self->has_method($name) && !$args{replace_constructor} ) { + my $class = $self->name; + warn "Not inlining a constructor for $class since it defines" + . " its own constructor.\n" + . "If you are certain you don't need to inline your" + . " constructor, specify inline_constructor => 0 in your" + . " call to $class->meta->make_immutable\n"; + return; + } + + my $constructor_class = $args{constructor_class}; + + { + local $@; + use_package_optimistically($constructor_class); + } + + my $constructor = $constructor_class->new( + options => \%args, + metaclass => $self, + is_inline => 1, + package_name => $self->name, + name => $name, + definition_context => { + description => "constructor " . $self->name . "::" . $name, + file => $args{file}, + line => $args{line}, + }, + ); + + if ( $args{replace_constructor} or $constructor->can_be_inlined ) { + $self->add_method( $name => $constructor ); + $self->_add_inlined_method($constructor); + } +} + +sub _inline_destructor { + my ( $self, %args ) = @_; + + ( exists $args{destructor_class} && defined $args{destructor_class} ) + || $self->_throw_exception( NoDestructorClassSpecified => class_name => $self->name, + params => \%args, + ); + + if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) { + my $class = $self->name; + warn "Not inlining a destructor for $class since it defines" + . " its own destructor.\n"; + return; + } + + my $destructor_class = $args{destructor_class}; + + { + local $@; + use_package_optimistically($destructor_class); + } + + return unless $destructor_class->is_needed($self); + + my $destructor = $destructor_class->new( + options => \%args, + metaclass => $self, + package_name => $self->name, + name => 'DESTROY', + definition_context => { + description => "destructor " . $self->name . "::DESTROY", + file => $args{file}, + line => $args{line}, + }, + ); + + if ( $args{replace_destructor} or $destructor->can_be_inlined ) { + $self->add_method( 'DESTROY' => $destructor ); + $self->_add_inlined_method($destructor); + } +} + +1; + +# ABSTRACT: Class Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Class - Class Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + # assuming that class Foo + # has been defined, you can + + # use this for introspection ... + + # add a method to Foo ... + Foo->meta->add_method( 'bar' => sub {...} ) + + # get a list of all the classes searched + # the method dispatcher in the correct order + Foo->meta->class_precedence_list() + + # remove a method from Foo + Foo->meta->remove_method('bar'); + + # or use this to actually create classes ... + + Class::MOP::Class->create( + 'Bar' => ( + version => '0.01', + superclasses => ['Foo'], + attributes => [ + Class::MOP::Attribute->new('$bar'), + Class::MOP::Attribute->new('$baz'), + ], + methods => { + calculate_bar => sub {...}, + construct_baz => sub {...} + } + ) + ); + +=head1 DESCRIPTION + +The Class Protocol is the largest and most complex part of the +Class::MOP meta-object protocol. It controls the introspection and +manipulation of Perl 5 classes, and it can create them as well. The +best way to understand what this module can do is to read the +documentation for each of its methods. + +=head1 INHERITANCE + +C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>. + +=head1 METHODS + +=head2 Class construction + +These methods all create new C<Class::MOP::Class> objects. These +objects can represent existing classes or they can be used to create +new classes from scratch. + +The metaclass object for a given class is a singleton. If you attempt +to create a metaclass for the same class twice, you will just get the +existing object. + +=over 4 + +=item B<< Class::MOP::Class->create($package_name, %options) >> + +This method creates a new C<Class::MOP::Class> object with the given +package name. It accepts a number of options: + +=over 8 + +=item * version + +An optional version number for the newly created package. + +=item * authority + +An optional authority for the newly created package. +See L<Class::MOP::Module/authority> for more details. + +=item * superclasses + +An optional array reference of superclass names. + +=item * methods + +An optional hash reference of methods for the class. The keys of the +hash reference are method names and values are subroutine references. + +=item * attributes + +An optional array reference of L<Class::MOP::Attribute> objects. + +=item * meta_name + +Specifies the name to install the C<meta> method for this class under. +If it is not passed, C<meta> is assumed, and if C<undef> is explicitly +given, no meta method will be installed. + +=item * weaken + +If true, the metaclass that is stored in the global cache will be a +weak reference. + +Classes created in this way are destroyed once the metaclass they are +attached to goes out of scope, and will be removed from Perl's internal +symbol table. + +All instances of a class with a weakened metaclass keep a special +reference to the metaclass object, which prevents the metaclass from +going out of scope while any instances exist. + +This only works if the instance is based on a hash reference, however. + +=back + +=item B<< Class::MOP::Class->create_anon_class(%options) >> + +This method works just like C<< Class::MOP::Class->create >> but it +creates an "anonymous" class. In fact, the class does have a name, but +that name is a unique name generated internally by this module. + +It accepts the same C<superclasses>, C<methods>, and C<attributes> +parameters that C<create> accepts. + +It also accepts a C<cache> option. If this is C<true>, then the anonymous class +will be cached based on its superclasses and roles. If an existing anonymous +class in the cache has the same superclasses and roles, it will be reused. + +Anonymous classes default to C<< weaken => 1 >> if cache is C<false>, although +this can be overridden. + +=item B<< Class::MOP::Class->initialize($package_name, %options) >> + +This method will initialize a C<Class::MOP::Class> object for the +named package. Unlike C<create>, this method I<will not> create a new +class. + +The purpose of this method is to retrieve a C<Class::MOP::Class> +object for introspecting an existing class. + +If an existing C<Class::MOP::Class> object exists for the named +package, it will be returned, and any options provided will be +ignored! + +If the object does not yet exist, it will be created. + +The valid options that can be passed to this method are +C<attribute_metaclass>, C<method_metaclass>, +C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all +optional, and default to the appropriate class in the C<Class::MOP> +distribution. + +=back + +=head2 Object instance construction and cloning + +These methods are all related to creating and/or cloning object +instances. + +=over 4 + +=item B<< $metaclass->clone_object($instance, %params) >> + +This method clones an existing object instance. Any parameters you +provide are will override existing attribute values in the object. + +This is a convenience method for cloning an object instance, then +blessing it into the appropriate package. + +You could implement a clone method in your class, using this method: + + sub clone { + my ($self, %params) = @_; + $self->meta->clone_object($self, %params); + } + +=item B<< $metaclass->rebless_instance($instance, %params) >> + +This method changes the class of C<$instance> to the metaclass's class. + +You can only rebless an instance into a subclass of its current +class. If you pass any additional parameters, these will be treated +like constructor parameters and used to initialize the object's +attributes. Any existing attributes that are already set will be +overwritten. + +Before reblessing the instance, this method will call +C<rebless_instance_away> on the instance's current metaclass. This method +will be passed the instance, the new metaclass, and any parameters +specified to C<rebless_instance>. By default, C<rebless_instance_away> +does nothing; it is merely a hook. + +=item B<< $metaclass->rebless_instance_back($instance) >> + +Does the same thing as C<rebless_instance>, except that you can only +rebless an instance into one of its superclasses. Any attributes that +do not exist in the superclass will be deinitialized. + +This is a much more dangerous operation than C<rebless_instance>, +especially when multiple inheritance is involved, so use this carefully! + +=item B<< $metaclass->new_object(%params) >> + +This method is used to create a new object of the metaclass's +class. Any parameters you provide are used to initialize the +instance's attributes. A special C<__INSTANCE__> key can be passed to +provide an already generated instance, rather than having Class::MOP +generate it for you. This is mostly useful for using Class::MOP with +foreign classes which generate instances using their own constructors. + +=item B<< $metaclass->instance_metaclass >> + +Returns the class name of the instance metaclass. See +L<Class::MOP::Instance> for more information on the instance +metaclass. + +=item B<< $metaclass->get_meta_instance >> + +Returns an instance of the C<instance_metaclass> to be used in the +construction of a new instance of the class. + +=back + +=head2 Informational predicates + +These are a few predicate methods for asking information about the +class itself. + +=over 4 + +=item B<< $metaclass->is_anon_class >> + +This returns true if the class was created by calling C<< +Class::MOP::Class->create_anon_class >>. + +=item B<< $metaclass->is_mutable >> + +This returns true if the class is still mutable. + +=item B<< $metaclass->is_immutable >> + +This returns true if the class has been made immutable. + +=item B<< $metaclass->is_pristine >> + +A class is I<not> pristine if it has non-inherited attributes or if it +has any generated methods. + +=back + +=head2 Inheritance Relationships + +=over 4 + +=item B<< $metaclass->superclasses(@superclasses) >> + +This is a read-write accessor which represents the superclass +relationships of the metaclass's class. + +This is basically sugar around getting and setting C<@ISA>. + +=item B<< $metaclass->class_precedence_list >> + +This returns a list of all of the class's ancestor classes. The +classes are returned in method dispatch order. + +=item B<< $metaclass->linearized_isa >> + +This returns a list based on C<class_precedence_list> but with all +duplicates removed. + +=item B<< $metaclass->subclasses >> + +This returns a list of all subclasses for this class, even indirect +subclasses. + +=item B<< $metaclass->direct_subclasses >> + +This returns a list of immediate subclasses for this class, which does not +include indirect subclasses. + +=back + +=head2 Method introspection and creation + +These methods allow you to introspect a class's methods, as well as +add, remove, or change methods. + +Determining what is truly a method in a Perl 5 class requires some +heuristics (aka guessing). + +Methods defined outside the package with a fully qualified name (C<sub +Package::name { ... }>) will be included. Similarly, methods named +with a fully qualified name using L<Sub::Name> are also included. + +However, we attempt to ignore imported functions. + +Ultimately, we are using heuristics to determine what truly is a +method in a class, and these heuristics may get the wrong answer in +some edge cases. However, for most "normal" cases the heuristics work +correctly. + +=over 4 + +=item B<< $metaclass->get_method($method_name) >> + +This will return a L<Class::MOP::Method> for the specified +C<$method_name>. If the class does not have the specified method, it +returns C<undef> + +=item B<< $metaclass->has_method($method_name) >> + +Returns a boolean indicating whether or not the class defines the +named method. It does not include methods inherited from parent +classes. + +=item B<< $metaclass->get_method_list >> + +This will return a list of method I<names> for all methods defined in +this class. + +=item B<< $metaclass->add_method($method_name, $method) >> + +This method takes a method name and a subroutine reference, and adds +the method to the class. + +The subroutine reference can be a L<Class::MOP::Method>, and you are +strongly encouraged to pass a meta method object instead of a code +reference. If you do so, that object gets stored as part of the +class's method map directly. If not, the meta information will have to +be recreated later, and may be incorrect. + +If you provide a method object, this method will clone that object if +the object's package name does not match the class name. This lets us +track the original source of any methods added from other classes +(notably Moose roles). + +=item B<< $metaclass->remove_method($method_name) >> + +Remove the named method from the class. This method returns the +L<Class::MOP::Method> object for the method. + +=item B<< $metaclass->method_metaclass >> + +Returns the class name of the method metaclass, see +L<Class::MOP::Method> for more information on the method metaclass. + +=item B<< $metaclass->wrapped_method_metaclass >> + +Returns the class name of the wrapped method metaclass, see +L<Class::MOP::Method::Wrapped> for more information on the wrapped +method metaclass. + +=item B<< $metaclass->get_all_methods >> + +This will traverse the inheritance hierarchy and return a list of all +the L<Class::MOP::Method> objects for this class and its parents. + +=item B<< $metaclass->find_method_by_name($method_name) >> + +This will return a L<Class::MOP::Method> for the specified +C<$method_name>. If the class does not have the specified method, it +returns C<undef> + +Unlike C<get_method>, this method I<will> look for the named method in +superclasses. + +=item B<< $metaclass->get_all_method_names >> + +This will return a list of method I<names> for all of this class's +methods, including inherited methods. + +=item B<< $metaclass->find_all_methods_by_name($method_name) >> + +This method looks for the named method in the class and all of its +parents. It returns every matching method it finds in the inheritance +tree, so it returns a list of methods. + +Each method is returned as a hash reference with three keys. The keys +are C<name>, C<class>, and C<code>. The C<code> key has a +L<Class::MOP::Method> object as its value. + +The list of methods is distinct. + +=item B<< $metaclass->find_next_method_by_name($method_name) >> + +This method returns the first method in any superclass matching the +given name. It is effectively the method that C<SUPER::$method_name> +would dispatch to. + +=back + +=head2 Attribute introspection and creation + +Because Perl 5 does not have a core concept of attributes in classes, +we can only return information about attributes which have been added +via this class's methods. We cannot discover information about +attributes which are defined in terms of "regular" Perl 5 methods. + +=over 4 + +=item B<< $metaclass->get_attribute($attribute_name) >> + +This will return a L<Class::MOP::Attribute> for the specified +C<$attribute_name>. If the class does not have the specified +attribute, it returns C<undef>. + +NOTE that get_attribute does not search superclasses, for that you +need to use C<find_attribute_by_name>. + +=item B<< $metaclass->has_attribute($attribute_name) >> + +Returns a boolean indicating whether or not the class defines the +named attribute. It does not include attributes inherited from parent +classes. + +=item B<< $metaclass->get_attribute_list >> + +This will return a list of attributes I<names> for all attributes +defined in this class. Note that this operates on the current class +only, it does not traverse the inheritance hierarchy. + +=item B<< $metaclass->get_all_attributes >> + +This will traverse the inheritance hierarchy and return a list of all +the L<Class::MOP::Attribute> objects for this class and its parents. + +=item B<< $metaclass->find_attribute_by_name($attribute_name) >> + +This will return a L<Class::MOP::Attribute> for the specified +C<$attribute_name>. If the class does not have the specified +attribute, it returns C<undef>. + +Unlike C<get_attribute>, this attribute I<will> look for the named +attribute in superclasses. + +=item B<< $metaclass->add_attribute(...) >> + +This method accepts either an existing L<Class::MOP::Attribute> +object or parameters suitable for passing to that class's C<new> +method. + +The attribute provided will be added to the class. + +Any accessor methods defined by the attribute will be added to the +class when the attribute is added. + +If an attribute of the same name already exists, the old attribute +will be removed first. + +=item B<< $metaclass->remove_attribute($attribute_name) >> + +This will remove the named attribute from the class, and +L<Class::MOP::Attribute> object. + +Removing an attribute also removes any accessor methods defined by the +attribute. + +However, note that removing an attribute will only affect I<future> +object instances created for this class, not existing instances. + +=item B<< $metaclass->attribute_metaclass >> + +Returns the class name of the attribute metaclass for this class. By +default, this is L<Class::MOP::Attribute>. + +=back + +=head2 Overload introspection and creation + +These methods provide an API to the core L<overload> functionality. + +=over 4 + +=item B<< $metaclass->is_overloaded >> + +Returns true if overloading is enabled for this class. Corresponds to +L<overload::Overloaded|overload/Public Functions>. + +=item B<< $metaclass->get_overloaded_operator($op) >> + +Returns the L<Class::MOP::Overload> object corresponding to the operator named +C<$op>, if one exists for this class. + +=item B<< $metaclass->has_overloaded_operator($op) >> + +Returns whether or not the operator C<$op> is overloaded for this class. + +=item B<< $metaclass->get_overload_list >> + +Returns a list of operator names which have been overloaded (see +L<overload/Overloadable Operations> for the list of valid operator names). + +=item B<< $metaclass->get_all_overloaded_operators >> + +Returns a list of L<Class::MOP::Overload> objects corresponding to the +operators that have been overloaded. + +=item B<< $metaclass->add_overloaded_operator($op, $impl) >> + +Overloads the operator C<$op> for this class. The C<$impl> can be a coderef, a +method name, or a L<Class::MOP::Overload> object. Corresponds to +C<< use overload $op => $impl; >> + +=item B<< $metaclass->remove_overloaded_operator($op) >> + +Remove overloading for operator C<$op>. Corresponds to C<< no overload $op; >> + +=item B<< $metaclass->get_overload_fallback_value >> + +Returns the overload C<fallback> setting for the package. + +=item B<< $metaclass->set_overload_fallback_value($fallback) >> + +Sets the overload C<fallback> setting for the package. + +=back + +=head2 Class Immutability + +Making a class immutable "freezes" the class definition. You can no +longer call methods which alter the class, such as adding or removing +methods or attributes. + +Making a class immutable lets us optimize the class by inlining some +methods, and also allows us to optimize some methods on the metaclass +object itself. + +After immutabilization, the metaclass object will cache most informational +methods that returns information about methods or attributes. Methods which +would alter the class, such as C<add_attribute> and C<add_method>, will +throw an error on an immutable metaclass object. + +The immutabilization system in L<Moose> takes much greater advantage +of the inlining features than Class::MOP itself does. + +=over 4 + +=item B<< $metaclass->make_immutable(%options) >> + +This method will create an immutable transformer and use it to make +the class and its metaclass object immutable, and returns true +(you should not rely on the details of this value apart from its truth). + +This method accepts the following options: + +=over 8 + +=item * inline_accessors + +=item * inline_constructor + +=item * inline_destructor + +These are all booleans indicating whether the specified method(s) +should be inlined. + +By default, accessors and the constructor are inlined, but not the +destructor. + +=item * immutable_trait + +The name of a class which will be used as a parent class for the +metaclass object being made immutable. This "trait" implements the +post-immutability functionality of the metaclass (but not the +transformation itself). + +This defaults to L<Class::MOP::Class::Immutable::Trait>. + +=item * constructor_name + +This is the constructor method name. This defaults to "new". + +=item * constructor_class + +The name of the method metaclass for constructors. It will be used to +generate the inlined constructor. This defaults to +"Class::MOP::Method::Constructor". + +=item * replace_constructor + +This is a boolean indicating whether an existing constructor should be +replaced when inlining a constructor. This defaults to false. + +=item * destructor_class + +The name of the method metaclass for destructors. It will be used to +generate the inlined destructor. This defaults to +"Class::MOP::Method::Denstructor". + +=item * replace_destructor + +This is a boolean indicating whether an existing destructor should be +replaced when inlining a destructor. This defaults to false. + +=back + +=item B<< $metaclass->immutable_options >> + +Returns a hash of the options used when making the class immutable, including +both defaults and anything supplied by the user in the call to C<< +$metaclass->make_immutable >>. This is useful if you need to temporarily make +a class mutable and then restore immutability as it was before. + +=item B<< $metaclass->make_mutable >> + +Calling this method reverse the immutabilization transformation. + +=back + +=head2 Method Modifiers + +Method modifiers are hooks which allow a method to be wrapped with +I<before>, I<after> and I<around> method modifiers. Every time a +method is called, its modifiers are also called. + +A class can modify its own methods, as well as methods defined in +parent classes. + +=head3 How method modifiers work? + +Method modifiers work by wrapping the original method and then +replacing it in the class's symbol table. The wrappers will handle +calling all the modifiers in the appropriate order and preserving the +calling context for the original method. + +The return values of C<before> and C<after> modifiers are +ignored. This is because their purpose is B<not> to filter the input +and output of the primary method (this is done with an I<around> +modifier). + +This may seem like an odd restriction to some, but doing this allows +for simple code to be added at the beginning or end of a method call +without altering the function of the wrapped method or placing any +extra responsibility on the code of the modifier. + +Of course if you have more complex needs, you can use the C<around> +modifier which allows you to change both the parameters passed to the +wrapped method, as well as its return value. + +Before and around modifiers are called in last-defined-first-called +order, while after modifiers are called in first-defined-first-called +order. So the call tree might looks something like this: + + before 2 + before 1 + around 2 + around 1 + primary + around 1 + around 2 + after 1 + after 2 + +=head3 What is the performance impact? + +Of course there is a performance cost associated with method +modifiers, but we have made every effort to make that cost directly +proportional to the number of modifier features you use. + +The wrapping method does its best to B<only> do as much work as it +absolutely needs to. In order to do this we have moved some of the +performance costs to set-up time, where they are easier to amortize. + +All this said, our benchmarks have indicated the following: + + simple wrapper with no modifiers 100% slower + simple wrapper with simple before modifier 400% slower + simple wrapper with simple after modifier 450% slower + simple wrapper with simple around modifier 500-550% slower + simple wrapper with all 3 modifiers 1100% slower + +These numbers may seem daunting, but you must remember, every feature +comes with some cost. To put things in perspective, just doing a +simple C<AUTOLOAD> which does nothing but extract the name of the +method called and return it costs about 400% over a normal method +call. + +=over 4 + +=item B<< $metaclass->add_before_method_modifier($method_name, $code) >> + +This wraps the specified method with the supplied subroutine +reference. The modifier will be called as a method itself, and will +receive the same arguments as are passed to the method. + +When the modifier exits, the wrapped method will be called. + +The return value of the modifier will be ignored. + +=item B<< $metaclass->add_after_method_modifier($method_name, $code) >> + +This wraps the specified method with the supplied subroutine +reference. The modifier will be called as a method itself, and will +receive the same arguments as are passed to the method. + +When the wrapped methods exits, the modifier will be called. + +The return value of the modifier will be ignored. + +=item B<< $metaclass->add_around_method_modifier($method_name, $code) >> + +This wraps the specified method with the supplied subroutine +reference. + +The first argument passed to the modifier will be a subroutine +reference to the wrapped method. The second argument is the object, +and after that come any arguments passed when the method is called. + +The around modifier can choose to call the original method, as well as +what arguments to pass if it does so. + +The return value of the modifier is what will be seen by the caller. + +=back + +=head2 Introspection + +=over 4 + +=item B<< Class::MOP::Class->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +It should also be noted that L<Class::MOP> will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Class/Immutable/Trait.pm b/lib/Class/MOP/Class/Immutable/Trait.pm new file mode 100644 index 0000000..8bb6c93 --- /dev/null +++ b/lib/Class/MOP/Class/Immutable/Trait.pm @@ -0,0 +1,172 @@ +package Class::MOP::Class::Immutable::Trait; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use MRO::Compat; +use Module::Runtime 'use_module'; + +# the original class of the metaclass instance +sub _get_mutable_metaclass_name { $_[0]{__immutable}{original_class} } + +sub is_mutable { 0 } +sub is_immutable { 1 } + +sub _immutable_metaclass { ref $_[1] } + +sub _immutable_read_only { + my $name = shift; + __throw_exception( CallingReadOnlyMethodOnAnImmutableInstance => method_name => $name ); +} + +sub _immutable_cannot_call { + my $name = shift; + __throw_exception( CallingMethodOnAnImmutableInstance => method_name => $name ); +} + +for my $name (qw/superclasses/) { + no strict 'refs'; + *{__PACKAGE__."::$name"} = sub { + my $orig = shift; + my $self = shift; + _immutable_read_only($name) if @_; + $self->$orig; + }; +} + +for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol add_package_symbol/) { + no strict 'refs'; + *{__PACKAGE__."::$name"} = sub { _immutable_cannot_call($name) }; +} + +sub class_precedence_list { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{class_precedence_list} + ||= [ $self->$orig ] }; +} + +sub linearized_isa { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] }; +} + +sub get_all_methods { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] }; +} + +sub get_all_method_names { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] }; +} + +sub get_all_attributes { + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] }; +} + +sub get_meta_instance { + my $orig = shift; + my $self = shift; + $self->{__immutable}{get_meta_instance} ||= $self->$orig; +} + +sub _method_map { + my $orig = shift; + my $self = shift; + $self->{__immutable}{_method_map} ||= $self->$orig; +} + +# private method, for this file only - +# if we declare a method here, it will behave differently depending on what +# class this trait is applied to, so we won't have a reliable parameter list. +sub __throw_exception { + my ($exception_type, @args_to_exception) = @_; + die use_module( "Moose::Exception::$exception_type" )->new( @args_to_exception ); +} + +1; + +# ABSTRACT: Implements immutability for metaclass objects + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Class::Immutable::Trait - Implements immutability for metaclass objects + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class provides a pseudo-trait that is applied to immutable metaclass +objects. In reality, it is simply a parent class. + +It implements caching and read-only-ness for various metaclass methods. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Deprecated.pm b/lib/Class/MOP/Deprecated.pm new file mode 100644 index 0000000..cb9329a --- /dev/null +++ b/lib/Class/MOP/Deprecated.pm @@ -0,0 +1,95 @@ +package Class::MOP::Deprecated; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Package::DeprecationManager -deprecations => { + 'Class::Load wrapper functions' => '2.1100', +}; + +1; + +# ABSTRACT: Manages deprecation warnings for Class::MOP + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Deprecated - Manages deprecation warnings for Class::MOP + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + + use Class::MOP::Deprecated -api_version => $version; + +=head1 FUNCTIONS + +This module manages deprecation warnings for features that have been +deprecated in Class::MOP. + +If you specify C<< -api_version => $version >>, you can use deprecated features +without warnings. Note that this special treatment is limited to the package +that loads C<Class::MOP::Deprecated>. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm new file mode 100644 index 0000000..3cffb4e --- /dev/null +++ b/lib/Class/MOP/Instance.pm @@ -0,0 +1,533 @@ +package Class::MOP::Instance; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'isweak', 'weaken', 'blessed'; + +use parent 'Class::MOP::Object'; + +# make this not a valid method name, to avoid (most) attribute conflicts +my $RESERVED_MOP_SLOT = '<<MOP>>'; + +sub BUILDARGS { + my ($class, @args) = @_; + + if ( @args == 1 ) { + unshift @args, "associated_metaclass"; + } elsif ( @args >= 2 && blessed($args[0]) && $args[0]->isa("Class::MOP::Class") ) { + # compat mode + my ( $meta, @attrs ) = @args; + @args = ( associated_metaclass => $meta, attributes => \@attrs ); + } + + my %options = @args; + # FIXME lazy_build + $options{slots} ||= [ map { $_->slots } @{ $options{attributes} || [] } ]; + $options{slot_hash} = { map { $_ => undef } @{ $options{slots} } }; # FIXME lazy_build + + return \%options; +} + +sub new { + my $class = shift; + my $options = $class->BUILDARGS(@_); + + # FIXME replace with a proper constructor + my $instance = $class->_new(%$options); + + # FIXME weak_ref => 1, + weaken($instance->{'associated_metaclass'}); + + return $instance; +} + +sub _new { + my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + return bless { + # NOTE: + # I am not sure that it makes + # sense to pass in the meta + # The ideal would be to just + # pass in the class name, but + # that is placing too much of + # an assumption on bless(), + # which is *probably* a safe + # assumption,.. but you can + # never tell <:) + 'associated_metaclass' => $params->{associated_metaclass}, + 'attributes' => $params->{attributes}, + 'slots' => $params->{slots}, + 'slot_hash' => $params->{slot_hash}, + } => $class; +} + +sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name } + +sub create_instance { + my $self = shift; + bless {}, $self->_class_name; +} + +sub clone_instance { + my ($self, $instance) = @_; + + my $clone = $self->create_instance; + for my $attr ($self->get_all_attributes) { + next unless $attr->has_value($instance); + for my $slot ($attr->slots) { + my $val = $self->get_slot_value($instance, $slot); + $self->set_slot_value($clone, $slot, $val); + $self->weaken_slot_value($clone, $slot) + if $self->slot_value_is_weak($instance, $slot); + } + } + + $self->_set_mop_slot($clone, $self->_get_mop_slot($instance)) + if $self->_has_mop_slot($instance); + + return $clone; +} + +# operations on meta instance + +sub get_all_slots { + my $self = shift; + return @{$self->{'slots'}}; +} + +sub get_all_attributes { + my $self = shift; + return @{$self->{attributes}}; +} + +sub is_valid_slot { + my ($self, $slot_name) = @_; + exists $self->{'slot_hash'}->{$slot_name}; +} + +# operations on created instances + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + $instance->{$slot_name}; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $instance->{$slot_name} = $value; +} + +sub initialize_slot { + my ($self, $instance, $slot_name) = @_; + return; +} + +sub deinitialize_slot { + my ( $self, $instance, $slot_name ) = @_; + delete $instance->{$slot_name}; +} + +sub initialize_all_slots { + my ($self, $instance) = @_; + foreach my $slot_name ($self->get_all_slots) { + $self->initialize_slot($instance, $slot_name); + } +} + +sub deinitialize_all_slots { + my ($self, $instance) = @_; + foreach my $slot_name ($self->get_all_slots) { + $self->deinitialize_slot($instance, $slot_name); + } +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name, $value) = @_; + exists $instance->{$slot_name}; +} + +sub weaken_slot_value { + my ($self, $instance, $slot_name) = @_; + weaken $instance->{$slot_name}; +} + +sub slot_value_is_weak { + my ($self, $instance, $slot_name) = @_; + isweak $instance->{$slot_name}; +} + +sub strengthen_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name)); +} + +sub rebless_instance_structure { + my ($self, $instance, $metaclass) = @_; + + # we use $_[1] here because of t/cmop/rebless_overload.t regressions + # on 5.8.8 + bless $_[1], $metaclass->name; +} + +sub is_dependent_on_superclasses { + return; # for meta instances that require updates on inherited slot changes +} + +sub _get_mop_slot { + my ($self, $instance) = @_; + $self->get_slot_value($instance, $RESERVED_MOP_SLOT); +} + +sub _has_mop_slot { + my ($self, $instance) = @_; + $self->is_slot_initialized($instance, $RESERVED_MOP_SLOT); +} + +sub _set_mop_slot { + my ($self, $instance, $value) = @_; + $self->set_slot_value($instance, $RESERVED_MOP_SLOT, $value); +} + +sub _clear_mop_slot { + my ($self, $instance) = @_; + $self->deinitialize_slot($instance, $RESERVED_MOP_SLOT); +} + +# inlinable operation snippets + +sub is_inlinable { 1 } + +sub inline_create_instance { + my ($self, $class_variable) = @_; + 'bless {} => ' . $class_variable; +} + +sub inline_slot_access { + my ($self, $instance, $slot_name) = @_; + sprintf q[%s->{"%s"}], $instance, quotemeta($slot_name); +} + +sub inline_get_is_lvalue { 1 } + +sub inline_get_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->inline_slot_access($instance, $slot_name); +} + +sub inline_set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + $self->inline_slot_access($instance, $slot_name) . " = $value", +} + +sub inline_initialize_slot { + my ($self, $instance, $slot_name) = @_; + return ''; +} + +sub inline_deinitialize_slot { + my ($self, $instance, $slot_name) = @_; + "delete " . $self->inline_slot_access($instance, $slot_name); +} +sub inline_is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + "exists " . $self->inline_slot_access($instance, $slot_name); +} + +sub inline_weaken_slot_value { + my ($self, $instance, $slot_name) = @_; + sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name); +} + +sub inline_strengthen_slot_value { + my ($self, $instance, $slot_name) = @_; + $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name)); +} + +sub inline_rebless_instance_structure { + my ($self, $instance, $class_variable) = @_; + "bless $instance => $class_variable"; +} + +sub _inline_get_mop_slot { + my ($self, $instance) = @_; + $self->inline_get_slot_value($instance, $RESERVED_MOP_SLOT); +} + +sub _inline_set_mop_slot { + my ($self, $instance, $value) = @_; + $self->inline_set_slot_value($instance, $RESERVED_MOP_SLOT, $value); +} + +sub _inline_clear_mop_slot { + my ($self, $instance) = @_; + $self->inline_deinitialize_slot($instance, $RESERVED_MOP_SLOT); +} + +1; + +# ABSTRACT: Instance Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Instance - Instance Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +The Instance Protocol controls the creation of object instances, and +the storage of attribute values in those instances. + +Using this API directly in your own code violates encapsulation, and +we recommend that you use the appropriate APIs in L<Class::MOP::Class> +and L<Class::MOP::Attribute> instead. Those APIs in turn call the +methods in this class as appropriate. + +This class also participates in generating inlined code by providing +snippets of code to access an object instance. + +=head1 METHODS + +=head2 Object construction + +=over 4 + +=item B<< Class::MOP::Instance->new(%options) >> + +This method creates a new meta-instance object. + +It accepts the following keys in C<%options>: + +=over 8 + +=item * associated_metaclass + +The L<Class::MOP::Class> object for which instances will be created. + +=item * attributes + +An array reference of L<Class::MOP::Attribute> objects. These are the +attributes which can be stored in each instance. + +=back + +=back + +=head2 Creating and altering instances + +=over 4 + +=item B<< $metainstance->create_instance >> + +This method returns a reference blessed into the associated +metaclass's class. + +The default is to use a hash reference. Subclasses can override this. + +=item B<< $metainstance->clone_instance($instance) >> + +Given an instance, this method creates a new object by making +I<shallow> clone of the original. + +=back + +=head2 Introspection + +=over 4 + +=item B<< $metainstance->associated_metaclass >> + +This returns the L<Class::MOP::Class> object associated with the +meta-instance object. + +=item B<< $metainstance->get_all_slots >> + +This returns a list of slot names stored in object instances. In +almost all cases, slot names correspond directly attribute names. + +=item B<< $metainstance->is_valid_slot($slot_name) >> + +This will return true if C<$slot_name> is a valid slot name. + +=item B<< $metainstance->get_all_attributes >> + +This returns a list of attributes corresponding to the attributes +passed to the constructor. + +=back + +=head2 Operations on Instance Structures + +It's important to understand that the meta-instance object is a +different entity from the actual instances it creates. For this +reason, any operations on the C<$instance_structure> always require +that the object instance be passed to the method. + +=over 4 + +=item B<< $metainstance->get_slot_value($instance_structure, $slot_name) >> + +=item B<< $metainstance->set_slot_value($instance_structure, $slot_name, $value) >> + +=item B<< $metainstance->initialize_slot($instance_structure, $slot_name) >> + +=item B<< $metainstance->deinitialize_slot($instance_structure, $slot_name) >> + +=item B<< $metainstance->initialize_all_slots($instance_structure) >> + +=item B<< $metainstance->deinitialize_all_slots($instance_structure) >> + +=item B<< $metainstance->is_slot_initialized($instance_structure, $slot_name) >> + +=item B<< $metainstance->weaken_slot_value($instance_structure, $slot_name) >> + +=item B<< $metainstance->slot_value_is_weak($instance_structure, $slot_name) >> + +=item B<< $metainstance->strengthen_slot_value($instance_structure, $slot_name) >> + +=item B<< $metainstance->rebless_instance_structure($instance_structure, $new_metaclass) >> + +The exact details of what each method does should be fairly obvious +from the method name. + +=back + +=head2 Inlinable Instance Operations + +=over 4 + +=item B<< $metainstance->is_inlinable >> + +This is a boolean that indicates whether or not slot access operations +can be inlined. By default it is true, but subclasses can override +this. + +=item B<< $metainstance->inline_create_instance($class_variable) >> + +This method expects a string that, I<when inlined>, will become a +class name. This would literally be something like C<'$class'>, not an +actual class name. + +It returns a snippet of code that creates a new object for the +class. This is something like C< bless {}, $class_name >. + +=item B<< $metainstance->inline_get_is_lvalue >> + +Returns whether or not C<inline_get_slot_value> is a valid lvalue. This can be +used to do extra optimizations when generating inlined methods. + +=item B<< $metainstance->inline_slot_access($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_get_slot_value($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_set_slot_value($instance_variable, $slot_name, $value) >> + +=item B<< $metainstance->inline_initialize_slot($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_deinitialize_slot($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_is_slot_initialized($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_weaken_slot_value($instance_variable, $slot_name) >> + +=item B<< $metainstance->inline_strengthen_slot_value($instance_variable, $slot_name) >> + +These methods all expect two arguments. The first is the name of a +variable, than when inlined, will represent the object +instance. Typically this will be a literal string like C<'$_[0]'>. + +The second argument is a slot name. + +The method returns a snippet of code that, when inlined, performs some +operation on the instance. + +=item B<< $metainstance->inline_rebless_instance_structure($instance_variable, $class_variable) >> + +This takes the name of a variable that will, when inlined, represent the object +instance, and the name of a variable that will represent the class to rebless +into, and returns code to rebless an instance into a class. + +=back + +=head2 Introspection + +=over 4 + +=item B<< Class::MOP::Instance->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +It should also be noted that L<Class::MOP> will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm new file mode 100644 index 0000000..d945bcb --- /dev/null +++ b/lib/Class/MOP/Method.pm @@ -0,0 +1,343 @@ +package Class::MOP::Method; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'weaken', 'reftype', 'blessed'; + +use parent 'Class::MOP::Object'; + +# NOTE: +# if poked in the right way, +# they should act like CODE refs. +use overload '&{}' => sub { $_[0]->body }, fallback => 1; + +# construction + +sub wrap { + my ( $class, @args ) = @_; + + unshift @args, 'body' if @args % 2 == 1; + + my %params = @args; + my $code = $params{body}; + + if (blessed($code) && $code->isa(__PACKAGE__)) { + my $method = $code->clone; + delete $params{body}; + Class::MOP::class_of($class)->rebless_instance($method, %params); + return $method; + } + elsif (!ref $code || 'CODE' ne reftype($code)) { + $class->_throw_exception( WrapTakesACodeRefToBless => params => \%params, + class => $class, + code => $code + ); + } + + ($params{package_name} && $params{name}) + || $class->_throw_exception( PackageNameAndNameParamsNotGivenToWrap => params => \%params, + class => $class, + code => $code + ); + + my $self = $class->_new(\%params); + + weaken($self->{associated_metaclass}) if $self->{associated_metaclass}; + + return $self; +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + 'body' => $params->{body}, + 'associated_metaclass' => $params->{associated_metaclass}, + 'package_name' => $params->{package_name}, + 'name' => $params->{name}, + 'original_method' => $params->{original_method}, + } => $class; +} + +## accessors + +sub associated_metaclass { shift->{'associated_metaclass'} } + +sub attach_to_class { + my ( $self, $class ) = @_; + $self->{associated_metaclass} = $class; + weaken($self->{associated_metaclass}); +} + +sub detach_from_class { + my $self = shift; + delete $self->{associated_metaclass}; +} + +sub fully_qualified_name { + my $self = shift; + $self->package_name . '::' . $self->name; +} + +sub original_method { (shift)->{'original_method'} } + +sub _set_original_method { $_[0]->{'original_method'} = $_[1] } + +# It's possible that this could cause a loop if there is a circular +# reference in here. That shouldn't ever happen in normal +# circumstances, since original method only gets set when clone is +# called. We _could_ check for such a loop, but it'd involve some sort +# of package-lexical variable, and wouldn't be terribly subclassable. +sub original_package_name { + my $self = shift; + + $self->original_method + ? $self->original_method->original_package_name + : $self->package_name; +} + +sub original_name { + my $self = shift; + + $self->original_method + ? $self->original_method->original_name + : $self->name; +} + +sub original_fully_qualified_name { + my $self = shift; + + $self->original_method + ? $self->original_method->original_fully_qualified_name + : $self->fully_qualified_name; +} + +sub execute { + my $self = shift; + $self->body->(@_); +} + +# We used to go through use Class::MOP::Class->clone_instance to do this, but +# this was awfully slow. This method may be called a number of times when +# classes are loaded (especially during Moose role application), so it is +# worth optimizing. - DR +sub clone { + my $self = shift; + + my $clone = bless { %{$self}, @_ }, blessed($self); + weaken($clone->{associated_metaclass}) if $clone->{associated_metaclass}; + + $clone->_set_original_method($self); + + return $clone; +} + +1; + +# ABSTRACT: Method Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method - Method Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +The Method Protocol is very small, since methods in Perl 5 are just +subroutines in a specific package. We provide a very basic +introspection interface. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method->wrap($code, %options) >> + +This is the constructor. It accepts a method body in the form of +either a code reference or a L<Class::MOP::Method> instance, followed +by a hash of options. + +The options are: + +=over 8 + +=item * name + +The method name (without a package name). This is required if C<$code> +is a coderef. + +=item * package_name + +The package name for the method. This is required if C<$code> is a +coderef. + +=item * associated_metaclass + +An optional L<Class::MOP::Class> object. This is the metaclass for the +method's class. + +=back + +=item B<< $metamethod->clone(%params) >> + +This makes a shallow clone of the method object. In particular, +subroutine reference itself is shared between all clones of a given +method. + +When a method is cloned, the original method object will be available +by calling C<original_method> on the clone. + +=item B<< $metamethod->body >> + +This returns a reference to the method's subroutine. + +=item B<< $metamethod->name >> + +This returns the method's name. + +=item B<< $metamethod->package_name >> + +This returns the method's package name. + +=item B<< $metamethod->fully_qualified_name >> + +This returns the method's fully qualified name (package name and +method name). + +=item B<< $metamethod->associated_metaclass >> + +This returns the L<Class::MOP::Class> object for the method, if one +exists. + +=item B<< $metamethod->original_method >> + +If this method object was created as a clone of some other method +object, this returns the object that was cloned. + +=item B<< $metamethod->original_name >> + +This returns the method's original name, wherever it was first +defined. + +If this method is a clone of a clone (of a clone, etc.), this method +returns the name from the I<first> method in the chain of clones. + +=item B<< $metamethod->original_package_name >> + +This returns the method's original package name, wherever it was first +defined. + +If this method is a clone of a clone (of a clone, etc.), this method +returns the package name from the I<first> method in the chain of +clones. + +=item B<< $metamethod->original_fully_qualified_name >> + +This returns the method's original fully qualified name, wherever it +was first defined. + +If this method is a clone of a clone (of a clone, etc.), this method +returns the fully qualified name from the I<first> method in the chain +of clones. + +=item B<< $metamethod->is_stub >> + +Returns true if the method is just a stub: + + sub foo; + +=item B<< $metamethod->attach_to_class($metaclass) >> + +Given a L<Class::MOP::Class> object, this method sets the associated +metaclass for the method. This will overwrite any existing associated +metaclass. + +=item B<< $metamethod->detach_from_class >> + +Removes any associated metaclass object for the method. + +=item B<< $metamethod->execute(...) >> + +This executes the method. Any arguments provided will be passed on to +the method itself. + +=item B<< Class::MOP::Method->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +It should also be noted that L<Class::MOP> will actually bootstrap +this module by installing a number of attribute meta-objects into its +metaclass. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm new file mode 100644 index 0000000..673bfde --- /dev/null +++ b/lib/Class/MOP/Method/Accessor.pm @@ -0,0 +1,409 @@ +package Class::MOP::Method::Accessor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; + +use parent 'Class::MOP::Method::Generated'; + +sub new { + my $class = shift; + my %options = @_; + + (exists $options{attribute}) + || $class->_throw_exception( MustSupplyAnAttributeToConstructWith => params => \%options, + class => $class, + ); + + (exists $options{accessor_type}) + || $class->_throw_exception( MustSupplyAnAccessorTypeToConstructWith => params => \%options, + class => $class, + ); + + (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) + || $class->_throw_exception( MustSupplyAClassMOPAttributeInstance => params => \%options, + class => $class + ); + + ($options{package_name} && $options{name}) + || $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + my $self = $class->_new(\%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'attribute'}); + + $self->_initialize_body; + + return $self; +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + body => $params->{body}, + associated_metaclass => $params->{associated_metaclass}, + package_name => $params->{package_name}, + name => $params->{name}, + original_method => $params->{original_method}, + + # inherit from Class::MOP::Generated + is_inline => $params->{is_inline} || 0, + definition_context => $params->{definition_context}, + + # defined in this class + attribute => $params->{attribute}, + accessor_type => $params->{accessor_type}, + } => $class; +} + +## accessors + +sub associated_attribute { (shift)->{'attribute'} } +sub accessor_type { (shift)->{'accessor_type'} } + +## factory + +sub _initialize_body { + my $self = shift; + + my $method_name = join "_" => ( + '_generate', + $self->accessor_type, + 'method', + ($self->is_inline ? 'inline' : ()) + ); + + $self->{'body'} = $self->$method_name(); +} + +## generators + +sub _generate_accessor_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + if (@_ >= 2) { + $attr->set_value($_[0], $_[1]); + } + $attr->get_value($_[0]); + }; +} + +sub _generate_accessor_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + 'if (@_ > 1) {', + $attr->_inline_set_value('$_[0]', '$_[1]'), + '}', + $attr->_inline_get_value('$_[0]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "accessor" + ); + }; +} + +sub _generate_reader_method { + my $self = shift; + my $attr = $self->associated_attribute; + my $class = $attr->associated_class; + + return sub { + $self->_throw_exception( CannotAssignValueToReadOnlyAccessor => class_name => $class->name, + value => $_[1], + attribute => $attr + ) + if @_ > 1; + $attr->get_value($_[0]); + }; +} + +sub _generate_reader_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + my $attr_name = $attr->name; + + return try { + $self->_compile_code([ + 'sub {', + 'if (@_ > 1) {', + $self->_inline_throw_exception( CannotAssignValueToReadOnlyAccessor => + 'class_name => ref $_[0],'. + 'value => $_[1],'. + "attribute_name => '".$attr_name."'", + ) . ';', + '}', + $attr->_inline_get_value('$_[0]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "reader" + ); + }; +} + +sub _inline_throw_exception { + my ( $self, $exception_type, $throw_args ) = @_; + return 'die Module::Runtime::use_module("Moose::Exception::' . $exception_type . '")->new(' . ($throw_args || '') . ')'; +} + +sub _generate_writer_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->set_value($_[0], $_[1]); + }; +} + +sub _generate_writer_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + $attr->_inline_set_value('$_[0]', '$_[1]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "writer" + ); + }; +} + +sub _generate_predicate_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->has_value($_[0]) + }; +} + +sub _generate_predicate_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + $attr->_inline_has_value('$_[0]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "predicate" + ); + }; +} + +sub _generate_clearer_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->clear_value($_[0]) + }; +} + +sub _generate_clearer_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + + return try { + $self->_compile_code([ + 'sub {', + $attr->_inline_clear_value('$_[0]'), + '}', + ]); + } + catch { + $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self, + error => $_, + option => "clearer" + ); + }; +} + +1; + +# ABSTRACT: Method Meta Object for accessors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Accessor - Method Meta Object for accessors + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + use Class::MOP::Method::Accessor; + + my $reader = Class::MOP::Method::Accessor->new( + attribute => $attribute, + is_inline => 1, + accessor_type => 'reader', + ); + + $reader->body->execute($instance); # call the reader method + +=head1 DESCRIPTION + +This is a subclass of C<Class::MOP::Method> which is used by +C<Class::MOP::Attribute> to generate accessor code. It handles +generation of readers, writers, predicates and clearers. For each type +of method, it can either create a subroutine reference, or actually +inline code by generating a string and C<eval>'ing it. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method::Accessor->new(%options) >> + +This returns a new C<Class::MOP::Method::Accessor> based on the +C<%options> provided. + +=over 4 + +=item * attribute + +This is the C<Class::MOP::Attribute> for which accessors are being +generated. This option is required. + +=item * accessor_type + +This is a string which should be one of "reader", "writer", +"accessor", "predicate", or "clearer". This is the type of method +being generated. This option is required. + +=item * is_inline + +This indicates whether or not the accessor should be inlined. This +defaults to false. + +=item * name + +The method name (without a package name). This is required. + +=item * package_name + +The package name for the method. This is required. + +=back + +=item B<< $metamethod->accessor_type >> + +Returns the accessor type which was passed to C<new>. + +=item B<< $metamethod->is_inline >> + +Returns a boolean indicating whether or not the accessor is inlined. + +=item B<< $metamethod->associated_attribute >> + +This returns the L<Class::MOP::Attribute> object which was passed to +C<new>. + +=item B<< $metamethod->body >> + +The method itself is I<generated> when the accessor object is +constructed. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm new file mode 100644 index 0000000..c8a30ac --- /dev/null +++ b/lib/Class/MOP/Method/Constructor.pm @@ -0,0 +1,251 @@ +package Class::MOP::Method::Constructor; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed', 'weaken'; +use Try::Tiny; + +use parent 'Class::MOP::Method::Inlined'; + +sub new { + my $class = shift; + my %options = @_; + + (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class')) + || $class->_throw_exception( MustSupplyAMetaclass => params => \%options, + class => $class + ) + if $options{is_inline}; + + ($options{package_name} && $options{name}) + || $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options, + class => $class + ); + + my $self = $class->_new(\%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'associated_metaclass'}); + + $self->_initialize_body; + + return $self; +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + body => $params->{body}, + # associated_metaclass => $params->{associated_metaclass}, # overridden + package_name => $params->{package_name}, + name => $params->{name}, + original_method => $params->{original_method}, + + # inherited from Class::MOP::Generated + is_inline => $params->{is_inline} || 0, + definition_context => $params->{definition_context}, + + # inherited from Class::MOP::Inlined + _expected_method_class => $params->{_expected_method_class}, + + # defined in this subclass + options => $params->{options} || {}, + associated_metaclass => $params->{metaclass}, + }, $class; +} + +## accessors + +sub options { (shift)->{'options'} } +sub associated_metaclass { (shift)->{'associated_metaclass'} } + +## method + +sub _initialize_body { + my $self = shift; + my $method_name = '_generate_constructor_method'; + + $method_name .= '_inline' if $self->is_inline; + + $self->{'body'} = $self->$method_name; +} + +sub _eval_environment { + my $self = shift; + return $self->associated_metaclass->_eval_environment; +} + +sub _generate_constructor_method { + return sub { Class::MOP::Class->initialize(shift)->new_object(@_) } +} + +sub _generate_constructor_method_inline { + my $self = shift; + + my $meta = $self->associated_metaclass; + + my @source = ( + 'sub {', + $meta->_inline_new_object, + '}', + ); + + warn join("\n", @source) if $self->options->{debug}; + + my $code = try { + $self->_compile_code(\@source); + } + catch { + my $source = join("\n", @source); + $self->_throw_exception( CouldNotEvalConstructor => constructor_method => $self, + source => $source, + error => $_ + ); + }; + + return $code; +} + +1; + +# ABSTRACT: Method Meta Object for constructors + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Constructor - Method Meta Object for constructors + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + use Class::MOP::Method::Constructor; + + my $constructor = Class::MOP::Method::Constructor->new( + metaclass => $metaclass, + options => { + debug => 1, # this is all for now + }, + ); + + # calling the constructor ... + $constructor->body->execute($metaclass->name, %params); + +=head1 DESCRIPTION + +This is a subclass of L<Class::MOP::Method> which generates +constructor methods. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method::Constructor->new(%options) >> + +This creates a new constructor object. It accepts a hash reference of +options. + +=over 8 + +=item * metaclass + +This should be a L<Class::MOP::Class> object. It is required. + +=item * name + +The method name (without a package name). This is required. + +=item * package_name + +The package name for the method. This is required. + +=item * is_inline + +This indicates whether or not the constructor should be inlined. This +defaults to false. + +=back + +=item B<< $metamethod->is_inline >> + +Returns a boolean indicating whether or not the constructor is +inlined. + +=item B<< $metamethod->associated_metaclass >> + +This returns the L<Class::MOP::Class> object for the method. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Generated.pm b/lib/Class/MOP/Method/Generated.pm new file mode 100644 index 0000000..740f5f5 --- /dev/null +++ b/lib/Class/MOP/Method/Generated.pm @@ -0,0 +1,142 @@ +package Class::MOP::Method::Generated; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Eval::Closure; + +use parent 'Class::MOP::Method'; + +## accessors + +sub new { + $_[0]->_throw_exception( CannotCallAnAbstractBaseMethod => package_name => __PACKAGE__ ); +} + +sub _initialize_body { + $_[0]->_throw_exception( NoBodyToInitializeInAnAbstractBaseClass => package_name => __PACKAGE__ ); +} + +sub _generate_description { + my ( $self, $context ) = @_; + $context ||= $self->definition_context; + + my $desc = "generated method"; + my $origin = "unknown origin"; + + if (defined $context) { + if (defined $context->{description}) { + $desc = $context->{description}; + } + + if (defined $context->{file} || defined $context->{line}) { + $origin = "defined at " + . (defined $context->{file} + ? $context->{file} : "<unknown file>") + . " line " + . (defined $context->{line} + ? $context->{line} : "<unknown line>"); + } + } + + return "$desc ($origin)"; +} + +sub _compile_code { + my ( $self, @args ) = @_; + unshift @args, 'source' if @args % 2; + my %args = @args; + + my $context = delete $args{context}; + my $environment = $self->can('_eval_environment') + ? $self->_eval_environment + : {}; + + return eval_closure( + environment => $environment, + description => $self->_generate_description($context), + %args, + ); +} + +1; + +# ABSTRACT: Abstract base class for generated methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Generated - Abstract base class for generated methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a C<Class::MOP::Method> subclass which is subclassed by +C<Class::MOP::Method::Accessor> and +C<Class::MOP::Method::Constructor>. + +It is not intended to be used directly. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Inlined.pm b/lib/Class/MOP/Method/Inlined.pm new file mode 100644 index 0000000..a075200 --- /dev/null +++ b/lib/Class/MOP/Method/Inlined.pm @@ -0,0 +1,195 @@ +package Class::MOP::Method::Inlined; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'refaddr'; + +use parent 'Class::MOP::Method::Generated'; + +sub _uninlined_body { + my $self = shift; + + my $super_method + = $self->associated_metaclass->find_next_method_by_name( $self->name ) + or return; + + if ( $super_method->isa(__PACKAGE__) ) { + return $super_method->_uninlined_body; + } + else { + return $super_method->body; + } +} + +sub can_be_inlined { + my $self = shift; + my $metaclass = $self->associated_metaclass; + my $class = $metaclass->name; + + # If we don't find an inherited method, this is a rather weird + # case where we have no method in the inheritance chain even + # though we're expecting one to be there + my $inherited_method + = $metaclass->find_next_method_by_name( $self->name ); + + if ( $inherited_method + && $inherited_method->isa('Class::MOP::Method::Wrapped') ) { + warn "Not inlining '" + . $self->name + . "' for $class since it " + . "has method modifiers which would be lost if it were inlined\n"; + + return 0; + } + + my $expected_class = $self->_expected_method_class + or return 1; + + # if we are shadowing a method we first verify that it is + # compatible with the definition we are replacing it with + my $expected_method = $expected_class->can( $self->name ); + + if ( ! $expected_method ) { + warn "Not inlining '" + . $self->name + . "' for $class since ${expected_class}::" + . $self->name + . " is not defined\n"; + + return 0; + } + + my $actual_method = $class->can( $self->name ) + or return 1; + + # the method is what we wanted (probably Moose::Object::new) + return 1 + if refaddr($expected_method) == refaddr($actual_method); + + # otherwise we have to check that the actual method is an inlined + # version of what we're expecting + if ( $inherited_method->isa(__PACKAGE__) ) { + if ( $inherited_method->_uninlined_body + && refaddr( $inherited_method->_uninlined_body ) + == refaddr($expected_method) ) { + return 1; + } + } + elsif ( refaddr( $inherited_method->body ) + == refaddr($expected_method) ) { + return 1; + } + + my $warning + = "Not inlining '" + . $self->name + . "' for $class since it is not" + . " inheriting the default ${expected_class}::" + . $self->name . "\n"; + + if ( $self->isa("Class::MOP::Method::Constructor") ) { + + # FIXME kludge, refactor warning generation to a method + $warning + .= "If you are certain you don't need to inline your" + . " constructor, specify inline_constructor => 0 in your" + . " call to $class->meta->make_immutable\n"; + } + + warn $warning; + + return 0; +} + +1; + +# ABSTRACT: Method base class for methods which have been inlined + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Inlined - Method base class for methods which have been inlined + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a L<Class::MOP::Method::Generated> subclass for methods which +can be inlined. + +=head1 METHODS + +=over 4 + +=item B<< $metamethod->can_be_inlined >> + +This method returns true if the method in question can be inlined in +the associated metaclass. + +If it cannot be inlined, it spits out a warning and returns false. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Meta.pm b/lib/Class/MOP/Method/Meta.pm new file mode 100644 index 0000000..23b3567 --- /dev/null +++ b/lib/Class/MOP/Method/Meta.pm @@ -0,0 +1,169 @@ +package Class::MOP::Method::Meta; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken'; + +use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0; + +use parent 'Class::MOP::Method'; + +sub _is_caller_mop_internal { + my $self = shift; + my ($caller) = @_; + return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/; +} + +sub _generate_meta_method { + my $method_self = shift; + my $metaclass = shift; + weaken($metaclass); + + sub { + # this will be compiled out if the env var wasn't set + if (DEBUG_NO_META) { + confess "'meta' method called by MOP internals" + # it's okay to call meta methods on metaclasses, since we + # explicitly ask for them + if !$_[0]->isa('Class::MOP::Object') + && !$_[0]->isa('Class::MOP::Mixin') + # it's okay if the test itself calls ->meta, we only care about + # if the mop internals call ->meta + && $method_self->_is_caller_mop_internal(scalar caller); + } + # we must re-initialize so that it + # works as expected in subclasses, + # since metaclass instances are + # singletons, this is not really a + # big deal anyway. + $metaclass->initialize(blessed($_[0]) || $_[0]) + }; +} + +sub wrap { + my ($class, @args) = @_; + + unshift @args, 'body' if @args % 2 == 1; + my %params = @args; + $class->_throw_exception( CannotOverrideBodyOfMetaMethods => params => \%params, + class => $class + ) + if $params{body}; + + my $metaclass_class = $params{associated_metaclass}->meta; + $params{body} = $class->_generate_meta_method($metaclass_class); + return $class->SUPER::wrap(%params); +} + +sub _make_compatible_with { + my $self = shift; + my ($other) = @_; + + # XXX: this is pretty gross. the issue here is that CMOP::Method::Meta + # objects are subclasses of CMOP::Method, but when we get to moose, they'll + # need to be compatible with Moose::Meta::Method, which isn't possible. the + # right solution here is to make ::Meta into a role that gets applied to + # whatever the method_metaclass happens to be and get rid of + # _meta_method_metaclass entirely, but that's not going to happen until + # we ditch cmop and get roles into the bootstrapping, so. i'm not + # maintaining the previous behavior of turning them into instances of the + # new method_metaclass because that's equally broken, and at least this way + # any issues will at least be detectable and potentially fixable. -doy + return $self unless $other->_is_compatible_with($self->_real_ref_name); + + return $self->SUPER::_make_compatible_with(@_); +} + +1; + +# ABSTRACT: Method Meta Object for C<meta> methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Meta - Method Meta Object for C<meta> methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a L<Class::MOP::Method> subclass which represents C<meta> +methods installed into classes by Class::MOP. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> + +This is the constructor. It accepts a L<Class::MOP::Method> object and +a hash of options. The options accepted are identical to the ones +accepted by L<Class::MOP::Method>, except that C<body> cannot be passed +(it will be generated automatically). + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Method/Wrapped.pm b/lib/Class/MOP/Method/Wrapped.pm new file mode 100644 index 0000000..6b96c5f --- /dev/null +++ b/lib/Class/MOP/Method/Wrapped.pm @@ -0,0 +1,331 @@ +package Class::MOP::Method::Wrapped; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; + +use parent 'Class::MOP::Method'; + +# NOTE: +# this ugly beast is the result of trying +# to micro optimize this as much as possible +# while not completely loosing maintainability. +# At this point it's "fast enough", after all +# you can't get something for nothing :) +my $_build_wrapped_method = sub { + my $modifier_table = shift; + my ($before, $after, $around) = ( + $modifier_table->{before}, + $modifier_table->{after}, + $modifier_table->{around}, + ); + if (@$before && @$after) { + $modifier_table->{cache} = sub { + for my $c (@$before) { $c->(@_) }; + my @rval; + ((defined wantarray) ? + ((wantarray) ? + (@rval = $around->{cache}->(@_)) + : + ($rval[0] = $around->{cache}->(@_))) + : + $around->{cache}->(@_)); + for my $c (@$after) { $c->(@_) }; + return unless defined wantarray; + return wantarray ? @rval : $rval[0]; + } + } + elsif (@$before && !@$after) { + $modifier_table->{cache} = sub { + for my $c (@$before) { $c->(@_) }; + return $around->{cache}->(@_); + } + } + elsif (@$after && !@$before) { + $modifier_table->{cache} = sub { + my @rval; + ((defined wantarray) ? + ((wantarray) ? + (@rval = $around->{cache}->(@_)) + : + ($rval[0] = $around->{cache}->(@_))) + : + $around->{cache}->(@_)); + for my $c (@$after) { $c->(@_) }; + return unless defined wantarray; + return wantarray ? @rval : $rval[0]; + } + } + else { + $modifier_table->{cache} = $around->{cache}; + } +}; + +sub wrap { + my ( $class, $code, %params ) = @_; + + (blessed($code) && $code->isa('Class::MOP::Method')) + || $class->_throw_exception( CanOnlyWrapBlessedCode => params => \%params, + class => $class, + code => $code + ); + + my $modifier_table = { + cache => undef, + orig => $code->body, + before => [], + after => [], + around => { + cache => $code->body, + methods => [], + }, + }; + $_build_wrapped_method->($modifier_table); + return $class->SUPER::wrap( + sub { $modifier_table->{cache}->(@_) }, + # get these from the original + # unless explicitly overridden + package_name => $params{package_name} || $code->package_name, + name => $params{name} || $code->name, + original_method => $code, + + modifier_table => $modifier_table, + ); +} + +sub _new { + my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + 'body' => $params->{body}, + 'associated_metaclass' => $params->{associated_metaclass}, + 'package_name' => $params->{package_name}, + 'name' => $params->{name}, + 'original_method' => $params->{original_method}, + + # defined in this class + 'modifier_table' => $params->{modifier_table} + } => $class; +} + +sub get_original_method { + my $code = shift; + $code->original_method; +} + +sub add_before_modifier { + my $code = shift; + my $modifier = shift; + unshift @{$code->{'modifier_table'}->{before}} => $modifier; + $_build_wrapped_method->($code->{'modifier_table'}); +} + +sub before_modifiers { + my $code = shift; + return @{$code->{'modifier_table'}->{before}}; +} + +sub add_after_modifier { + my $code = shift; + my $modifier = shift; + push @{$code->{'modifier_table'}->{after}} => $modifier; + $_build_wrapped_method->($code->{'modifier_table'}); +} + +sub after_modifiers { + my $code = shift; + return @{$code->{'modifier_table'}->{after}}; +} + +{ + # NOTE: + # this is another possible candidate for + # optimization as well. There is an overhead + # associated with the currying that, if + # eliminated might make around modifiers + # more manageable. + my $compile_around_method = sub {{ + my $f1 = pop; + return $f1 unless @_; + my $f2 = pop; + push @_, sub { $f2->( $f1, @_ ) }; + redo; + }}; + + sub add_around_modifier { + my $code = shift; + my $modifier = shift; + unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier; + $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->( + @{$code->{'modifier_table'}->{around}->{methods}}, + $code->{'modifier_table'}->{orig} + ); + $_build_wrapped_method->($code->{'modifier_table'}); + } +} + +sub around_modifiers { + my $code = shift; + return @{$code->{'modifier_table'}->{around}->{methods}}; +} + +sub _make_compatible_with { + my $self = shift; + my ($other) = @_; + + # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped + # objects are subclasses of CMOP::Method, but when we get to moose, they'll + # need to be compatible with Moose::Meta::Method, which isn't possible. the + # right solution here is to make ::Wrapped into a role that gets applied to + # whatever the method_metaclass happens to be and get rid of + # wrapped_method_metaclass entirely, but that's not going to happen until + # we ditch cmop and get roles into the bootstrapping, so. i'm not + # maintaining the previous behavior of turning them into instances of the + # new method_metaclass because that's equally broken, and at least this way + # any issues will at least be detectable and potentially fixable. -doy + return $self unless $other->_is_compatible_with($self->_real_ref_name); + + return $self->SUPER::_make_compatible_with(@_); +} + +1; + +# ABSTRACT: Method Meta Object for methods with before/after/around modifiers + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This is a L<Class::MOP::Method> subclass which implements before, +after, and around method modifiers. + +=head1 METHODS + +=head2 Construction + +=over 4 + +=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> + +This is the constructor. It accepts a L<Class::MOP::Method> object and +a hash of options. + +The options are: + +=over 8 + +=item * name + +The method name (without a package name). This will be taken from the +provided L<Class::MOP::Method> object if it is not provided. + +=item * package_name + +The package name for the method. This will be taken from the provided +L<Class::MOP::Method> object if it is not provided. + +=item * associated_metaclass + +An optional L<Class::MOP::Class> object. This is the metaclass for the +method's class. + +=back + +=item B<< $metamethod->get_original_method >> + +This returns the L<Class::MOP::Method> object that was passed to the +constructor. + +=item B<< $metamethod->add_before_modifier($code) >> + +=item B<< $metamethod->add_after_modifier($code) >> + +=item B<< $metamethod->add_around_modifier($code) >> + +These methods all take a subroutine reference and apply it as a +modifier to the original method. + +=item B<< $metamethod->before_modifiers >> + +=item B<< $metamethod->after_modifiers >> + +=item B<< $metamethod->around_modifiers >> + +These methods all return a list of subroutine references which are +acting as the specified type of modifier. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/MiniTrait.pm b/lib/Class/MOP/MiniTrait.pm new file mode 100644 index 0000000..4272901 --- /dev/null +++ b/lib/Class/MOP/MiniTrait.pm @@ -0,0 +1,113 @@ +package Class::MOP::MiniTrait; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Module::Runtime 'use_package_optimistically'; + +sub apply { + my ( $to_class, $trait ) = @_; + + for ( grep { !ref } $to_class, $trait ) { + use_package_optimistically($_); + $_ = Class::MOP::Class->initialize($_); + } + + for my $meth ( grep { $_->package_name ne 'UNIVERSAL' } $trait->get_all_methods ) { + my $meth_name = $meth->name; + next if index($meth_name, '__') == 0; # skip private subs + + if ( $to_class->find_method_by_name($meth_name) ) { + $to_class->add_around_method_modifier( $meth_name, $meth->body ); + } + else { + $to_class->add_method( $meth_name, $meth->clone ); + } + } +} + +# We can't load this with use, since it may be loaded and used from Class::MOP +# (via CMOP::Class, etc). However, if for some reason this module is loaded +# _without_ first loading Class::MOP we need to require Class::MOP so we can +# use it and CMOP::Class. +require Class::MOP; + +1; + +# ABSTRACT: Extremely limited trait application + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::MiniTrait - Extremely limited trait application + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This package provides a single function, C<apply>, which does a half-assed job +of applying a trait to a class. It exists solely for use inside Class::MOP and +L<Moose> core classes. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin.pm b/lib/Class/MOP/Mixin.pm new file mode 100644 index 0000000..578448a --- /dev/null +++ b/lib/Class/MOP/Mixin.pm @@ -0,0 +1,111 @@ +package Class::MOP::Mixin; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; +use Module::Runtime 'use_module'; + +sub meta { + require Class::MOP::Class; + Class::MOP::Class->initialize( blessed( $_[0] ) || $_[0] ); +} + +sub _throw_exception { + my ($class, $exception_type, @args_to_exception) = @_; + die use_module( "Moose::Exception::$exception_type" )->new( @args_to_exception ); +} + +1; + +# ABSTRACT: Base class for mixin classes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin - Base class for mixin classes + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class provides a few methods which are useful in all metaclasses. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Mixin->meta >> + +This returns a L<Class::MOP::Class> object for the mixin class. + +=item B<< Class::MOP::Mixin->_throw_exception >> + +Throws an exception in the L<Moose::Exception> family. This should ONLY be +used internally -- any callers outside Class::MOP::* should be using the +version in L<Moose::Util> instead. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin/AttributeCore.pm b/lib/Class/MOP/Mixin/AttributeCore.pm new file mode 100644 index 0000000..9c96c6c --- /dev/null +++ b/lib/Class/MOP/Mixin/AttributeCore.pm @@ -0,0 +1,125 @@ +package Class::MOP::Mixin::AttributeCore; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; + +use parent 'Class::MOP::Mixin'; + +sub has_accessor { defined $_[0]->{'accessor'} } +sub has_reader { defined $_[0]->{'reader'} } +sub has_writer { defined $_[0]->{'writer'} } +sub has_predicate { defined $_[0]->{'predicate'} } +sub has_clearer { defined $_[0]->{'clearer'} } +sub has_builder { defined $_[0]->{'builder'} } +sub has_init_arg { defined $_[0]->{'init_arg'} } +sub has_default { exists $_[0]->{'default'} } +sub has_initializer { defined $_[0]->{'initializer'} } +sub has_insertion_order { defined $_[0]->{'insertion_order'} } + +sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] } + +sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } +sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } + +sub is_default_a_coderef { + # Uber hack because it is called from CMOP::Attribute constructor as + # $class->is_default_a_coderef(\%options) + my ($value) = ref $_[0] ? $_[0]->{'default'} : $_[1]->{'default'}; + + return unless ref($value); + + return ref($value) eq 'CODE' + || ( blessed($value) && $value->isa('Class::MOP::Method') ); +} + +sub default { + my ( $self, $instance ) = @_; + if ( defined $instance && $self->is_default_a_coderef ) { + # if the default is a CODE ref, then we pass in the instance and + # default can return a value based on that instance. Somewhat crude, + # but works. + return $self->{'default'}->($instance); + } + $self->{'default'}; +} + +1; + +# ABSTRACT: Core attributes shared by attribute metaclasses + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin::AttributeCore - Core attributes shared by attribute metaclasses + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements the core attributes (aka properties) shared by all +attributes. See the L<Class::MOP::Attribute> documentation for API details. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin/HasAttributes.pm b/lib/Class/MOP/Mixin/HasAttributes.pm new file mode 100644 index 0000000..c76377d --- /dev/null +++ b/lib/Class/MOP/Mixin/HasAttributes.pm @@ -0,0 +1,171 @@ +package Class::MOP::Mixin::HasAttributes; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; + +use parent 'Class::MOP::Mixin'; + +sub add_attribute { + my $self = shift; + + my $attribute + = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_); + + ( $attribute->isa('Class::MOP::Mixin::AttributeCore') ) + || $self->_throw_exception( AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass => attribute => $attribute, + class_name => $self->name, + ); + + $self->_attach_attribute($attribute); + + my $attr_name = $attribute->name; + + $self->remove_attribute($attr_name) + if $self->has_attribute($attr_name); + + my $order = ( scalar keys %{ $self->_attribute_map } ); + $attribute->_set_insertion_order($order); + + $self->_attribute_map->{$attr_name} = $attribute; + + # This method is called to allow for installing accessors. Ideally, we'd + # use method overriding, but then the subclass would be responsible for + # making the attribute, which would end up with lots of code + # duplication. Even more ideally, we'd use augment/inner, but this is + # Class::MOP! + $self->_post_add_attribute($attribute) + if $self->can('_post_add_attribute'); + + return $attribute; +} + +sub has_attribute { + my ( $self, $attribute_name ) = @_; + + ( defined $attribute_name ) + || $self->_throw_exception( MustDefineAnAttributeName => class_name => $self->name ); + + exists $self->_attribute_map->{$attribute_name}; +} + +sub get_attribute { + my ( $self, $attribute_name ) = @_; + + ( defined $attribute_name ) + || $self->_throw_exception( MustDefineAnAttributeName => class_name => $self->name ); + + return $self->_attribute_map->{$attribute_name}; +} + +sub remove_attribute { + my ( $self, $attribute_name ) = @_; + + ( defined $attribute_name ) + || $self->_throw_exception( MustDefineAnAttributeName => class_name => $self->name ); + + my $removed_attribute = $self->_attribute_map->{$attribute_name}; + return unless defined $removed_attribute; + + delete $self->_attribute_map->{$attribute_name}; + + return $removed_attribute; +} + +sub get_attribute_list { + my $self = shift; + keys %{ $self->_attribute_map }; +} + +sub _restore_metaattributes_from { + my $self = shift; + my ($old_meta) = @_; + + for my $attr (sort { $a->insertion_order <=> $b->insertion_order } + map { $old_meta->get_attribute($_) } + $old_meta->get_attribute_list) { + $attr->_make_compatible_with($self->attribute_metaclass); + $self->add_attribute($attr); + } +} + +1; + +# ABSTRACT: Methods for metaclasses which have attributes + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin::HasAttributes - Methods for metaclasses which have attributes + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements methods for metaclasses which have attributes +(L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for +API details. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin/HasMethods.pm b/lib/Class/MOP/Mixin/HasMethods.pm new file mode 100644 index 0000000..1a27b69 --- /dev/null +++ b/lib/Class/MOP/Mixin/HasMethods.pm @@ -0,0 +1,304 @@ +package Class::MOP::Mixin::HasMethods; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::Method::Meta; + +use Scalar::Util 'blessed', 'reftype'; +use Sub::Name 'subname'; + +use parent 'Class::MOP::Mixin'; + +sub _meta_method_class { 'Class::MOP::Method::Meta' } + +sub _add_meta_method { + my $self = shift; + my ($name) = @_; + my $existing_method = $self->can('find_method_by_name') + ? $self->find_method_by_name($name) + : $self->get_method($name); + return if $existing_method + && $existing_method->isa($self->_meta_method_class); + $self->add_method( + $name => $self->_meta_method_class->wrap( + name => $name, + package_name => $self->name, + associated_metaclass => $self, + ) + ); +} + +sub wrap_method_body { + my ( $self, %args ) = @_; + + ( $args{body} && 'CODE' eq reftype $args{body} ) + || $self->_throw_exception( CodeBlockMustBeACodeRef => instance => $self, + params => \%args + ); + $self->method_metaclass->wrap( + package_name => $self->name, + %args, + ); +} + +sub add_method { + my ( $self, $method_name, $method ) = @_; + ( defined $method_name && length $method_name ) + || $self->_throw_exception( MustDefineAMethodName => instance => $self ); + + my $package_name = $self->name; + + my $body; + if ( blessed($method) && $method->isa('Class::MOP::Method') ) { + $body = $method->body; + if ( $method->package_name ne $package_name ) { + $method = $method->clone( + package_name => $package_name, + name => $method_name, + ); + } + + $method->attach_to_class($self); + } + else { + # If a raw code reference is supplied, its method object is not created. + # The method object won't be created until required. + $body = $method; + } + + $self->_method_map->{$method_name} = $method; + + my ($current_package, $current_name) = Class::MOP::get_code_info($body); + + subname($package_name . '::' . $method_name, $body) + unless defined $current_name && $current_name !~ /^__ANON__/; + + $self->add_package_symbol("&$method_name", $body); + + # we added the method to the method map too, so it's still valid + $self->update_package_cache_flag; +} + +sub _code_is_mine { + my ( $self, $code ) = @_; + + my ( $code_package, $code_name ) = Class::MOP::get_code_info($code); + + return ( $code_package && $code_package eq $self->name ) + || ( $code_package eq 'constant' && $code_name eq '__ANON__' ); +} + +sub has_method { + my ( $self, $method_name ) = @_; + + ( defined $method_name && length $method_name ) + || $self->_throw_exception( MustDefineAMethodName => instance => $self ); + + my $method = $self->_get_maybe_raw_method($method_name) + or return; + + return defined($self->_method_map->{$method_name} = $method); +} + +sub get_method { + my ( $self, $method_name ) = @_; + + ( defined $method_name && length $method_name ) + || $self->_throw_exception( MustDefineAMethodName => instance => $self ); + + my $method = $self->_get_maybe_raw_method($method_name) + or return; + + return $method if blessed($method) && $method->isa('Class::MOP::Method'); + + return $self->_method_map->{$method_name} = $self->wrap_method_body( + body => $method, + name => $method_name, + associated_metaclass => $self, + ); +} + +sub _get_maybe_raw_method { + my ( $self, $method_name ) = @_; + + my $map_entry = $self->_method_map->{$method_name}; + return $map_entry if defined $map_entry; + + my $code = $self->get_package_symbol("&$method_name"); + + return unless $code && $self->_code_is_mine($code); + + return $code; +} + +sub remove_method { + my ( $self, $method_name ) = @_; + + ( defined $method_name && length $method_name ) + || $self->_throw_exception( MustDefineAMethodName => instance => $self ); + + my $removed_method = delete $self->_method_map->{$method_name}; + + $self->remove_package_symbol("&$method_name"); + + $removed_method->detach_from_class + if blessed($removed_method) && $removed_method->isa('Class::MOP::Method'); + + # still valid, since we just removed the method from the map + $self->update_package_cache_flag; + + return $removed_method; +} + +sub get_method_list { + my $self = shift; + + return keys %{ $self->_full_method_map }; +} + +sub _get_local_methods { + my $self = shift; + + return values %{ $self->_full_method_map }; +} + +sub _restore_metamethods_from { + my $self = shift; + my ($old_meta) = @_; + + my $package_name = $self->name; + + # Check if Perl debugger is enabled + my $debugger_enabled = ($^P & 0x10); + my $debug_method_info; + + for my $method ($old_meta->_get_local_methods) { + my $method_name = $method->name; + + # Track DB::sub information for this method if debugger is enabled. + # This contains original method filename and line numbers. + $debug_method_info = ''; + if ($debugger_enabled) { + $debug_method_info = $DB::sub{$package_name . "::" . $method_name} + } + + $method->_make_compatible_with($self->method_metaclass); + $self->add_method($method_name => $method); + + # Restore method debug information, which can be clobbered by add_method. + # Note that we handle this here instead of in add_method, because we + # only want to preserve the original debug info in cases where we are + # restoring a method, not overwriting a method. + if ($debugger_enabled && $debug_method_info) { + $DB::sub{$package_name . "::" . $method_name} = $debug_method_info; + } + } +} + +sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef } +sub update_package_cache_flag { + my $self = shift; + # NOTE: + # we can manually update the cache number + # since we are actually adding the method + # to our cache as well. This avoids us + # having to regenerate the method_map. + # - SL + $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); +} + +sub _full_method_map { + my $self = shift; + + my $pkg_gen = Class::MOP::check_package_cache_flag($self->name); + + if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) { + # forcibly reify all method map entries + $self->get_method($_) + for $self->list_all_package_symbols('CODE'); + $self->{_package_cache_flag_full} = $pkg_gen; + } + + return $self->_method_map; +} + +1; + +# ABSTRACT: Methods for metaclasses which have methods + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements methods for metaclasses which have methods +(L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for +API details. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Mixin/HasOverloads.pm b/lib/Class/MOP/Mixin/HasOverloads.pm new file mode 100644 index 0000000..057551f --- /dev/null +++ b/lib/Class/MOP/Mixin/HasOverloads.pm @@ -0,0 +1,237 @@ +package Class::MOP::Mixin::HasOverloads; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Class::MOP::Overload; + +use Devel::OverloadInfo 'overload_info'; +use Scalar::Util 'blessed'; +use Sub::Identify 'sub_name', 'stash_name'; + +use overload (); + +use parent 'Class::MOP::Mixin'; + +sub is_overloaded { + my $self = shift; + return overload::Overloaded($self->name); +} + +sub get_overload_list { + my $self = shift; + + my $info = $self->_overload_info; + return grep { $_ ne 'fallback' } keys %{$info} +} + +sub get_all_overloaded_operators { + my $self = shift; + return map { $self->_overload_for($_) } $self->get_overload_list; +} + +sub has_overloaded_operator { + my $self = shift; + my ($op) = @_; + return defined $self->_overload_info->{$op}; +} + +sub _overload_map { + $_[0]->{_overload_map} ||= {}; +} + +sub get_overloaded_operator { + my $self = shift; + my ($op) = @_; + return $self->_overload_map->{$op} ||= $self->_overload_for($op); +} + +use constant _SET_FALLBACK_EACH_TIME => $] < 5.120; + +sub add_overloaded_operator { + my $self = shift; + my ( $op, $overload ) = @_; + + my %p = ( associated_metaclass => $self ); + if ( !ref $overload ) { + %p = ( + %p, + operator => $op, + method_name => $overload, + associated_metaclass => $self, + ); + $p{method} = $self->get_method($overload) + if $self->has_method($overload); + $overload = Class::MOP::Overload->new(%p); + } + elsif ( !blessed $overload) { + $overload = Class::MOP::Overload->new( + operator => $op, + coderef => $overload, + coderef_name => sub_name($overload), + coderef_package => stash_name($overload), + %p, + ); + } + + $overload->attach_to_class($self); + $self->_overload_map->{$op} = $overload; + + my %overload = ( + $op => $overload->has_coderef + ? $overload->coderef + : $overload->method_name + ); + + # Perl 5.10 and earlier appear to have a bug where setting a new + # overloading operator wipes out the fallback value unless we pass it each + # time. + if (_SET_FALLBACK_EACH_TIME) { + $overload{fallback} = $self->get_overload_fallback_value; + } + + $self->name->overload::OVERLOAD(%overload); +} + +sub remove_overloaded_operator { + my $self = shift; + my ($op) = @_; + + delete $self->_overload_map->{$op}; + + # overload.pm provides no api for this - but the problem that makes this + # necessary has been fixed in 5.18 + $self->get_or_add_package_symbol('%OVERLOAD')->{dummy}++ + if $] < 5.017000; + + $self->remove_package_symbol('&(' . $op); +} + +sub get_overload_fallback_value { + my $self = shift; + return $self->_overload_info->{fallback}{value}; +} + +sub set_overload_fallback_value { + my $self = shift; + my $value = shift; + + $self->name->overload::OVERLOAD( fallback => $value ); +} + +# We could cache this but we'd need some logic to clear it at all the right +# times, which seems more tedious than it's worth. +sub _overload_info { + my $self = shift; + return overload_info( $self->name ) || {}; +} + +sub _overload_for { + my $self = shift; + my $op = shift; + + my $map = $self->_overload_map; + return $map->{$op} if $map->{$op}; + + my $info = $self->_overload_info->{$op}; + return unless $info; + + my %p = ( + operator => $op, + associated_metaclass => $self, + ); + + if ( $info->{code} && !$info->{method_name} ) { + $p{coderef} = $info->{code}; + @p{ 'coderef_package', 'coderef_name' } + = $info->{code_name} =~ /(.+)::([^:]+)/; + } + else { + $p{method_name} = $info->{method_name}; + if ( $self->has_method( $p{method_name} ) ) { + $p{method} = $self->get_method( $p{method_name} ); + } + } + + return $map->{$op} = Class::MOP::Overload->new(%p); +} + +1; + +# ABSTRACT: Methods for metaclasses which have overloads + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Mixin::HasOverloads - Methods for metaclasses which have overloads + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class implements methods for metaclasses which have overloads +(L<Class::MOP::Clas> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for +API details. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm new file mode 100644 index 0000000..ddc83f7 --- /dev/null +++ b/lib/Class/MOP/Module.pm @@ -0,0 +1,213 @@ +package Class::MOP::Module; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Class::MOP::Package'; + +sub _new { + my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + return bless { + # Need to quote package to avoid a problem with PPI mis-parsing this + # as a package statement. + + # from Class::MOP::Package + 'package' => $params->{package}, + namespace => \undef, + + # attributes + version => \undef, + authority => \undef + } => $class; +} + +sub version { + my $self = shift; + ${$self->get_or_add_package_symbol('$VERSION')}; +} + +sub authority { + my $self = shift; + ${$self->get_or_add_package_symbol('$AUTHORITY')}; +} + +sub identifier { + my $self = shift; + join '-' => ( + $self->name, + ($self->version || ()), + ($self->authority || ()), + ); +} + +sub create { + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; + + my $package = delete $options{package}; + my $version = delete $options{version}; + my $authority = delete $options{authority}; + + my $meta = $class->SUPER::create($package => %options); + + $meta->_instantiate_module($version, $authority); + + return $meta; +} + +sub _anon_package_prefix { 'Class::MOP::Module::__ANON__::SERIAL::' } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + $class->_throw_exception( PackagesAndModulesAreNotCachable => class_name => $class, + params => \%options, + is_module => 1 + ); +} + +sub _instantiate_module { + my($self, $version, $authority) = @_; + my $package_name = $self->name; + + $self->add_package_symbol('$VERSION' => $version) + if defined $version; + $self->add_package_symbol('$AUTHORITY' => $authority) + if defined $authority; + + return; +} + +1; + +# ABSTRACT: Module Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Module - Module Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +A module is essentially a L<Class::MOP::Package> with metadata, in our +case the version and authority. + +=head1 INHERITANCE + +B<Class::MOP::Module> is a subclass of L<Class::MOP::Package>. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Module->create($package, %options) >> + +Overrides C<create> from L<Class::MOP::Package> to provide these additional +options: + +=over 4 + +=item C<version> + +A version number, to be installed in the C<$VERSION> package global variable. + +=item C<authority> + +An authority, to be installed in the C<$AUTHORITY> package global variable. + +This is a legacy field and its use is not recommended. + +=back + +=item B<< $metamodule->version >> + +This is a read-only attribute which returns the C<$VERSION> of the +package, if one exists. + +=item B<< $metamodule->authority >> + +This is a read-only attribute which returns the C<$AUTHORITY> of the +package, if one exists. + +=item B<< $metamodule->identifier >> + +This constructs a string which combines the name, version and +authority. + +=item B<< Class::MOP::Module->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Object.pm b/lib/Class/MOP/Object.pm new file mode 100644 index 0000000..a5d0896 --- /dev/null +++ b/lib/Class/MOP/Object.pm @@ -0,0 +1,200 @@ +package Class::MOP::Object; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use parent 'Class::MOP::Mixin'; +use Scalar::Util 'blessed'; +use Module::Runtime; + +# introspection + +sub throw_error { + shift->_throw_exception( Legacy => message => join('', @_) ); +} + +sub _inline_throw_error { + my ( $self, $message ) = @_; + return 'die Module::Runtime::use_module("Moose::Exception::Legacy")->new(message => ' . $message. ')'; +} + +sub _new { + Class::MOP::class_of(shift)->new_object(@_); +} + +# RANT: +# Cmon, how many times have you written +# the following code while debugging: +# +# use Data::Dumper; +# warn Dumper $obj; +# +# It can get seriously annoying, so why +# not just do this ... +sub dump { + my $self = shift; + require Data::Dumper; + local $Data::Dumper::Maxdepth = shift || 1; + Data::Dumper::Dumper $self; +} + +sub _real_ref_name { + my $self = shift; + return blessed($self); +} + +sub _is_compatible_with { + my $self = shift; + my ($other_name) = @_; + + return $self->isa($other_name); +} + +sub _can_be_made_compatible_with { + my $self = shift; + return !$self->_is_compatible_with(@_) + && defined($self->_get_compatible_metaclass(@_)); +} + +sub _make_compatible_with { + my $self = shift; + my ($other_name) = @_; + + my $new_metaclass = $self->_get_compatible_metaclass($other_name); + + unless ( defined $new_metaclass ) { + $self->_throw_exception( CannotMakeMetaclassCompatible => superclass_name => $other_name, + class => $self, + ); + } + + # can't use rebless_instance here, because it might not be an actual + # subclass in the case of, e.g. moose role reconciliation + $new_metaclass->meta->_force_rebless_instance($self) + if blessed($self) ne $new_metaclass; + + return $self; +} + +sub _get_compatible_metaclass { + my $self = shift; + my ($other_name) = @_; + + return $self->_get_compatible_metaclass_by_subclassing($other_name); +} + +sub _get_compatible_metaclass_by_subclassing { + my $self = shift; + my ($other_name) = @_; + my $meta_name = blessed($self) ? $self->_real_ref_name : $self; + + if ($meta_name->isa($other_name)) { + return $meta_name; + } + elsif ($other_name->isa($meta_name)) { + return $other_name; + } + + return; +} + +1; + +# ABSTRACT: Base class for metaclasses + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Object - Base class for metaclasses + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +This class is a very minimal base class for metaclasses. + +=head1 METHODS + +This class provides a few methods which are useful in all metaclasses. + +=over 4 + +=item B<< Class::MOP::???->meta >> + +This returns a L<Class::MOP::Class> object. + +=item B<< $metaobject->dump($max_depth) >> + +This method uses L<Data::Dumper> to dump the object. You can pass an +optional maximum depth, which will set C<$Data::Dumper::Maxdepth>. The +default maximum depth is 1. + +=item B<< $metaclass->throw_error($message) >> + +This method calls L<Class::MOP::Mixin/_throw_exception> internally, with an object +of class L<Moose::Exception::Legacy>. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Overload.pm b/lib/Class/MOP/Overload.pm new file mode 100644 index 0000000..8ff81f5 --- /dev/null +++ b/lib/Class/MOP/Overload.pm @@ -0,0 +1,342 @@ +package Class::MOP::Overload; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use overload (); +use Scalar::Util qw( blessed weaken ); +use Try::Tiny; + +use parent 'Class::MOP::Object'; + +my %Operators = ( + map { $_ => 1 } + grep { $_ ne 'fallback' } + map { split /\s+/ } values %overload::ops +); + +sub new { + my ( $class, %params ) = @_; + + unless ( defined $params{operator} ) { + $class->_throw_exception('OverloadRequiresAnOperator'); + } + unless ( $Operators{ $params{operator} } ) { + $class->_throw_exception( + 'InvalidOverloadOperator', + operator => $params{operator}, + ); + } + + unless ( defined $params{method_name} || $params{coderef} ) { + $class->_throw_exception( + 'OverloadRequiresAMethodNameOrCoderef', + operator => $params{operator}, + ); + } + + if ( $params{coderef} ) { + unless ( defined $params{coderef_package} + && defined $params{coderef_name} ) { + + $class->_throw_exception('OverloadRequiresNamesForCoderef'); + } + } + + if ( $params{method} + && !try { $params{method}->isa('Class::MOP::Method') } ) { + + $class->_throw_exception('OverloadRequiresAMetaMethod'); + } + + if ( $params{associated_metaclass} + && !try { $params{associated_metaclass}->isa('Class::MOP::Module') } ) + { + + $class->_throw_exception('OverloadRequiresAMetaClass'); + } + + my @optional_attrs + = qw( method_name coderef coderef_package coderef_name method associated_metaclass ); + + return bless { + operator => $params{operator}, + map { defined $params{$_} ? ( $_ => $params{$_} ) : () } + @optional_attrs + }, + $class; +} + +sub operator { $_[0]->{operator} } + +sub method_name { $_[0]->{method_name} } +sub has_method_name { exists $_[0]->{method_name} } + +sub method { $_[0]->{method} } +sub has_method { exists $_[0]->{method} } + +sub coderef { $_[0]->{coderef} } +sub has_coderef { exists $_[0]->{coderef} } + +sub coderef_package { $_[0]->{coderef_package} } +sub has_coderef_package { exists $_[0]->{coderef_package} } + +sub coderef_name { $_[0]->{coderef_name} } +sub has_coderef_name { exists $_[0]->{coderef_name} } + +sub associated_metaclass { $_[0]->{associated_metaclass} } + +sub is_anonymous { + my $self = shift; + return $self->has_coderef && $self->coderef_name eq '__ANON__'; +} + +sub attach_to_class { + my ( $self, $class ) = @_; + $self->{associated_metaclass} = $class; + weaken $self->{associated_metaclass}; +} + +sub clone { + my $self = shift; + + my $clone = bless { %{$self}, @_ }, blessed($self); + weaken $clone->{associated_metaclass} if $clone->{associated_metaclass}; + + $clone->_set_original_overload($self); + + return $clone; +} + +sub original_overload { $_[0]->{original_overload} } +sub _set_original_overload { $_[0]->{original_overload} = $_[1] } + +sub _is_equal_to { + my $self = shift; + my $other = shift; + + if ( $self->has_coderef ) { + return unless $other->has_coderef; + return $self->coderef == $other->coderef; + } + else { + return $self->method_name eq $other->method_name; + } +} + +1; + +# ABSTRACT: Overload Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Overload - Overload Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 SYNOPSIS + + my $meta = Class->meta; + my $overload = $meta->get_overloaded_operator('+'); + + if ( $overload->has_method_name ) { + print 'Method for + is ', $overload->method_name, "\n"; + } + else { + print 'Overloading for + is implemented by ', + $overload->coderef_name, " sub\n"; + } + +=head1 DESCRIPTION + +This class provides meta information for overloading in classes and roles. + +=head1 INHERITANCE + +C<Class::MOP::Overload> is a subclass of L<Class::MOP::Object>. + +=head1 METHODS + +This class provides the following methods: + +=head2 Class::MOP::Overload->new(%options) + +This method creates a new C<Class::MOP::Overload> object. It accepts a number +of options: + +=over 4 + +=item * operator + +This is a string that matches an operator known by the L<overload> module, +such as C<""> or C<+>. This is required. + +=item * method_name + +The name of the method which implements the overloading. Note that this does +not need to actually correspond to a real method, since it's okay to declare a +not-yet-implemented overloading. + +Either this or the C<coderef> option must be passed. + +=item * method + +A L<Class::MOP::Method> object for the method which implements the +overloading. + +This is optional. + +=item * coderef + +A coderef which implements the overloading. + +Either this or the C<method_name> option must be passed. + +=item * coderef_package + +The package where the coderef was defined. + +This is required if C<coderef> is passed. + +=item * coderef_name + +The name of the coderef. This can be "__ANON__". + +This is required if C<coderef> is passed. + +=item * associated_metaclass + +A L<Class::MOP::Module> object for the associated class or role. + +This is optional. + +=back + +=head2 $overload->operator + +Returns the operator for this overload object. + +=head2 $overload->method_name + +Returns the method name that implements overloading, if it has one. + +=head2 $overload->has_method_name + +Returns true if the object has a method name. + +=head2 $overload->method + +Returns the L<Class::MOP::Method> that implements overloading, if it has one. + +=head2 $overload->has_method + +Returns true if the object has a method. + +=head2 $overload->coderef + +Returns the coderef that implements overloading, if it has one. + +=head2 $overload->has_coderef + +Returns true if the object has a coderef. + +=head2 $overload->coderef_package + +Returns the package for the coderef that implements overloading, if it has +one. + +=head2 $overload->has_coderef + +Returns true if the object has a coderef package. + +=head2 $overload->coderef_name + +Returns the sub name for the coderef that implements overloading, if it has +one. + +=head2 $overload->has_coderef_name + +Returns true if the object has a coderef name. + +=head2 $overload->is_anonymous + +Returns true if the overloading is implemented by an anonymous coderef. + +=head2 $overload->associated_metaclass + +Returns the L<Class::MOP::Module> (class or role) that is associated with the +overload object. + +=head2 $overload->clone + +Clones the overloading object, setting C<original_overload> in the process. + +=head2 $overload->original_overload + +For cloned objects, this returns the L<Class::MOP::Overload> object from which +they were cloned. This can be used to determine the source of an overloading +in a class that came from a role, for example. + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm new file mode 100644 index 0000000..135ad68 --- /dev/null +++ b/lib/Class/MOP/Package.pm @@ -0,0 +1,464 @@ +package Class::MOP::Package; +our $VERSION = '2.1405'; + +use strict; +use warnings; + +use Scalar::Util 'blessed', 'weaken'; +use Devel::GlobalDestruction 'in_global_destruction'; +use Module::Runtime 'module_notional_filename'; +use Package::Stash; + +use parent 'Class::MOP::Object'; + +# creation ... + +sub initialize { + my ( $class, @args ) = @_; + + unshift @args, "package" if @args % 2; + + my %options = @args; + my $package_name = delete $options{package}; + + # we hand-construct the class until we can bootstrap it + if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) { + return $meta; + } else { + my $meta = ( ref $class || $class )->_new({ + 'package' => $package_name, + %options, + }); + Class::MOP::store_metaclass_by_name($package_name, $meta); + + Class::MOP::weaken_metaclass($package_name) if $options{weaken}; + + + return $meta; + } +} + +sub reinitialize { + my ( $class, @args ) = @_; + + unshift @args, "package" if @args % 2; + + my %options = @args; + my $package_name = delete $options{package}; + + (defined $package_name && $package_name + && (!blessed $package_name || $package_name->isa('Class::MOP::Package'))) + || $class->_throw_exception( MustPassAPackageNameOrAnExistingClassMOPPackageInstance => params => \%options, + class => $class + ); + + $package_name = $package_name->name + if blessed $package_name; + + Class::MOP::remove_metaclass_by_name($package_name); + + $class->initialize($package_name, %options); # call with first arg form for compat +} + +sub create { + my $class = shift; + my @args = @_; + + my $meta = $class->initialize(@args); + my $filename = module_notional_filename($meta->name); + $INC{$filename} = '(set by Moose)' + unless exists $INC{$filename}; + + return $meta; +} + +## ANON packages + +{ + # NOTE: + # this should be sufficient, if you have a + # use case where it is not, write a test and + # I will change it. + my $ANON_SERIAL = 0; + + my %ANON_PACKAGE_CACHE; + + # NOTE: + # we need a sufficiently annoying prefix + # this should suffice for now, this is + # used in a couple of places below, so + # need to put it up here for now. + sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' } + + sub is_anon { + my $self = shift; + no warnings 'uninitialized'; + my $prefix = $self->_anon_package_prefix; + $self->name =~ /^\Q$prefix/; + } + + sub create_anon { + my ($class, %options) = @_; + + my $cache_ok = delete $options{cache}; + $options{weaken} = !$cache_ok unless exists $options{weaken}; + + my $cache_key; + if ($cache_ok) { + $cache_key = $class->_anon_cache_key(%options); + undef $cache_ok if !defined($cache_key); + } + + if ($cache_ok) { + if (defined $ANON_PACKAGE_CACHE{$cache_key}) { + return $ANON_PACKAGE_CACHE{$cache_key}; + } + } + + my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL; + + my $meta = $class->create($package_name, %options); + + if ($cache_ok) { + $ANON_PACKAGE_CACHE{$cache_key} = $meta; + weaken($ANON_PACKAGE_CACHE{$cache_key}); + } + + return $meta; + } + + sub _anon_cache_key { + my $class = shift; + my %options = @_; + $class->_throw_exception( PackagesAndModulesAreNotCachable => class_name => $class, + params => \%options, + is_module => 0 + ); + } + + sub DESTROY { + my $self = shift; + + return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated + + $self->_free_anon + if $self->is_anon; + } + + sub _free_anon { + my $self = shift; + my $name = $self->name; + + # Moose does a weird thing where it replaces the metaclass for + # class when fixing metaclass incompatibility. In that case, + # we don't want to clean out the namespace now. We can detect + # that because Moose will explicitly update the singleton + # cache in Class::MOP using store_metaclass_by_name, which + # means that the new metaclass will already exist in the cache + # by this point. + # The other options here are that $current_meta can be undef if + # remove_metaclass_by_name is called explicitly (since the hash + # entry is removed first, and then this destructor is called), + # or that $current_meta can be the same as $self, which happens + # when the metaclass goes out of scope (since the weak reference + # in the metaclass cache won't be freed until after this + # destructor runs). + my $current_meta = Class::MOP::get_metaclass_by_name($name); + return if defined($current_meta) && $current_meta ne $self; + + my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/); + + no strict 'refs'; + # clear @ISA first, to avoid a memory leak + # see https://rt.perl.org/rt3/Public/Bug/Display.html?id=92708 + @{$name . '::ISA'} = (); + %{$name . '::'} = (); + delete ${$first_fragments . '::'}{$last_fragment . '::'}; + + Class::MOP::remove_metaclass_by_name($name); + + delete $INC{module_notional_filename($name)}; + } + +} + +sub _new { + my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # Need to quote package to avoid a problem with PPI mis-parsing this + # as a package statement. + 'package' => $params->{package}, + + # NOTE: + # because of issues with the Perl API + # to the typeglob in some versions, we + # need to just always grab a new + # reference to the hash in the accessor. + # Ideally we could just store a ref and + # it would Just Work, but oh well :\ + + namespace => \undef, + + } => $class; +} + +# Attributes + +# NOTE: +# all these attribute readers will be bootstrapped +# away in the Class::MOP bootstrap section + +sub _package_stash { + $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name) +} +sub namespace { + $_[0]->_package_stash->namespace +} + +# Class attributes + +# ... these functions have to touch the symbol table itself,.. yuk + +sub add_package_symbol { + my $self = shift; + $self->_package_stash->add_symbol(@_); +} + +sub remove_package_glob { + my $self = shift; + $self->_package_stash->remove_glob(@_); +} + +# ... these functions deal with stuff on the namespace level + +sub has_package_symbol { + my $self = shift; + $self->_package_stash->has_symbol(@_); +} + +sub get_package_symbol { + my $self = shift; + $self->_package_stash->get_symbol(@_); +} + +sub get_or_add_package_symbol { + my $self = shift; + $self->_package_stash->get_or_add_symbol(@_); +} + +sub remove_package_symbol { + my $self = shift; + $self->_package_stash->remove_symbol(@_); +} + +sub list_all_package_symbols { + my $self = shift; + $self->_package_stash->list_all_symbols(@_); +} + +sub get_all_package_symbols { + my $self = shift; + $self->_package_stash->get_all_symbols(@_); +} + +1; + +# ABSTRACT: Package Meta Object + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::MOP::Package - Package Meta Object + +=head1 VERSION + +version 2.1405 + +=head1 DESCRIPTION + +The Package Protocol provides an abstraction of a Perl 5 package. A +package is basically namespace, and this module provides methods for +looking at and changing that namespace's symbol table. + +=head1 METHODS + +=over 4 + +=item B<< Class::MOP::Package->initialize($package_name, %options) >> + +This method creates a new C<Class::MOP::Package> instance which +represents specified package. If an existing metaclass object exists +for the package, that will be returned instead. No options are valid at the +package level. + +=item B<< Class::MOP::Package->reinitialize($package, %options) >> + +This method forcibly removes any existing metaclass for the package +before calling C<initialize>. In contrast to C<initialize>, you may +also pass an existing C<Class::MOP::Package> instance instead of just +a package name as C<$package>. + +Do not call this unless you know what you are doing. + +=item B<< Class::MOP::Package->create($package, %options) >> + +Creates a new C<Class::MOP::Package> instance which represents the specified +package, and also does some initialization of that package. Currently, this +just does the same thing as C<initialize>, but is overridden in subclasses, +such as C<Class::MOP::Class>. + +=item B<< Class::MOP::Package->create_anon(%options) >> + +Creates a new anonymous package. Valid keys for C<%options> are: + +=over 4 + +=item C<cache> + +If this will be C<true> (the default is C<false>), the instance will be cached +in C<Class::MOP>'s metaclass cache. + +=item C<weaken> + +If this is C<true> (the default C<true> when L<cache> is C<false>), the instance +stored in C<Class::MOP>'s metaclass cache will be weakened, so that the +anonymous package will be garbage collected when the returned instance goes out +of scope. + +=back + +=item B<< $metapackage->is_anon >> + +Returns true if the package is an anonymous package. + +=item B<< $metapackage->name >> + +This is returns the package's name, as passed to the constructor. + +=item B<< $metapackage->namespace >> + +This returns a hash reference to the package's symbol table. The keys +are symbol names and the values are typeglob references. + +=item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >> + +This method accepts a variable name and an optional initial value. The +C<$variable_name> must contain a leading sigil. + +This method creates the variable in the package's symbol table, and +sets it to the initial value if one was provided. + +=item B<< $metapackage->get_package_symbol($variable_name) >> + +Given a variable name, this method returns the variable as a reference +or undef if it does not exist. The C<$variable_name> must contain a +leading sigil. + +=item B<< $metapackage->get_or_add_package_symbol($variable_name) >> + +Given a variable name, this method returns the variable as a reference. +If it does not exist, a default value will be generated if possible. The +C<$variable_name> must contain a leading sigil. + +=item B<< $metapackage->has_package_symbol($variable_name) >> + +Returns true if there is a package variable defined for +C<$variable_name>. The C<$variable_name> must contain a leading sigil. + +=item B<< $metapackage->remove_package_symbol($variable_name) >> + +This will remove the package variable specified C<$variable_name>. The +C<$variable_name> must contain a leading sigil. + +=item B<< $metapackage->remove_package_glob($glob_name) >> + +Given the name of a glob, this will remove that glob from the +package's symbol table. Glob names do not include a sigil. Removing +the glob removes all variables and subroutines with the specified +name. + +=item B<< $metapackage->list_all_package_symbols($type_filter) >> + +This will list all the glob names associated with the current +package. These names do not have leading sigils. + +You can provide an optional type filter, which should be one of +'SCALAR', 'ARRAY', 'HASH', or 'CODE'. + +=item B<< $metapackage->get_all_package_symbols($type_filter) >> + +This works much like C<list_all_package_symbols>, but it returns a +hash reference. The keys are glob names and the values are references +to the value for that name. + +=item B<< Class::MOP::Package->meta >> + +This will return a L<Class::MOP::Class> instance for this class. + +=back + +=head1 AUTHORS + +=over 4 + +=item * + +Stevan Little <stevan.little@iinteractive.com> + +=item * + +Dave Rolsky <autarch@urth.org> + +=item * + +Jesse Luehrs <doy@tozt.net> + +=item * + +Shawn M Moore <code@sartak.org> + +=item * + +יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> + +=item * + +Karen Etheridge <ether@cpan.org> + +=item * + +Florian Ragwitz <rafl@debian.org> + +=item * + +Hans Dieter Pearcey <hdp@weftsoar.net> + +=item * + +Chris Prather <chris@prather.org> + +=item * + +Matt S Trout <mst@shadowcat.co.uk> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by Infinity Interactive, Inc.. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut |