Do as Steffen says

[p5sagit/Class-Accessor-Grouped.git] / lib / Class / Accessor / Grouped.pm

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index 81d778a..fd36786 100644 (file)
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -5,8 +5,31 @@ use Carp ();
 use Class::Inspector ();
 use Scalar::Util ();
 use MRO::Compat;
+use Sub::Name ();
 
-our $VERSION = '0.08001';
+our $VERSION = '0.09003';
+$VERSION = eval $VERSION;
+
+# Class::XSAccessor is segfaulting on win32, so be careful
+# Win32 users can set $hasXS to try to use it anyway
+
+our $hasXS;
+
+sub _hasXS {
+
+  if (not defined $hasXS) {
+    $hasXS = 0;
+
+    if ($^O ne 'MSWin32') {
+      eval {
+        require Class::XSAccessor;
+        $hasXS = 1;
+      };
+    }
+  }
+
+  return $hasXS;
+}
 
 =head1 NAME
 
@@ -64,6 +87,8 @@ sub mk_group_accessors {
 
         # So we don't have to do lots of lookups inside the loop.
         $maker = $self->can($maker) unless ref $maker;
+        
+        my $hasXS = _hasXS();
 
         foreach my $field (@fields) {
             if( $field eq 'DESTROY' ) {
@@ -74,15 +99,31 @@ sub mk_group_accessors {
             my $name = $field;
 
             ($name, $field) = @$field if ref $field;
-
-            my $accessor = $self->$maker($group, $field);
+            
             my $alias = "_${name}_accessor";
-
-            *{$class."\:\:$name"}  = $accessor;
-              #unless defined &{$class."\:\:$field"}
-
-            *{$class."\:\:$alias"}  = $accessor;
-              #unless defined &{$class."\:\:$alias"}
+            my $full_name = join('::', $class, $name);
+            my $full_alias = join('::', $class, $alias);
+            if ( $hasXS && $group eq 'simple' ) {
+                require Class::XSAccessor;
+                Class::XSAccessor->import({
+                  replace => 1,
+                  class => $class,
+                  accessors => {
+                    $name => $field,
+                    $alias => $field,
+                  },
+                });
+            }
+            else {
+                my $accessor = $self->$maker($group, $field);
+                my $alias_accessor = $self->$maker($group, $field);
+                
+                *$full_name = Sub::Name::subname($full_name, $accessor);
+                  #unless defined &{$class."\:\:$field"}
+                
+                *$full_alias = Sub::Name::subname($full_alias, $alias_accessor);
+                  #unless defined &{$class."\:\:$alias"}
+            }
         }
     }
 }
@@ -98,7 +139,7 @@ Returns: none
 =back
 
 Creates a set of read only accessors in a given group. Identical to
-<L:/mk_group_accessors> but accessors will throw an error if passed a value
+L</mk_group_accessors> but accessors will throw an error if passed a value
 rather than setting the value.
 
 =cut
@@ -120,7 +161,7 @@ Returns: none
 =back
 
 Creates a set of write only accessors in a given group. Identical to
-<L:/mk_group_accessors> but accessors will throw an error if not passed a
+L</mk_group_accessors> but accessors will throw an error if not passed a
 value rather than getting the value.
 
 =cut
@@ -243,8 +284,6 @@ name passed as an argument.
 =cut
 
 sub get_simple {
-    my ($self, $get) = @_;
-  return $self->{$get};
   return $_[0]->{$_[1]};
 }
 
@@ -303,10 +342,14 @@ sub get_inherited {
     };
 
     no strict 'refs';
+    no warnings qw/uninitialized/;
     return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]});
 
-    if (!@{$class.'::__cag_supers'}) {
+    # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
+    my $pkg_gen = mro::get_pkg_gen ($class);
+    if ( ${$class.'::__cag_pkg_gen'} != $pkg_gen ) {
         @{$class.'::__cag_supers'} = $_[0]->get_super_paths;
+        ${$class.'::__cag_pkg_gen'} = $pkg_gen;
     };
 
     foreach (@{$class.'::__cag_supers'}) {
@@ -422,14 +465,29 @@ sub get_super_paths {
 
 1;
 
+=head1 PERFORMANCE
+
+You can speed up accessors of type 'simple' by installing L<Class::XSAccessor>.
+Note however that the use of this module is disabled by default on Win32
+systems, as it causes yet unresolved segfaults. If you are a Win32 user, and
+want to try this module with L<Class::XSAccessor>, set
+C<$Class::Accessor::Grouped::hasXS> to a true value B<before> registering
+your accessors (e.g. in a C<BEGIN> block)
+
 =head1 AUTHORS
 
 Matt S. Trout <mst@shadowcatsystems.co.uk>
 Christopher H. Laco <claco@chrislaco.com>
 
-=head1 LICENSE
+With contributions from:
 
-You may distribute this code under the same terms as Perl itself.
+Guillermo Roditi <groditi@cpan.org>
 
-=cut
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
 
+This program is free software; you can redistribute it and/or modify
+it under the same terms as perl itself.
+
+=cut