r1064@mbp: claco | 2007-12-28 18:18:25 -0500

 Working around @_ assigment bug in 5.10.0 that kills performace
 Tweaked code for speed over form. No functional changes.

diff --git a/Changes b/Changes
index 6d1aa8d..cf337dc 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 Revision history for Class::Accessor::Grouped.
 
+0.07009_01 Fri Dec 28 18:08::00 2007
+    - Tweak code for pure speed while fixing performance issue when assigning @_
+    under Perl 5.10.0
+
 0.07000 
     - Altered get_inherited to return undef rather than () when no value
         set for Class::Data::(Inheritable|Accessor) compatiblity

diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
index e01f9fb..00810ee 100644 (file)
--- a/MANIFEST.SKIP
+++ b/MANIFEST.SKIP
@@ -8,6 +8,7 @@
 aegis.log$
 \bconfig$
 \bbuild$
+\.DS_Store$
 
 # Avoid Makemaker generated and utility files.
 \bMakefile$

diff --git a/README b/README
index 77cd081..df32090 100644 (file)
--- a/README
+++ b/README
@@ -17,6 +17,10 @@ METHODS
     they will call get_$group($field) on get and set_$group($field, $value)
     on set.
 
+    If you want to mimic Class::Accessor's mk_accessors $group has to be
+    'simple' to tell Class::Accessor::Grouped to use its own get_simple and
+    set_simple methods.
+
     @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
     this is used as both field and accessor name, if a listref it is
     expected to be of the form [ $accessor, $field ].

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index 933c687..caf7181 100644 (file)
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -1,14 +1,12 @@
 package Class::Accessor::Grouped;
 use strict;
 use warnings;
-use Carp;
+use Carp ();
 use Class::Inspector ();
-use Scalar::Util qw/reftype blessed/;
+use Scalar::Util ();
 use MRO::Compat;
 
-use vars qw($VERSION);
-
-$VERSION = '0.07000';
+our $VERSION = '0.07999_01';
 
 =head1 NAME
 
