From: gfx <gfuji@cpan.org>
Date: Sun, 19 Jul 2009 02:03:30 +0000 (+0900)
Subject: fix symbol manipulators
X-Git-Tag: 0.92_01~32
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=982b6f24564033d95a3bef722f9deccb24906e4f;p=gitmo%2FClass-MOP.git

fix symbol manipulators
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 3a965c3..2a975e8 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -264,13 +264,17 @@ sub _check_metaclass_compatibility {
         my $current_meta = Class::MOP::get_metaclass_by_name($name);
         return if $current_meta ne $self;
 
+
+        @{$self->get_package_symbol({name => 'ISA', type => 'ARRAY', sigil => '$', create => 1 })} = ();
+        %{ $self->namespace } = ();
+
         my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
-        no strict 'refs';
-        @{$name . '::ISA'} = ();
-        %{$name . '::'}    = ();
-        delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
 
         Class::MOP::remove_metaclass_by_name($name);
+
+        no strict 'refs';
+        delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
+        return;
     }
 
 }
@@ -508,7 +512,7 @@ sub rebless_instance_away {
 
 sub superclasses {
     my $self     = shift;
-    my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
+    my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA', create => 1 };
     if (@_) {
         my @supers = @_;
         @{$self->get_package_symbol($var_spec)} = @supers;
diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm
index 802381d..4fd47ac 100644
--- a/lib/Class/MOP/Module.pm
+++ b/lib/Class/MOP/Module.pm
@@ -33,12 +33,12 @@ sub _new {
 
 sub version {  
     my $self = shift;
-    ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'VERSION' })};
+    ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'VERSION', create => 1 })};
 }
 
 sub authority {  
     my $self = shift;
-    ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'AUTHORITY' })};
+    ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'AUTHORITY', create => 1 })};
 }
 
 sub identifier {
@@ -61,10 +61,8 @@ sub _instantiate_module {
     Class::MOP::_is_valid_class_name($package_name)
         || confess "creation of $package_name failed: invalid package name";
 
-    no strict 'refs';
-    scalar %{ $package_name . '::' };    # touch the stash
-    ${ $package_name . '::VERSION' }   = $version   if defined $version;
-    ${ $package_name . '::AUTHORITY' } = $authority if defined $authority;
+    $self->add_package_symbol('$VERSION',   \$version);
+    $self->add_package_symbol('$AUTHORITY', \$authority);
 
     return;
 }
diff --git a/xs/Package.xs b/xs/Package.xs
index 17838ed..6e907f3 100644
--- a/xs/Package.xs
+++ b/xs/Package.xs
@@ -1,9 +1,13 @@
-#define NEED_newSVpvn_flags
+
 #include "mop.h"
 
-static SV*
-mop_deconstruct_variable_name(pTHX_ SV* const variable, svtype* const type, const char** const type_name) {
-	SV* name;
+#define GLOB_CREATE     0x01
+#define VARIABLE_CREATE 0x02
+
+
+static const char*
+mop_deconstruct_variable_name(pTHX_ SV* const variable, svtype* const type, const char** const type_name, I32* const flags) {
+	const char* name;
 
 	if(SvROK(variable) && SvTYPE(SvRV(variable)) == SVt_PVHV){
 		/* e.g. variable = { type => "SCALAR", name => "foo" } */
@@ -16,8 +20,7 @@ mop_deconstruct_variable_name(pTHX_ SV* const variable, svtype* const type, cons
 		if(!(svp && SvOK(*svp))){
 			croak("You must pass a variable name");
 		}
-		name = *svp;
-		pv   = SvPV_const(name, len);
+		name = SvPV_const(*svp, len);
 		if(len < 1){
 			croak("You must pass a variable name");
 		}
@@ -49,6 +52,11 @@ mop_deconstruct_variable_name(pTHX_ SV* const variable, svtype* const type, cons
 			croak("I do not recognize that type '%s'", pv);
 		}
 		*type_name = pv;
+
+		svp = hv_fetchs(hv, "create", FALSE);
+		if(svp && SvTRUE(*svp)){
+			*flags = VARIABLE_CREATE | GLOB_CREATE;
+		}
 	}
 	else {
 		STRLEN len;
@@ -87,8 +95,7 @@ mop_deconstruct_variable_name(pTHX_ SV* const variable, svtype* const type, cons
 			croak("I do not recognize that sigil '%c'", pv[0]);
 		}
 
-		name = newSVpvn_share(pv+1, len-1, 0U);
-		sv_2mortal(name);
+		name = pv + 1;
 	}
 
 	return name;
@@ -132,26 +139,39 @@ get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
 BOOT:
     INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
 
+#define S_HAS GV_NOADD_NOINIT
+#define S_GET 0
+#define S_ADD GV_ADDMULTI
+
 SV*
 add_package_symbol(SV* self, SV* variable, SV* ref = &PL_sv_undef)
+ALIAS:
+	has_package_symbol = S_HAS
+	get_package_symbol = S_GET
+	add_package_symbol = S_ADD
 PREINIT:
 	svtype type;
 	const char* type_name;
-	SV* var_name;
+	const char* var_name;
 	SV* package_name;
-	SV* fq_name;
+	const char* fq_name;
+	I32 flags = 0; /* not used */
 CODE:
-	var_name = mop_deconstruct_variable_name(aTHX_ variable, &type, &type_name);
+	var_name = mop_deconstruct_variable_name(aTHX_ variable, &type, &type_name, &flags);
 
 	package_name = mop_call0(aTHX_ self, KEY_FOR(name));
 	if(!SvOK(package_name)){
 		croak("name() did not return a defined value");
 	}
-	fq_name = newSVpvf("%"SVf"::%"SVf, package_name, var_name);
-	sv_2mortal(fq_name);
+	fq_name = Perl_form(aTHX_ "%"SVf"::%s", package_name, var_name);
+
+	if(items == 3 && ix != S_ADD){
+		croak("Too many arguments for %s", GvNAME(CvGV(cv)));
+	}
 
-	if(SvOK(ref)){ /* set */
+	if(SvOK(ref)){ /* add_package_symbol with a value */
 		GV* gv;
+
 		if(type == SVt_PV){
 			if(!SvROK(ref)){
 				ref = newRV_noinc(newSVsv(ref));
@@ -161,7 +181,7 @@ CODE:
 		else if(!(SvROK(ref) && SvTYPE(SvRV(ref)) == type)){
 			croak("You must pass a reference of %s for the value of %s", type_name, GvNAME(CvGV(cv)));
 		}
-		gv = gv_fetchsv(fq_name, GV_ADDMULTI, type);
+		gv = gv_fetchpv(fq_name, GV_ADDMULTI, type);
 
 		if(type == SVt_PVCV && GvCV(gv)){
 			/* XXX: should introduce an option { redefine => 1 } ? */
@@ -171,107 +191,61 @@ CODE:
 		sv_setsv_mg((SV*)gv, ref); /* *glob = $ref */
 		RETVAL = ref;
 	}
-	else { /* init */
-		GV* const gv = gv_fetchsv(fq_name, GV_ADDMULTI, type);
+	else { /* no values */
+		GV* const gv = gv_fetchpv(fq_name, ix | (flags & GLOB_CREATE ? GV_ADDMULTI : 0), type);
 		SV* sv;
 
+		if(!gv){
+			if(ix == S_HAS){
+				XSRETURN_NO;
+			}
+			else{
+				XSRETURN_UNDEF;
+			}
+		}
+
+		if(!isGV(gv)){ /* In has_package_symbol, the stash entry is a stub or constant */
+			assert(ix == S_HAS);
+			if(type == SVt_PVCV){
+				XSRETURN_YES;
+			}
+			else{
+				XSRETURN_NO;
+			}
+		}
+
 		switch(type){
-		case SVt_PV:
-			sv = GvSVn(gv);
-			break;
 		case SVt_PVAV:
-			sv = (SV*)GvAVn(gv);
+			sv = (SV*)((flags & VARIABLE_CREATE) ? GvAVn(gv) : GvAV(gv));
 			break;
 		case SVt_PVHV:
-			sv = (SV*)GvHVn(gv);
+			sv = (SV*)((flags & VARIABLE_CREATE) ? GvHVn(gv) : GvHV(gv));
 			break;
 		case SVt_PVCV:
 			sv = (SV*)GvCV(gv);
 			break;
+		case SVt_PVIO:
+			sv = (SV*)((flags & VARIABLE_CREATE) ? GvIOn(gv) : GvIO(gv));
+			break;
 		case SVt_PVGV:
 			sv = (SV*)gv;
 			break;
-		case SVt_PVIO:
-			sv = (SV*)GvIOn(gv);
-			break;
-		default:
-			croak("NOT REACHED");
-			sv = NULL; /* -W */
+		default: /* SCALAR */
+			sv =       (flags & VARIABLE_CREATE) ? GvSVn(gv) : GvSV(gv);
 			break;
 		}
 
-		if(sv){
-			RETVAL = sv_2mortal(newRV_inc(sv));
+		if(ix == S_HAS){
+			RETVAL = boolSV(sv);
 		}
 		else{
-			RETVAL = &PL_sv_undef;
+			if(sv){
+				RETVAL = sv_2mortal(newRV_inc(sv));
+			}
+			else{
+				RETVAL = &PL_sv_undef;
+			}
 		}
 	}
 	ST(0) = RETVAL;
 
-SV*
-get_package_symbol(SV* self, SV* variable)
-ALIAS:
-	get_package_symbol = GV_ADDMULTI
-	has_package_symbol = 0
-PREINIT:
-	svtype type;
-	const char* type_name;
-	SV* var_name;
-	SV* package_name;
-	SV* fq_name;
-	GV* gv;
-	SV* sv;
-CODE:
-	var_name = mop_deconstruct_variable_name(aTHX_ variable, &type, &type_name);
-
-	package_name = mop_call0(aTHX_ self, KEY_FOR(name));
-	if(!SvOK(package_name)){
-		croak("name() did not return a defined value");
-	}
-	fq_name = newSVpvf("%"SVf"::%"SVf, package_name, var_name);
-	sv_2mortal(fq_name);
-
-	gv = gv_fetchsv(fq_name, ix, type);
-	if(!gv){ /* no symbol in has_package_symbol() */
-		XSRETURN_NO;
-	}
-
-	switch(type){
-	case SVt_PV:
-		sv = GvSV(gv);
-		break;
-	case SVt_PVAV:
-		sv = (SV*)GvAV(gv);
-		break;
-	case SVt_PVHV:
-		sv = (SV*)GvHV(gv);
-		break;
-	case SVt_PVCV:
-		sv = (SV*)GvCV(gv);
-		break;
-	case SVt_PVGV:
-		sv = (SV*)gv;
-		break;
-	case SVt_PVIO:
-		sv = (SV*)GvIO(gv);
-		break;
-	default:
-		croak("NOT REACHED");
-		sv = NULL; /* -W */
-		break;
-	}
-
-	if(!ix){ /* has_package_symbol */
-		RETVAL = boolSV(sv);
-	}
-	else{
-		if(sv){
-			RETVAL = newRV_inc(sv);
-		}
-		else{
-			RETVAL = &PL_sv_undef;
-		}
-	}
-OUTPUT:
-	RETVAL