From: Matt S Trout <mst@shadowcat.co.uk>
Date: Mon, 8 Nov 2010 05:49:02 +0000 (+0000)
Subject: use XSAccessor if available
X-Git-Tag: 0.009001~50
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=daa05b6234ccf2ac5859178ddb821f02e786d117;p=gitmo%2FMoo.git

use XSAccessor if available
---

diff --git a/lib/Class/Tiny/_Utils.pm b/lib/Class/Tiny/_Utils.pm
index b046068..b166515 100644
--- a/lib/Class/Tiny/_Utils.pm
+++ b/lib/Class/Tiny/_Utils.pm
@@ -3,7 +3,7 @@ package Class::Tiny::_Utils;
 use strictures 1;
 use base qw(Exporter);
 
-our @EXPORT = qw(_getglob _install_modifier);
+our @EXPORT = qw(_getglob _install_modifier _maybe_load_module);
 
 sub _getglob { no strict 'refs'; \*{$_[0]} }
 
@@ -22,4 +22,20 @@ sub _install_modifier {
   Class::Method::Modifiers::install_modifier(@_);
 }
 
+our %MAYBE_LOADED;
+
+sub _maybe_load_module {
+  return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]};
+  (my $proto = $_[0]) =~ s/::/\//g;
+  if (eval { require "${proto}.pm"; 1 }) {
+    $MAYBE_LOADED{$_[0]} = 1;
+  } else {
+    if (exists $INC{"${proto}.pm"}) {
+      warn "$_[0] exists but failed to load with error: $@";
+    }
+    $MAYBE_LOADED{$_[0]} = 0;
+  }
+  return $MAYBE_LOADED{$_[0]};
+}
+
 1;
diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 263c7f8..581386f 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -5,11 +5,17 @@ use Class::Tiny::_Utils;
 use base qw(Class::Tiny::Object);
 use Sub::Quote;
 use B 'perlstring';
+BEGIN {
+  our $CAN_HAZ_XS = ($^O ne 'Win32')
+    && _maybe_load_module('Class::XSAccessor')
+    && (Class::XSAccessor->VERSION > 1.06);
+}
 
 sub generate_method {
   my ($self, $into, $name, $spec, $quote_opts) = @_;
   die "Must have an is" unless my $is = $spec->{is};
   local $self->{captures} = {};
+  local $self->{into} = $into; # for XS gen
   my $body = do {
     if ($is eq 'ro') {
       $self->_generate_get($name, $spec)
@@ -29,6 +35,7 @@ sub generate_method {
       "    delete \$_[0]->{${\perlstring $name}}\n"
     ;
   }
+  return $body if ref($body); # optimiferised
   quote_sub
     "${into}::${name}" => '    '.$body."\n",
     $self->{captures}, $quote_opts||{}
@@ -43,8 +50,21 @@ sub is_simple_attribute {
     qw(lazy default builder isa trigger predicate);
 }
 
+sub is_simple_get {
+  my ($self, $name, $spec) = @_;
+  return !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
+}
+
+sub is_simple_set {
+  my ($self, $name, $spec) = @_;
+  return !grep $spec->{$_}, qw(isa trigger);
+}
+
 sub _generate_get {
   my ($self, $name, $spec) = @_;
+  if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
+    return $self->_generate_xs_get($name);
+  }
   my $simple = $self->_generate_simple_get('$_[0]', $name);
   my ($lazy, $default, $builder) = @{$spec}{qw(lazy default builder)};
   return $simple unless $lazy and ($default or $builder);
@@ -231,8 +251,33 @@ sub _generate_simple_set {
 
 sub _generate_getset {
   my ($self, $name, $spec) = @_;
+  if (
+    our $CAN_HAZ_XS
+    && $self->is_simple_get($name, $spec)
+    && $self->is_simple_set($name, $spec)
+  ) {
+    return $self->_generate_xs_getset($name);
+  }
   q{(@_ > 1 ? }.$self->_generate_set($name, q{$_[1]}, $spec)
     .' : '.$self->_generate_get($name).')';
 }
 
+sub _generate_xs_get {
+  shift->_generate_xs('getters', @_);
+}
+
+sub _generate_xs_getset {
+  shift->_generate_xs('accessors', @_);
+}
+
+sub _generate_xs {
+  my ($self, $type, $name) = @_;
+  no strict 'refs';
+  Class::XSAccessor->import(
+    class => $self->{into},
+    $type => { $name => $name }
+  );
+  return $self->{into}->can($name);
+}
+
 1;
diff --git a/t/method-generate-accessor.t b/t/method-generate-accessor.t
index 4c15a94..93164c8 100644
--- a/t/method-generate-accessor.t
+++ b/t/method-generate-accessor.t
@@ -28,7 +28,7 @@ like(
 my $foo = Foo->new(one => 1);
 
 is($foo->one, 1, 'ro reads');
-$foo->one(-3);
+$foo->one(-3) unless $Method::Generate::Accessor::CAN_HAZ_XS;
 is($foo->one, 1, 'ro does not write');
 
 is($foo->two, undef, 'rw reads');