X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=f68ed297c3b6452361ad0d0872b9d05f408e4b66;hb=a007159dcf8bc57e8ca504cd49e0b6034962b6b8;hp=8ca431d783bf9ca038aad9324ce052939eeef350;hpb=c1d5345a2dedc909590256182a1e77ea5f1566ef;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 8ca431d..f68ed29 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -4,8 +4,10 @@ package Class::MOP; use strict; use warnings; -use Carp 'confess'; -use Scalar::Util 'weaken'; +use MRO::Compat; + +use Carp 'confess'; +use Scalar::Util 'weaken'; use Class::MOP::Class; use Class::MOP::Attribute; @@ -14,20 +16,85 @@ use Class::MOP::Method; use Class::MOP::Immutable; BEGIN { - our $VERSION = '0.51'; + + our $VERSION = '0.64'; our $AUTHORITY = 'cpan:STEVAN'; - use XSLoader; - XSLoader::load( 'Class::MOP', $VERSION ); + *IS_RUNNING_ON_5_10 = ($] < 5.009_005) + ? sub () { 0 } + : sub () { 1 }; + + # NOTE: + # we may not use this yet, but once + # the get_code_info XS gets merged + # upstream to it, we will always use + # it. But for now it is just kinda + # extra overhead. + # - SL + require Sub::Identify; + + # stash these for a sec, and see how things go + my $_PP_subname = sub { $_[1] }; + my $_PP_get_code_info = \&Sub::Identify::get_code_info; - unless ($] < 5.009_005) { - require mro; - no warnings 'redefine', 'prototype'; - *check_package_cache_flag = \&mro::get_pkg_gen; - *IS_RUNNING_ON_5_10 = sub () { 1 }; + if ($ENV{CLASS_MOP_NO_XS}) { + # NOTE: + # this is if you really want things + # to be slow, then you can force the + # no-XS rule this way, otherwise we + # make an effort to load as much of + # the XS as possible. + # - SL + no warnings 'prototype', 'redefine'; + + unless (IS_RUNNING_ON_5_10()) { + # get this from MRO::Compat ... + *check_package_cache_flag = \&MRO::Compat::__get_pkg_gen_pp; + } + else { + # NOTE: + # but if we are running 5.10 + # there is no need to use the + # Pure Perl version since we + # can use the built in mro + # version instead. + # - SL + *check_package_cache_flag = \&mro::get_pkg_gen; + } + # our own version of Sub::Name + *subname = $_PP_subname; + # and the Sub::Identify version of the get_code_info + *get_code_info = $_PP_get_code_info; } else { - *IS_RUNNING_ON_5_10 = sub () { 0 }; + # now try our best to get as much + # of the XS loaded as possible + { + local $@; + eval { + require XSLoader; + XSLoader::load( 'Class::MOP', $VERSION ); + }; + die $@ if $@ && $@ !~ /object version|loadable object/; + + # okay, so the XS failed to load, so + # use the pure perl one instead. + *get_code_info = $_PP_get_code_info if $@; + } + + # get it from MRO::Compat + *check_package_cache_flag = \&mro::get_pkg_gen; + + # now try and load the Sub::Name + # module and use that as a means + # for naming our CVs, if not, we + # use the workaround instead. + if ( eval { require Sub::Name } ) { + *subname = \&Sub::Name::subname; + } + else { + *subname = $_PP_subname; + } } } @@ -58,29 +125,65 @@ BEGIN { sub load_class { my $class = shift; - # see if this is already - # loaded in the symbol table - return 1 if is_class_loaded($class); - # otherwise require it ... - my $file = $class . '.pm'; - $file =~ s{::}{/}g; - eval { CORE::require($file) }; - confess "Could not load class ($class) because : $@" if $@; + + if (ref($class) || !defined($class) || !length($class)) { + my $display = defined($class) ? $class : 'undef'; + confess "Invalid class name ($display)"; + } + + # if the class is not already loaded in the symbol table.. + unless (is_class_loaded($class)) { + # require it + my $file = $class . '.pm'; + $file =~ s{::}{/}g; + eval { CORE::require($file) }; + confess "Could not load class ($class) because : $@" if $@; + } + + # initialize a metaclass if necessary unless (does_metaclass_exist($class)) { eval { Class::MOP::Class->initialize($class) }; confess "Could not initialize class ($class) because : $@" if $@; } - 1; # return true if it worked + + return get_metaclass_by_name($class); } sub is_class_loaded { my $class = shift; - no strict 'refs'; - return 1 if defined ${"${class}::VERSION"} || defined @{"${class}::ISA"}; - foreach (keys %{"${class}::"}) { - next if substr($_, -2, 2) eq '::'; - return 1 if defined &{"${class}::$_"}; + + return 0 if ref($class) || !defined($class) || !length($class); + + # walk the symbol table tree to avoid autovififying + # \*{${main::}{"Foo::"}} == \*main::Foo:: + + my $pack = \*::; + foreach my $part (split('::', $class)) { + return 0 unless exists ${$$pack}{"${part}::"}; + $pack = \*{${$$pack}{"${part}::"}}; + } + + # check for $VERSION or @ISA + return 1 if exists ${$$pack}{VERSION} + && defined *{${$$pack}{VERSION}}{SCALAR}; + return 1 if exists ${$$pack}{ISA} + && defined *{${$$pack}{ISA}}{ARRAY}; + + # check for any method + foreach ( keys %{$$pack} ) { + next if substr($_, -2, 2) eq '::'; + + my $glob = ${$$pack}{$_} || next; + + # constant subs + if ( IS_RUNNING_ON_5_10 ) { + return 1 if ref $glob eq 'SCALAR'; + } + + return 1 if defined *{$glob}{CODE}; } + + # fail return 0; } @@ -135,9 +238,7 @@ Class::MOP::Package->meta->add_attribute( # rather than re-produce it here 'namespace' => \&Class::MOP::Package::namespace }, - # NOTE: - # protect this from silliness - init_arg => '!............( DO NOT DO THIS )............!', + init_arg => undef, default => sub { \undef } )) ); @@ -172,9 +273,7 @@ Class::MOP::Module->meta->add_attribute( # rather than re-produce it here 'version' => \&Class::MOP::Module::version }, - # NOTE: - # protect this from silliness - init_arg => '!............( DO NOT DO THIS )............!', + init_arg => undef, default => sub { \undef } )) ); @@ -193,9 +292,7 @@ Class::MOP::Module->meta->add_attribute( # rather than re-produce it here 'authority' => \&Class::MOP::Module::authority }, - # NOTE: - # protect this from silliness - init_arg => '!............( DO NOT DO THIS )............!', + init_arg => undef, default => sub { \undef } )) ); @@ -240,9 +337,7 @@ Class::MOP::Class->meta->add_attribute( # rather than re-produce it here 'superclasses' => \&Class::MOP::Class::superclasses }, - # NOTE: - # protect this from silliness - init_arg => '!............( DO NOT DO THIS )............!', + init_arg => undef, default => sub { \undef } )) ); @@ -345,6 +440,14 @@ Class::MOP::Attribute->meta->add_attribute( ); Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('$!initializer' => ( + init_arg => 'initializer', + reader => { 'initializer' => \&Class::MOP::Attribute::initializer }, + predicate => { 'has_initializer' => \&Class::MOP::Attribute::has_initializer }, + )) +); + +Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('$!writer' => ( init_arg => 'writer', reader => { 'writer' => \&Class::MOP::Attribute::writer }, @@ -423,7 +526,7 @@ Class::MOP::Attribute->meta->add_method('new' => sub { } else { (Class::MOP::Attribute::is_default_a_coderef(\%options)) || confess("References are not allowed as default values, you must ". - "wrap then in a CODE reference (ex: sub { [] } and not [])") + "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])") if exists $options{default} && ref $options{default}; } # return the new object @@ -445,6 +548,40 @@ Class::MOP::Method->meta->add_attribute( )) ); +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('$!package_name' => ( + init_arg => 'package_name', + reader => { 'package_name' => \&Class::MOP::Method::package_name }, + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('$!name' => ( + init_arg => 'name', + reader => { 'name' => \&Class::MOP::Method::name }, + )) +); + +Class::MOP::Method->meta->add_method('wrap' => sub { + my $class = shift; + my $code = shift; + my %options = @_; + + ('CODE' eq ref($code)) + || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")"; + + ($options{package_name} && $options{name}) + || confess "You must supply the package_name and name parameters"; + + # return the new object + $class->meta->new_object(body => $code, %options); +}); + +Class::MOP::Method->meta->add_method('clone' => sub { + my $self = shift; + $self->meta->clone_object($self, @_); +}); + ## -------------------------------------------------------- ## Class::MOP::Method::Wrapped @@ -464,9 +601,19 @@ Class::MOP::Method::Generated->meta->add_attribute( Class::MOP::Attribute->new('$!is_inline' => ( init_arg => 'is_inline', reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline }, + default => 0, )) ); +Class::MOP::Method::Generated->meta->add_method('new' => sub { + my ($class, %options) = @_; + ($options{package_name} && $options{name}) + || confess "You must supply the package_name and name parameters"; + my $self = $class->meta->new_object(%options); + $self->initialize_body; + $self; +}); + ## -------------------------------------------------------- ## Class::MOP::Method::Accessor @@ -486,6 +633,35 @@ Class::MOP::Method::Accessor->meta->add_attribute( )) ); +Class::MOP::Method::Accessor->meta->add_method('new' => sub { + my $class = shift; + my %options = @_; + + (exists $options{attribute}) + || confess "You must supply an attribute to construct with"; + + (exists $options{accessor_type}) + || confess "You must supply an accessor_type to construct with"; + + (Scalar::Util::blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) + || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; + + ($options{package_name} && $options{name}) + || confess "You must supply the package_name and name parameters"; + + # return the new object + my $self = $class->meta->new_object(%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + Scalar::Util::weaken($self->{'$!attribute'}); + + $self->initialize_body; + + $self; +}); + ## -------------------------------------------------------- ## Class::MOP::Method::Constructor @@ -496,6 +672,7 @@ Class::MOP::Method::Constructor->meta->add_attribute( reader => { 'options' => \&Class::MOP::Method::Constructor::options }, + default => sub { +{} } )) ); @@ -508,6 +685,30 @@ Class::MOP::Method::Constructor->meta->add_attribute( )) ); +Class::MOP::Method::Constructor->meta->add_method('new' => sub { + my $class = shift; + my %options = @_; + + (Scalar::Util::blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class')) + || confess "You must pass a metaclass instance if you want to inline" + if $options{is_inline}; + + ($options{package_name} && $options{name}) + || confess "You must supply the package_name and name parameters"; + + # return the new object + my $self = $class->meta->new_object(%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + Scalar::Util::weaken($self->{'$!associated_metaclass'}); + + $self->initialize_body; + + $self; +}); + ## -------------------------------------------------------- ## Class::MOP::Instance @@ -566,7 +767,7 @@ Class::MOP - A Meta Object Protocol for Perl 5 =head1 DESCRIPTON -This module is an attempt to create a meta object protocol for the +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. @@ -694,7 +895,7 @@ programming. So in other words, don't worry about it. =head1 PROTOCOLS -The protocol is divided into 3 main sub-protocols: +The protocol is divided into 4 main sub-protocols: =over 4 @@ -710,7 +911,7 @@ See L for more details. This provides a consistent represenation for an attribute of a Perl 5 class. Since there are so many ways to create and handle -atttributes in Perl 5 OO, this attempts to provide as much of a +attributes in Perl 5 OO, this attempts to provide as much of a unified approach as possible, while giving the freedom and flexibility to subclass for specialization. @@ -725,6 +926,16 @@ making it possible to extend the system in many ways. See L for more details. +=item 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 ref to other +types of references. Several examples are provided in the F +directory included in this distribution. + +See L for more details. + =back =head1 FUNCTIONS @@ -749,6 +960,8 @@ compat. This will load a given C<$class_name> and if it does not have an already initialized metaclass, then it will intialize one for it. +This function can be used in place of tricks like +C or using C. =item B @@ -761,8 +974,27 @@ is probably correct about 99% of the time. =item B +This will return an integer that is managed by C +to determine if a module's symbol table has been altered. + +In Perl 5.10 or greater, this flag is package specific. However in +versions prior to 5.10, this will use the C variable +which is not package specific. + =item B +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 detemine where a given C<$code> reference is from. + +=item B + +B + +If possible, we will load the L module and this will function +as C does, otherwise it will just return the C<$code> +argument. + =back =head2 Metaclass cache functions @@ -791,14 +1023,28 @@ been cached by B. =item B +This will return a cached B instance of nothing +if no metaclass exist by that C<$name>. + =item B +This will store a metaclass in the cache at the supplied C<$key>. + =item B +In rare cases it is desireable to store a weakened reference in +the metaclass cache. This function will weaken the reference to +the metaclass stored in C<$name>. + =item B +This will return true of there exists a metaclass stored in the +C<$name> key and return false otherwise. + =item B +This will remove a the metaclass stored in the C<$name> key. + =back =head1 SEE ALSO