Class::MOP::Class->add_method()のXS版

昨日XSで書くといったのはget_method_map()だったんだけど，ちょっとした勘違いでadd_method()をXSで書いてしまった…。せっかくだからあとでRTで報告しよっと。

オリジナルと異なるのは，add_package_symbol()を呼ばずにサブルーチンをインストールしている*1点とSub::Name::subname()で命名していない点。これは，add_package_symbol()が非常に遅いのと，Sub::Name::subname()とは違う方法で命名したほうがいいと考える理由があるからなんだけど，これはあとで書きます。

--- MOP.xs.orig	2008-11-15 06:37:06.000000000 +0900
+++ MOP.xs	2008-11-17 22:34:16.000000000 +0900
@@ -1,3 +1,4 @@
+#define PERL_NO_GET_CONTEXT
 
 #include "EXTERN.h"
 #include "perl.h"
@@ -19,6 +20,33 @@
 SV *key_body;
 U32 hash_body;
 
+SV* m_add_package_symbol;
+SV* m_update_package_cache_flag;
+SV* m_get_method_map;
+SV* m_attach_to_class;
+SV* m_wrap_method_body;
+
+
+#define call0(s, m)  mop_call0(aTHX_ s, m)
+#define call0s(s, m) mop_call0(aTHX_ s, sv_2mortal(newSVpvs(m)));
+static SV*
+mop_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;
+}
+
 /*
 get_code_info:
   Pass in a coderef, returns:
@@ -28,6 +56,8 @@
 
 MODULE = Class::MOP   PACKAGE = Class::MOP
 
+PROTOTYPES: DISABLE
+
 BOOT:
     key_name = newSVpvs("name");
     key_body = newSVpvs("body");
@@ -38,6 +68,11 @@
     PERL_HASH(hash_body, "body", 4);
     PERL_HASH(hash_package, "package", 7);
     PERL_HASH(hash_package_name, "package_name", 12);
+	m_add_package_symbol        = newSVpvs("add_package_symbol");
+	m_update_package_cache_flag = newSVpvs("update_package_cache_flag");
+	m_get_method_map            = newSVpvs("get_method_map");
+	m_attach_to_class           = newSVpvs("attach_to_class");
+	m_wrap_method_body          = newSVpvs("wrap_method_body");
 
 
 PROTOTYPES: ENABLE
@@ -244,3 +279,138 @@
             XPUSHs(HeVAL(he));
         else
             ST(0) = &PL_sv_undef;
+
+MODULE = Class::MOP	PACKAGE = Class::MOP::Class
+
+void
+add_method(self, method_name, method)
+	SV* self
+	SV* method_name
+	SV* method
+PREINIT:
+	SV* body; /* ref to CODE */
+	SV* cache_flag;
+	SV* self_name;
+CODE:
+	if(!SvRV(self)){
+		die("Cannot call add_method as a class method");
+	}
+	if(!SvTRUE(method_name)){
+		croak("You must define a method name");
+	}
+	ENTER;
+
+	self_name = call0(self, key_name);
+	if(sv_isobject(method)){
+		SV* package_name;
+
+		/* $body = $method->body(); */
+		body         = call0(method, key_body);
+		package_name = call0(method, key_package_name);
+
+		if(strNE(SvPV_nolen_const(package_name), SvPV_nolen_const(self_name))){
+			dSP;
+			HV* stash  = SvSTASH(SvRV(method));
+			GV* can_gv = gv_fetchmethod_autoload(stash, "clone", FALSE);
+
+			if(can_gv && GvCV(can_gv)){
+				/* $method->clone(package => $self->name, name => $method_name) */
+				PUSHMARK(SP);
+				EXTEND(SP, 5);
+				PUSHs(method);
+				PUSHs(key_package);
+				PUSHs(self_name);
+				PUSHs(key_name);
+				PUSHs(method_name);
+				PUTBACK;
+				call_method("clone", G_SCALAR);
+				SPAGAIN;
+				method = POPs;
+				PUTBACK;
+			}
+		}
+	}
+	else{
+		dSP;
+		body = method;
+
+		/* self->wrap_method_body(body => $body, name => $method_name) */
+		PUSHMARK(SP);
+		EXTEND(SP, 5);
+		PUSHs(self);
+		PUSHs(key_body);
+		PUSHs(body);
+		PUSHs(key_name);
+		PUSHs(method_name);
+		PUTBACK;
+
+		call_sv(m_wrap_method_body, G_SCALAR | G_METHOD);
+		SPAGAIN;
+		method = POPs;
+		PUTBACK;
+	}
+	if(!(sv_isobject(method) && SvROK(body) && SvTYPE(SvRV(body)) == SVt_PVCV)){
+		croak("You must supply a method object or code reference");
+	}
+	{
+		dSP;
+		/* $method->attach_to_class($self) */
+
+		PUSHMARK(SP);
+		EXTEND(SP, 2);
+		PUSHs(method);
+		PUSHs(self);
+		PUTBACK;
+
+		call_sv(m_attach_to_class, G_VOID | G_METHOD);
+	}
+	{
+		/* $self->get_method_map()->{$method_name} = $method */
+		SV* method_map = call0(self, m_get_method_map);
+		if(!(SvROK(method_map) && SvTYPE(SvRV(method_map)) == SVt_PVHV)){
+			croak("Not a HASH reference");
+		}
+
+		hv_store_ent((HV*)SvRV(method_map), method_name, newSVsv(method), 0U);
+	}
+	{
+		CV* cv = (CV*)SvRV(body);
+		STRLEN namelen;
+		const char* const name = SvPV_const(method_name, namelen);
+		HV* stash = gv_stashsv(self_name, TRUE);
+		GV* gv = (GV*)*hv_fetch(stash, name, namelen, TRUE);
+		if(SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, name, namelen, GV_ADDMULTI);
+		/* install CV into the package directly */
+		SvREFCNT_dec(GvCV(gv));
+		GvCV(gv) = NULL;
+		SvSetMagicSV((SV*)gv, body); /* *foo = \&bar */
+		/* locate anonymous subroutines in the package */
+		if(CvGV(cv) && strEQ(GvNAME(CvGV(cv)), "__ANON__")){
+			CvGV(cv) = gv;
+			CvANON_off(cv);
+		}
+#if 0
+		/* add_packag_symbol(\%attr, $body) */
+		{
+			dSP;
+			HV* attr = newHV();
+			hv_stores(attr, "sigil", newSVpvs("&"));
+			hv_stores(attr, "type",  newSVpvs("CODE"));
+			hv_stores(attr, "name",  newSVsv(method_name));
+
+			PUSHMARK(SP);
+			EXTEND(SP, 3);
+			PUSHs(self);
+			mPUSHs(newRV_noinc((SV*)attr));
+			PUSHs(body);
+			PUTBACK;
+		}
+		call_sv(m_add_package_symbol, G_VOID | G_METHOD);
+#endif
+		cache_flag = call0(self, m_update_package_cache_flag);
+
+	}
+	ST(0) = cache_flag;
+
+	LEAVE;
+	XSRETURN(1);

*1:Data::Util::install_subroutine()のノウハウを利用した。