From: gfx <gfuji@cpan.org>
Date: Sat, 24 Oct 2009 05:21:15 +0000 (+0900)
Subject: Add first XS implementation
X-Git-Tag: 0.40_01~31
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=df6dd016657118a06b408d21767dbc9b4ca476b9

Add first XS implementation
---

diff --git a/Makefile.PL b/Makefile.PL
index 1222823..e6a0c67 100755
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -22,12 +22,12 @@ include 'Test::Exception'; # work around 0.27_0x (its use of diehook might be wr
 
 recommends 'MRO::Compat' if $] < 5.010;
 
-my $use_xs;
-
-for (@ARGV) {
-    /^--pp$/ and $use_xs = 0;
-    /^--xs$/ and $use_xs = 1;
-}
+my $use_xs;
+
+for (@ARGV) {
+    /^--pp$/ and $use_xs = 0;
+    /^--xs$/ and $use_xs = 1;
+}
 
 if(!defined $use_xs){
     configure_requires 'ExtUtils::CBuilder';
diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
new file mode 100644
index 0000000..e0eb596
--- /dev/null
+++ b/lib/Mouse/PurePerl.pm
@@ -0,0 +1,74 @@
+package
+    Mouse::Util;
+
+use strict;
+use warnings;
+
+use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl
+
+use B ();
+
+sub is_class_loaded {
+    my $class = shift;
+
+    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)) {
+        my $entry = \$pack->{$part . '::'};
+        return 0 if ref($entry) ne 'GLOB';
+        $pack = *{$entry}{HASH} or return 0;
+    }
+
+    # check for $VERSION or @ISA
+    return 1 if exists $pack->{VERSION}
+             && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
+    return 1 if exists $pack->{ISA}
+             && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
+
+    # check for any method
+    foreach my $name( keys %{$pack} ) {
+        my $entry = \$pack->{$name};
+        return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
+    }
+
+    # fail
+    return 0;
+}
+
+
+# taken from Sub::Identify
+sub get_code_info {
+    my ($coderef) = @_;
+    ref($coderef) or return;
+
+    my $cv = B::svref_2object($coderef);
+    $cv->isa('B::CV') or return;
+
+    my $gv = $cv->GV;
+    $gv->isa('B::GV') or return;
+
+    return ($gv->STASH->NAME, $gv->NAME);
+}
+
+sub get_code_package{
+    my($coderef) = @_;
+
+    my $cv = B::svref_2object($coderef);
+    $cv->isa('B::CV') or return '';
+
+    my $gv = $cv->GV;
+    $gv->isa('B::GV') or return '';
+
+    return $gv->STASH->NAME;
+}
+
+
+package
+    Mouse::Meta::Method::Accessor;
+
+1;
+__END__
diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index 9a34e0c..f24da52 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -1,9 +1,31 @@
 package Mouse::Util;
 use Mouse::Exporter; # enables strict and warnings
 
+BEGIN{
+    # Because Mouse::Util is loaded first in all the Mouse sub-modules,
+    # XS loader is placed here, not in Mouse.pm.
+
+    our $VERSION = '0.40';
+
+    my $need_pp = !!$ENV{MOUSE_PUREPERL};
+
+    if(!$need_pp && !exists $INC{'Mouse/PurePerl.pm'}){
+        local $@;
+        $need_pp = !eval{
+            require XSLoader;
+            XSLoader::load('Mouse', $VERSION);
+        };
+        warn $@ if $@; # for DEBUGGING
+    }
+
+    if($need_pp){
+        require 'Mouse/PurePerl.pm'; # we don't want to create its namespace
+    }
+}
+
+
 use Carp qw(confess);
 use Scalar::Util qw(blessed);
-use B ();
 
 use constant _MOUSE_VERBOSE => !!$ENV{MOUSE_VERBOSE};
 
@@ -107,32 +129,6 @@ BEGIN {
     *get_linear_isa = $impl;
 }
 