@@ -62,14 +60,14 @@ sub mk_group_accessors {
 
     sub _mk_group_accessors {
         my($self, $maker, $group, @fields) = @_;
-        my $class = blessed $self || $self;
+        my $class = Scalar::Util::blessed $self || $self;
 
         # So we don't have to do lots of lookups inside the loop.
         $maker = $self->can($maker) unless ref $maker;
 
         foreach my $field (@fields) {
             if( $field eq 'DESTROY' ) {
-                carp("Having a data accessor named DESTROY  in ".
+                Carp::carp("Having a data accessor named DESTROY  in ".
                              "'$class' is unwise.");
             }
 
@@ -154,17 +152,15 @@ sub make_group_accessor {
     my $set = "set_$group";
     my $get = "get_$group";
 
-    # Build a closure around $field.
-    return sub {
-        my $self = shift;
-
-        if(@_) {
-            return $self->$set($field, @_);
+    # eval for faster fastiness
+    return eval "sub {
+        if(\@_ > 1) {
+            return shift->$set('$field', \@_);
         }
         else {
-            return $self->$get($field);
+            return shift->$get('$field');
         }
-    };
+    };"
 }
 
 =head2 make_group_ro_accessor
@@ -187,18 +183,16 @@ sub make_group_ro_accessor {
 
     my $get = "get_$group";
 
-    return sub {
-        my $self = shift;
-
-        if(@_) {
-            my $caller = caller;
-            croak("'$caller' cannot alter the value of '$field' on ".
-                        "objects of class '$class'");
+    return eval "sub {
+        if(\@_ > 1) {
+            my \$caller = caller;
+            Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
+                        \"objects of class '$class'\");
         }
         else {
-            return $self->$get($field);
+            return shift->$get('$field');
         }
-    };
+    };"
 }
 
 =head2 make_group_wo_accessor
@@ -221,18 +215,16 @@ sub make_group_wo_accessor {
 
     my $set = "set_$group";
 
-    return sub {
-        my $self = shift;
-
-        unless (@_) {
-            my $caller = caller;
-            croak("'$caller' cannot access the value of '$field' on ".
-                        "objects of class '$class'");
+    return eval "sub {
+        unless (\@_ > 1) {
+            my \$caller = caller;
+            Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
+                        \"objects of class '$class'\");
         }
         else {
-            return $self->$set($field, @_);
+            return shift->$set('$field', \@_);
         }
-    };
+    };"
 }
 
 =head2 get_simple
@@ -251,8 +243,9 @@ name passed as an argument.
 =cut
 
 sub get_simple {
-  my ($self, $get) = @_;
+    my ($self, $get) = @_;
   return $self->{$get};
+  return $_[0]->{$_[1]};
 }
 
 =head2 set_simple
@@ -271,8 +264,7 @@ for the field name passed as an argument.
 =cut
 
 sub set_simple {
-  my ($self, $set, $val) = @_;
-  return $self->{$set} = $val;
+  return $_[0]->{$_[1]} = $_[2];
 }
 
 
@@ -295,31 +287,30 @@ instances.
 =cut
 
 sub get_inherited {
-    my ($self, $get) = @_;
     my $class;
 
-    if (blessed $self) {
-        my $reftype = reftype $self;
-        $class = ref $self;
+    if (Scalar::Util::blessed $_[0]) {
+        my $reftype = Scalar::Util::reftype $_[0];
+        $class = ref $_[0];
 
-        if ($reftype eq 'HASH' && exists $self->{$get}) {
-            return $self->{$get};
+        if ($reftype eq 'HASH' && exists $_[0]->{$_[1]}) {
+            return $_[0]->{$_[1]};
         } elsif ($reftype ne 'HASH') {
-            croak('Cannot get inherited value on an object instance that is not hash-based');
+            Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
         };
     } else {
-        $class = $self;
+        $class = $_[0];
     };
 
     no strict 'refs';
-    return ${$class.'::__cag_'.$get} if defined(${$class.'::__cag_'.$get});
+    return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]});
 
     if (!@{$class.'::__cag_supers'}) {
-        @{$class.'::__cag_supers'} = $self->get_super_paths;
+        @{$class.'::__cag_supers'} = $_[0]->get_super_paths;
     };
 
     foreach (@{$class.'::__cag_supers'}) {
-        return ${$_.'::__cag_'.$get} if defined(${$_.'::__cag_'.$get});
+        return ${$_.'::__cag_'.$_[1]} if defined(${$_.'::__cag_'.$_[1]});
     };
 
     return undef;
@@ -346,18 +337,16 @@ hash-based object.
 =cut
 
 sub set_inherited {
-    my ($self, $set, $val) = @_;
-
-    if (blessed $self) {
-        if (reftype $self eq 'HASH') {
-            return $self->{$set} = $val;
+    if (Scalar::Util::blessed $_[0]) {
+        if (Scalar::Util::reftype $_[0] eq 'HASH') {
+            return $_[0]->{$_[1]} = $_[2];
         } else {
-            croak('Cannot set inherited value on an object instance that is not hash-based');
+            Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
         };
     } else {
         no strict 'refs';
 
-        return ${$self.'::__cag_'.$set} = $val;
+        return ${$_[0].'::__cag_'.$_[1]} = $_[2];
     };
 }
 
@@ -383,9 +372,7 @@ Gets the value of the specified component class.
 =cut
 
 sub get_component_class {
-    my ($self, $field) = @_;
-
-    return $self->get_inherited($field);
+    return $_[0]->get_inherited($_[1]);
 };
 
 =head2 set_component_class
@@ -409,18 +396,16 @@ it. This method will die if the specified class could not be loaded.
 =cut
 
 sub set_component_class {
-    my ($self, $field, $value) = @_;
-
-    if ($value) {
+    if ($_[2]) {
         local $^W = 0;
-        if (Class::Inspector->installed($value) && !Class::Inspector->loaded($value)) {
-            eval "use $value";
+        if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
+            eval "use $_[2]";
 
-            croak("Could not load $field '$value': ", $@) if $@;
+            Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
         };
     };
 
-    return $self->set_inherited($field, $value);
+    return $_[0]->set_inherited($_[1], $_[2]);
 };
 
 =head2 get_super_paths
@@ -430,7 +415,7 @@ Returns a list of 'parent' or 'super' class names that the current class inherit
 =cut
 
 sub get_super_paths {
-    my $class = blessed $_[0] || $_[0];
+    my $class = Scalar::Util::blessed $_[0] || $_[0];
 
     return @{mro::get_linear_isa($class)};
 };

diff --git a/t/manifest.t b/t/manifest.t
index 008ec31..31df639 100644 (file)
--- a/t/manifest.t
+++ b/t/manifest.t
@@ -17,6 +17,6 @@ BEGIN {
 
 ok_manifest({
     exclude => ['/t/var', '/cover_db'],
-    filter  => [qr/\.svn/, qr/cover/, qr/Build(.(PL|bat))?/, qr/_build/],
+    filter  => [qr/\.svn/, qr/cover/, qr/Build(.(PL|bat))?/, qr/_build/, qr/\.DS_Store/],
     bool    => 'or'
 });