r61944 - in /branches/upstream/libclass-mop-perl/current: ./ lib/ lib/Class/ lib/Class/MOP/ lib/Class/MOP/Class/Immutable/ lib/Class/MOP/Method/ lib/Class/MOP/Mixin/ t/
angelabad-guest at users.alioth.debian.org
angelabad-guest at users.alioth.debian.org
Mon Aug 23 21:06:23 UTC 2010
Author: angelabad-guest
Date: Mon Aug 23 21:06:03 2010
New Revision: 61944
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=61944
Log:
[svn-upgrade] new version libclass-mop-perl (1.06)
Added:
branches/upstream/libclass-mop-perl/current/t/316_numeric_defaults.t (with props)
Modified:
branches/upstream/libclass-mop-perl/current/Changes
branches/upstream/libclass-mop-perl/current/MANIFEST
branches/upstream/libclass-mop-perl/current/META.yml
branches/upstream/libclass-mop-perl/current/README
branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Attribute.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class/Immutable/Trait.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Deprecated.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Instance.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Accessor.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Constructor.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Generated.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Inlined.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Wrapped.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/AttributeCore.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasAttributes.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasMethods.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Module.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Object.pm
branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm
branches/upstream/libclass-mop-perl/current/lib/metaclass.pm
branches/upstream/libclass-mop-perl/current/t/003_methods.t
branches/upstream/libclass-mop-perl/current/t/021_attribute_errors_and_edge_cases.t
Modified: branches/upstream/libclass-mop-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/Changes?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/Changes (original)
+++ branches/upstream/libclass-mop-perl/current/Changes Mon Aug 23 21:06:03 2010
@@ -1,4 +1,23 @@
Revision history for Perl extension Class-MOP.
+
+1.06 Sun, Aug 23, 2010
+
+ [BUG FIXES]
+
+ * Version 1.05 no longer reported constants as methods, except with Perl
+ 5.8.x, and doing so in 5.8.x caused test failures. Constants are now
+ _expected_ to be reported as methods, and this is tested for
+ explicit. (Dave Rolsky)
+
+
+1.05 Sun, Aug 22, 2010
+
+ [ENHANCEMENTS]
+
+ * Refactorings and improvements to how defaults are handled, particularly
+ for inlined code (doy).
+
+ * Optimizations that should help speed up compilation time (Dave Rolsky).
1.04 Tue, Jul 25, 2010
@@ -9,7 +28,7 @@
package, which cuts down on noise. When importing Class::MOP::Deprecated,
the request API version should now be passed in the "-api_version"
flag. However, the old "-compatible" flag will continue to work. (Dave
- Rolsky).
+ Rolsky)
1.03 Sat, Jun 5, 2010
Modified: branches/upstream/libclass-mop-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/MANIFEST?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/MANIFEST (original)
+++ branches/upstream/libclass-mop-perl/current/MANIFEST Mon Aug 23 21:06:03 2010
@@ -123,6 +123,7 @@
t/313_before_after_dollar_under.t
t/314_class_is_pristine.t
t/315_magic.t
+t/316_numeric_defaults.t
t/500_deprecated.t
t/lib/BinaryTree.pm
t/lib/MyMetaClass.pm
Modified: branches/upstream/libclass-mop-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/META.yml?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/META.yml (original)
+++ branches/upstream/libclass-mop-perl/current/META.yml Mon Aug 23 21:06:03 2010
@@ -38,5 +38,5 @@
resources:
license: http://dev.perl.org/licenses/
repository: git://git.moose.perl.org/Class-MOP.git
-version: 1.04
+version: 1.06
x_authority: cpan:STEVAN
Modified: branches/upstream/libclass-mop-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/README?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/README (original)
+++ branches/upstream/libclass-mop-perl/current/README Mon Aug 23 21:06:03 2010
@@ -1,4 +1,4 @@
-Class::MOP version 1.04
+Class::MOP version 1.06
===========================
See the individual module documentation for more information
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP.pm Mon Aug 23 21:06:03 2010
@@ -29,14 +29,13 @@
*check_package_cache_flag = \&mro::get_pkg_gen;
}
-our $VERSION = '1.04';
+our $VERSION = '1.06';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
require XSLoader;
XSLoader::load( __PACKAGE__, $XS_VERSION );
-
{
# Metaclasses are singletons, so we cache them here.
@@ -549,13 +548,6 @@
))
);
-Class::MOP::Method->meta->add_method('clone' => sub {
- my $self = shift;
- my $clone = $self->meta->clone_object($self, @_);
- $clone->_set_original_method($self);
- return $clone;
-});
-
## --------------------------------------------------------
## Class::MOP::Method::Wrapped
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Attribute.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Attribute.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Attribute.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Attribute.pm Mon Aug 23 21:06:03 2010
@@ -10,7 +10,7 @@
use Scalar::Util 'blessed', 'weaken';
use Try::Tiny;
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -73,7 +73,9 @@
'clearer' => $options->{clearer},
'builder' => $options->{builder},
'init_arg' => $options->{init_arg},
- 'default' => $options->{default},
+ exists $options->{default}
+ ? ('default' => $options->{default})
+ : (),
'initializer' => $options->{initializer},
'definition_context' => $options->{definition_context},
# keep a weakened link to the
@@ -117,7 +119,7 @@
$params->{$init_arg},
);
}
- elsif (defined $self->{'default'}) {
+ elsif (exists $self->{'default'}) {
$self->_set_initial_slot_value(
$meta_instance,
$instance,
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class.pm Mon Aug 23 21:06:03 2010
@@ -16,7 +16,7 @@
use Try::Tiny;
use List::MoreUtils 'all';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -190,29 +190,31 @@
sub _check_metaclass_compatibility {
my $self = shift;
- if (my @superclasses = $self->superclasses) {
- $self->_fix_metaclass_incompatibility(@superclasses);
-
- my %base_metaclass = $self->_base_metaclasses;
-
- # this is always okay ...
- return if ref($self) eq 'Class::MOP::Class'
+ 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;
-
+ !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_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
- );
- }
+ $self->_check_single_metaclass_compatibility( $metaclass_type,
+ $superclass );
}
}
}
@@ -760,10 +762,13 @@
sub superclasses {
my $self = shift;
- my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
+
+ my $isa = $self->get_package_symbol(
+ { sigil => '@', type => 'ARRAY', name => 'ISA' } );
+
if (@_) {
my @supers = @_;
- @{$self->get_package_symbol($var_spec)} = @supers;
+ @{$isa} = @supers;
# NOTE:
# on 5.8 and below, we need to call
@@ -782,7 +787,8 @@
$self->_check_metaclass_compatibility();
$self->_superclasses_updated();
}
- @{$self->get_package_symbol($var_spec)};
+
+ return @{$isa};
}
sub _superclasses_updated {
@@ -942,8 +948,7 @@
for my $class ( reverse $self->linearized_isa ) {
my $meta = Class::MOP::Class->initialize($class);
- $methods{$_} = $meta->get_method($_)
- for $meta->get_method_list;
+ $methods{ $_->name } = $_ for $meta->_get_local_methods;
}
return values %methods;
@@ -1706,7 +1711,8 @@
=item B<< $metaclass->get_attribute_list >>
This will return a list of attributes I<names> for all attributes
-defined in this class.
+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 >>
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class/Immutable/Trait.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class/Immutable/Trait.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class/Immutable/Trait.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Class/Immutable/Trait.pm Mon Aug 23 21:06:03 2010
@@ -8,7 +8,7 @@
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Deprecated.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Deprecated.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Deprecated.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Deprecated.pm Mon Aug 23 21:06:03 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Instance.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Instance.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Instance.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Instance.pm Mon Aug 23 21:06:03 2010
@@ -6,7 +6,7 @@
use Scalar::Util 'weaken', 'blessed';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method.pm Mon Aug 23 21:06:03 2010
@@ -7,7 +7,7 @@
use Carp 'confess';
use Scalar::Util 'weaken', 'reftype', 'blessed';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -123,11 +123,19 @@
$self->body->(@_);
}
-# NOTE:
-# the Class::MOP bootstrap
-# will create this for us
-# - SL
-# sub clone { ... }
+# 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);
+
+ $clone->_set_original_method($self);
+
+ return $clone;
+}
1;
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Accessor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Accessor.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Accessor.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Accessor.pm Mon Aug 23 21:06:03 2010
@@ -7,7 +7,7 @@
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Constructor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Constructor.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Constructor.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Constructor.pm Mon Aug 23 21:06:03 2010
@@ -5,9 +5,9 @@
use warnings;
use Carp 'confess';
-use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
-
-our $VERSION = '1.04';
+use Scalar::Util 'blessed', 'weaken';
+
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -100,7 +100,11 @@
sub _generate_constructor_method_inline {
my $self = shift;
- my $close_over = {};
+ my $defaults = [map { $_->default } @{ $self->_attributes }];
+
+ my $close_over = {
+ '$defaults' => \$defaults,
+ };
my $source = 'sub {';
$source .= "\n" . 'my $class = shift;';
@@ -111,8 +115,9 @@
$source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
$source .= "\n" . 'my $instance = ' . $self->_meta_instance->inline_create_instance('$class');
+ my $idx = 0;
$source .= ";\n" . (join ";\n" => map {
- $self->_generate_slot_initializer($_, $close_over)
+ $self->_generate_slot_initializer($_, $idx++)
} @{ $self->_attributes });
$source .= ";\n" . 'return $instance';
$source .= ";\n" . '}';
@@ -130,54 +135,68 @@
sub _generate_slot_initializer {
my $self = shift;
my $attr = shift;
- my $close = shift;
+ my $idx = shift;
my $default;
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) {
- my $idx = @{$close->{'@defaults'}||=[]};
- push(@{$close->{'@defaults'}}, $attr->default);
- $default = '$defaults[' . $idx . ']->($instance)';
- }
- else {
- $default = $attr->default;
- # make sure to quote strings ...
- unless (looks_like_number($default)) {
- $default = "'$default'";
- }
- }
+ $default = $self->_generate_default_value($attr, $idx);
} elsif( $attr->has_builder ) {
$default = '$instance->'.$attr->builder;
}
- if ( defined(my $init_arg = $attr->init_arg) ) {
- return (
- 'if(exists $params->{\'' . $init_arg . '\'}){' . "\n" .
- $self->_meta_instance->inline_set_slot_value(
+ if ( defined( my $init_arg = $attr->init_arg ) ) {
+ my $mi = $self->_meta_instance;
+ my $attr_name = $attr->name;
+
+ return (
+ 'if(exists $params->{\''
+ . $init_arg . '\'}){' . "\n"
+ . $mi->inline_set_slot_value(
+ '$instance',
+ $attr_name,
+ '$params->{\'' . $init_arg . '\'}'
+ )
+ . "\n" . '} '
+ . (
+ !defined $default ? '' : 'else {' . "\n"
+ . $mi->inline_set_slot_value(
'$instance',
- $attr->name,
- '$params->{\'' . $init_arg . '\'}' ) . "\n" .
- '} ' . (!defined $default ? '' : 'else {' . "\n" .
- $self->_meta_instance->inline_set_slot_value(
- '$instance',
- $attr->name,
- $default ) . "\n" .
- '}')
+ $attr_name,
+ $default
+ )
+ . "\n" . '}'
+ )
);
- } elsif ( defined $default ) {
+ }
+ elsif ( defined $default ) {
return (
$self->_meta_instance->inline_set_slot_value(
'$instance',
$attr->name,
- $default ) . "\n"
+ $default
+ )
+ . "\n"
);
- } else { return '' }
+ }
+ else {
+ return '';
+ }
+}
+
+sub _generate_default_value {
+ my ($self, $attr, $index) = @_;
+ # 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 . ']';
+ }
}
1;
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Generated.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Generated.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Generated.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Generated.pm Mon Aug 23 21:06:03 2010
@@ -6,7 +6,7 @@
use Carp 'confess';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Inlined.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Inlined.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Inlined.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Inlined.pm Mon Aug 23 21:06:03 2010
@@ -6,7 +6,7 @@
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Wrapped.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Wrapped.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Wrapped.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Method/Wrapped.pm Mon Aug 23 21:06:03 2010
@@ -7,7 +7,7 @@
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin.pm Mon Aug 23 21:06:03 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/AttributeCore.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/AttributeCore.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/AttributeCore.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/AttributeCore.pm Mon Aug 23 21:06:03 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -18,7 +18,7 @@
sub has_clearer { defined $_[0]->{'clearer'} }
sub has_builder { defined $_[0]->{'builder'} }
sub has_init_arg { defined $_[0]->{'init_arg'} }
-sub has_default { defined $_[0]->{'default'} }
+sub has_default { exists $_[0]->{'default'} }
sub has_initializer { defined $_[0]->{'initializer'} }
sub has_insertion_order { defined $_[0]->{'insertion_order'} }
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasAttributes.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasAttributes.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasAttributes.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasAttributes.pm Mon Aug 23 21:06:03 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasMethods.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasMethods.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasMethods.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Mixin/HasMethods.pm Mon Aug 23 21:06:03 2010
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
@@ -39,12 +39,14 @@
( defined $method_name && length $method_name )
|| confess "You must define a method name";
+ my $package_name = $self->name;
+
my $body;
if ( blessed($method) ) {
$body = $method->body;
- if ( $method->package_name ne $self->name ) {
+ if ( $method->package_name ne $package_name ) {
$method = $method->clone(
- package_name => $self->name,
+ package_name => $package_name,
name => $method_name,
) if $method->can('clone');
}
@@ -62,7 +64,7 @@
my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
if ( !defined $current_name || $current_name =~ /^__ANON__/ ) {
- my $full_method_name = ( $self->name . '::' . $method_name );
+ my $full_method_name = ( $package_name . '::' . $method_name );
subname( $full_method_name => $body );
}
@@ -87,7 +89,7 @@
( defined $method_name && length $method_name )
|| confess "You must define a method name";
- return defined( $self->get_method($method_name) );
+ return defined( $self->_get_maybe_raw_method($method_name) );
}
sub get_method {
@@ -95,6 +97,21 @@
( defined $method_name && length $method_name )
|| confess "You must define a method name";
+
+ my $method = $self->_get_maybe_raw_method($method_name)
+ or return;
+
+ return $method if blessed $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 $method_map = $self->_method_map;
my $map_entry = $method_map->{$method_name};
@@ -106,25 +123,18 @@
}
);
- # This seems to happen in some weird cases where methods modifiers are
- # added via roles or some other such bizareness. Honestly, I don't totally
- # understand this, but returning the entry works, and keeps various MX
- # modules from blowing up. - DR
- return $map_entry if blessed $map_entry && !$code;
-
- return $map_entry if blessed $map_entry && $map_entry->body == $code;
+ # The !$code case seems to happen in some weird cases where methods
+ # modifiers are added via roles or some other such bizareness. Honestly, I
+ # don't totally understand this, but returning the entry works, and keeps
+ # various MX modules from blowing up. - DR
+ return $map_entry
+ if blessed $map_entry && ( !$code || $map_entry->body == $code );
unless ($map_entry) {
return unless $code && $self->_code_is_mine($code);
}
- $code ||= $map_entry;
-
- return $method_map->{$method_name} = $self->wrap_method_body(
- body => $code,
- name => $method_name,
- associated_metaclass => $self,
- );
+ return $code;
}
sub remove_method {
@@ -148,7 +158,29 @@
sub get_method_list {
my $self = shift;
- return grep { $self->has_method($_) } keys %{ $self->namespace };
+
+ my $namespace = $self->namespace;
+
+ # Constants will show up as some sort of reference in the namespace hash
+ # ref.
+ return grep {
+ ( ref $namespace->{$_} || *{ $namespace->{$_} }{CODE} )
+ && $self->has_method($_)
+ }
+ keys %{$namespace};
+}
+
+# This should probably be what get_method_list actually does, instead of just
+# returning names. This was created as a much faster alternative to
+# $meta->get_method($_) for $meta->get_method_list
+sub _get_local_methods {
+ my $self = shift;
+
+ my $namespace = $self->namespace;
+
+ return map { $self->get_method($_) }
+ grep { ref $namespace->{$_} || *{ $namespace->{$_} }{CODE} }
+ keys %{$namespace};
}
1;
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Module.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Module.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Module.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Module.pm Mon Aug 23 21:06:03 2010
@@ -7,7 +7,7 @@
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Object.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Object.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Object.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Object.pm Mon Aug 23 21:06:03 2010
@@ -6,7 +6,7 @@
use Scalar::Util 'blessed';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/Class/MOP/Package.pm Mon Aug 23 21:06:03 2010
@@ -8,7 +8,7 @@
use Carp 'confess';
use Package::Stash;
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/lib/metaclass.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/lib/metaclass.pm?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/lib/metaclass.pm (original)
+++ branches/upstream/libclass-mop-perl/current/lib/metaclass.pm Mon Aug 23 21:06:03 2010
@@ -7,7 +7,7 @@
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '1.04';
+our $VERSION = '1.06';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
Modified: branches/upstream/libclass-mop-perl/current/t/003_methods.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/003_methods.t?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/003_methods.t (original)
+++ branches/upstream/libclass-mop-perl/current/t/003_methods.t Mon Aug 23 21:06:03 2010
@@ -352,4 +352,31 @@
}
}
+{
+ package HasConstants;
+
+ use constant FOO => 1;
+ use constant BAR => [];
+ use constant BAZ => {};
+ use constant UNDEF => undef;
+
+ sub quux {1}
+ sub thing {1}
+}
+
+my $HC = Class::MOP::Class->initialize('HasConstants');
+
+is_deeply(
+ [ sort $HC->get_method_list ],
+ [qw( BAR BAZ FOO UNDEF quux thing )],
+ 'get_method_list handles constants properly'
+);
+
+is_deeply(
+ [ sort map { $_->name } $HC->_get_local_methods ],
+ [qw( BAR BAZ FOO UNDEF quux thing )],
+ '_get_local_methods handles constants properly'
+);
+
+
done_testing;
Modified: branches/upstream/libclass-mop-perl/current/t/021_attribute_errors_and_edge_cases.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/021_attribute_errors_and_edge_cases.t?rev=61944&op=diff
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/021_attribute_errors_and_edge_cases.t (original)
+++ branches/upstream/libclass-mop-perl/current/t/021_attribute_errors_and_edge_cases.t Mon Aug 23 21:06:03 2010
@@ -80,6 +80,34 @@
builder => 'Foo', default => 'Foo'
));
} '... no default AND builder';
+
+ my $undef_attr;
+ lives_ok {
+ $undef_attr = Class::MOP::Attribute->new('$test' => (
+ default => undef,
+ predicate => 'has_test',
+ ));
+ } '... undef as a default is okay';
+ ok($undef_attr->has_default, '... and it counts as an actual default');
+ ok(!Class::MOP::Attribute->new('$test')->has_default,
+ '... but attributes with no default have no default');
+
+ Class::MOP::Class->create(
+ 'Foo',
+ attributes => [$undef_attr],
+ );
+ {
+ my $obj = Foo->meta->new_object;
+ ok($obj->has_test, '... and the default is populated');
+ is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value');
+ }
+ lives_ok { Foo->meta->make_immutable }
+ '... and it can be inlined';
+ {
+ my $obj = Foo->new;
+ ok($obj->has_test, '... and the default is populated');
+ is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value');
+ }
}
Added: branches/upstream/libclass-mop-perl/current/t/316_numeric_defaults.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-mop-perl/current/t/316_numeric_defaults.t?rev=61944&op=file
==============================================================================
--- branches/upstream/libclass-mop-perl/current/t/316_numeric_defaults.t (added)
+++ branches/upstream/libclass-mop-perl/current/t/316_numeric_defaults.t Mon Aug 23 21:06:03 2010
@@ -1,0 +1,125 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use B;
+use Class::MOP;
+
+my @int_defaults = (
+ 100,
+ -2,
+ 01234,
+ 0xFF,
+);
+
+my @num_defaults = (
+ 10.5,
+ -20.0,
+ 1e3,
+ 1.3e-10,
+);
+
+my @string_defaults = (
+ 'foo',
+ '',
+ '100',
+ '10.5',
+ '1e3',
+ '0 but true',
+ '01234',
+ '09876',
+ '0xFF',
+);
+
+for my $default (@int_defaults) {
+ my $copy = $default; # so we can print it out without modifying flags
+ my $attr = Class::MOP::Attribute->new(
+ foo => (default => $default, reader => 'foo'),
+ );
+ my $meta = Class::MOP::Class->create_anon_class(
+ attributes => [$attr],
+ methods => {bar => sub { $default }},
+ );
+
+ my $obj = $meta->new_object;
+ for my $meth (qw(foo bar)) {
+ my $val = $obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy)");
+ ok(!($flags & B::SVf_POK), "not a string ($copy)");
+ }
+
+ $meta->make_immutable;
+
+ my $immutable_obj = $meta->name->new;
+ for my $meth (qw(foo bar)) {
+ my $val = $immutable_obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy) (immutable)");
+ ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)");
+ }
+}
+
+for my $default (@num_defaults) {
+ my $copy = $default; # so we can print it out without modifying flags
+ my $attr = Class::MOP::Attribute->new(
+ foo => (default => $default, reader => 'foo'),
+ );
+ my $meta = Class::MOP::Class->create_anon_class(
+ attributes => [$attr],
+ methods => {bar => sub { $default }},
+ );
+
+ my $obj = $meta->new_object;
+ for my $meth (qw(foo bar)) {
+ my $val = $obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy)");
+ ok(!($flags & B::SVf_POK), "not a string ($copy)");
+ }
+
+ $meta->make_immutable;
+
+ my $immutable_obj = $meta->name->new;
+ for my $meth (qw(foo bar)) {
+ my $val = $immutable_obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy) (immutable)");
+ ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)");
+ }
+}
+
+for my $default (@string_defaults) {
+ my $copy = $default; # so we can print it out without modifying flags
+ my $attr = Class::MOP::Attribute->new(
+ foo => (default => $default, reader => 'foo'),
+ );
+ my $meta = Class::MOP::Class->create_anon_class(
+ attributes => [$attr],
+ methods => {bar => sub { $default }},
+ );
+
+ my $obj = $meta->new_object;
+ for my $meth (qw(foo bar)) {
+ my $val = $obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_POK, "it's a string ($copy)");
+ }
+
+ $meta->make_immutable;
+
+ my $immutable_obj = $meta->name->new;
+ for my $meth (qw(foo bar)) {
+ my $val = $immutable_obj->$meth;
+ my $b = B::svref_2object(\$val);
+ my $flags = $b->FLAGS;
+ ok($flags & B::SVf_POK, "it's a string ($copy) (immutable)");
+ }
+}
+
+done_testing;
Propchange: branches/upstream/libclass-mop-perl/current/t/316_numeric_defaults.t
------------------------------------------------------------------------------
svn:executable = *
More information about the Pkg-perl-cvs-commits
mailing list