-{ # taken from Sub::Identify
-    sub get_code_info($) {
-        my ($coderef) = @_;
-        ref($coderef) or return;
-
-        my $cv = B::svref_2object($coderef);
-        $cv->isa('B::CV') or return;
-
-        my $gv = $cv->GV;
-        $gv->isa('B::GV') or return;
-
-        return ($gv->STASH->NAME, $gv->NAME);
-    }
-
-    sub get_code_package{
-        my($coderef) = @_;
-
-        my $cv = B::svref_2object($coderef);
-        $cv->isa('B::CV') or return '';
-
-        my $gv = $cv->GV;
-        $gv->isa('B::GV') or return '';
-
-        return $gv->STASH->NAME;
-    }
-}
 
 # taken from Mouse::Util (0.90)
 {
@@ -163,6 +159,8 @@ BEGIN {
 
 # Utilities from Class::MOP
 
+sub get_code_info;
+sub get_code_package;
 
 # taken from Class/MOP.pm
 sub is_valid_class_name {
@@ -234,37 +232,7 @@ sub load_class {
     return 1;
 }
 
-
-sub is_class_loaded {
-    my $class = shift;
-
-    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)) {
-        my $entry = \$pack->{$part . '::'};
-        return 0 if ref($entry) ne 'GLOB';
-        $pack = *{$entry}{HASH} or return 0;
-    }
-
-    # check for $VERSION or @ISA
-    return 1 if exists $pack->{VERSION}
-             && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
-    return 1 if exists $pack->{ISA}
-             && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
-
-    # check for any method
-    foreach my $name( keys %{$pack} ) {
-        my $entry = \$pack->{$name};
-        return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
-    }
-
-    # fail
-    return 0;
-}
+sub is_class_loaded;
 
 
 sub apply_all_roles {
diff --git a/mouse.h b/mouse.h
new file mode 100644
index 0000000..5fe65b5
--- /dev/null
+++ b/mouse.h
@@ -0,0 +1,29 @@
+#ifndef MOUSE_H
+#define MOUSE_H
+
+#define PERL_NO_GET_CONTEXT
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+
+#include "ppport.h"
+
+#define is_class_loaded(sv) mouse_is_class_loaded(aTHX_ sv)
+bool mouse_is_class_loaded(pTHX_ SV*);
+
+#define is_instance_of(sv, klass) mouse_is_instance_of(aTHX_ sv, klass)
+bool mouse_is_instance_of(pTHX_ SV* const sv, SV* const klass);
+
+#define IsObject(sv) (SvROK(sv) && SvOBJECT(SvRV(sv)))
+
+#define mcall0(invocant, m)        mouse_call0(aTHX_ (invocant), (m))
+#define mcall1(invocant, m, arg1)  mouse_call1(aTHX_ (invocant), (m), (arg1))
+#define mcall0s(invocant, m)       mcall0((invocant), newSVpvs_flags(m, SVs_TEMP))
+#define mcall1s(invocant, m, arg1) mcall1((invocant), newSVpvs_flags(m, SVs_TEMP), (arg1))
+
+SV* mouse_call0(pTHX_ SV *const self, SV *const method);
+SV* mouse_call1(pTHX_ SV *const self, SV *const method, SV* const arg1);
+
+
+#endif /* !MOUSE_H */
+
diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs
new file mode 100644
index 0000000..f96dce3
--- /dev/null
+++ b/xs-src/Mouse.xs
@@ -0,0 +1,35 @@
+#include "mouse.h"
+
+MODULE = Mouse  PACKAGE = Mouse::Util
+
+PROTOTYPES: DISABLE
+
+bool
+is_class_loaded(SV* sv = &PL_sv_undef)
+
+void
+get_code_info(CV* code)
+PREINIT:
+    GV* gv;
+    HV* stash;
+PPCODE:
+    if((gv = CvGV(code)) && isGV(gv) && (stash = GvSTASH(gv))){
+        EXTEND(SP, 2);
+        mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U));
+        mPUSHs(newSVpvn_share(GvNAME_get(gv), GvNAMELEN_get(gv), 0U));
+    }
+
+SV*
+get_code_package(CV* code)
+PREINIT:
+    HV* stash;
+CODE:
+    if(CvGV(code) && isGV(CvGV(code)) && (stash = GvSTASH(CvGV(code)))){
+        RETVAL = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
+    }
+    else{
+        RETVAL = &PL_sv_no;
+    }
+OUTPUT:
+    RETVAL
+
diff --git a/xs-src/mouse_util.xs b/xs-src/mouse_util.xs
new file mode 100644
index 0000000..772deaf
--- /dev/null
+++ b/xs-src/mouse_util.xs
@@ -0,0 +1,110 @@
+#include "mouse.h"
+
+/* equivalent to "blessed($x) && $x->isa($klass)" */
+bool
+mouse_is_instance_of(pTHX_ SV* const sv, SV* const klass){
+    assert(sv);
+    assert(klass);
+
+    if(IsObject(sv) && SvOK(klass)){
+        bool ok;
+
+        ENTER;
+        SAVETMPS;
+
+        ok = SvTRUEx(mcall1s(sv, "isa", klass));
+
+        FREETMPS;
+        LEAVE;
+
+        return ok;
+    }
+
+    return FALSE;
+}
+
+
+bool
+mouse_is_class_loaded(pTHX_ SV * const klass){
+    HV *stash;
+    GV** gvp;
+    HE* he;
+
+    if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */
+        return FALSE;
+    }
+
+    stash = gv_stashsv(klass, FALSE);
+    if (!stash) {
+        return FALSE;
+    }
+
+    if (( gvp = (GV**)hv_fetchs(stash, "VERSION", FALSE) )) {
+        if(isGV(*gvp) && GvSV(*gvp) && SvOK(GvSV(*gvp))){
+            return TRUE;
+        }
+    }
+
+    if (( gvp = (GV**)hv_fetchs(stash, "ISA", FALSE) )) {
+        if(isGV(*gvp) && GvAV(*gvp) && av_len(GvAV(*gvp)) != -1){
+            return TRUE;
+        }
+    }
+
+    hv_iterinit(stash);
+    while(( he = hv_iternext(stash) )){
+        GV* const gv = (GV*)HeVAL(he);
+
+        if(isGV(gv)){
+            if(GvCVu(gv)){
+                return TRUE;
+            }
+        }
+        else if(SvOK(gv)){
+            return TRUE;
+        }
+    }
+    return FALSE;
+}
+
+
+SV *
+mouse_call0 (pTHX_ SV *const self, SV *const method)
+{
+    dSP;
+    SV *ret;
+
+    PUSHMARK(SP);
+    XPUSHs(self);
+    PUTBACK;
+
+    call_sv(method, G_SCALAR | G_METHOD);
+
+    SPAGAIN;
+    ret = POPs;
+    PUTBACK;
+
+    return ret;
+}
+
+SV *
+mouse_call1 (pTHX_ SV *const self, SV *const method, SV* const arg1)
+{
+    dSP;
+    SV *ret;
+
+    PUSHMARK(SP);
+    EXTEND(SP, 2);
+    PUSHs(self);
+    PUSHs(arg1);
+    PUTBACK;
+
+    call_sv(method, G_SCALAR | G_METHOD);
+
+    SPAGAIN;
+    ret = POPs;
+    PUTBACK;
+
+    return ret;
+}
+