X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=85a09161d281f6c6c5514d85d60d4d102f2b5232;hb=8f675a64451b3c11c234adeda6be313fb8d03f6c;hp=d629dfd1c967fa9e4ca47beacfbe47acb90684b2;hpb=62658f4d9934aba5f8b23afcc078dc12b3a40223;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index d629dfd..85a0916 100644
--- a/universal.c
+++ b/universal.c
@@ -93,7 +93,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
 		HV* basestash = gv_stashsv(sv, FALSE);
 		if (!basestash) {
 		    if (ckWARN(WARN_MISC))
-			Perl_warner(aTHX_ WARN_SYNTAX,
+			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 		             "Can't locate package %s for @%s::ISA",
 			    SvPVX(sv), HvNAME(stash));
 		    continue;
@@ -167,7 +167,8 @@ XS(XS_utf8_upgrade);
 XS(XS_utf8_downgrade);
 XS(XS_utf8_unicode_to_native);
 XS(XS_utf8_native_to_unicode);
-XS(XS_access_readonly);
+XS(XS_Internals_SvREADONLY);
+XS(XS_Internals_SvREFCNT);
 
 void
 Perl_boot_core_UNIVERSAL(pTHX)
@@ -184,7 +185,8 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXS("utf8::downgrade", XS_utf8_downgrade, file);
     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
-    newXSproto("access::readonly",XS_access_readonly, file, "\\[$%@];$");
+    newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
+    newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 }
 
 
@@ -460,22 +462,41 @@ XS(XS_utf8_unicode_to_native)
  XSRETURN(1);
 }
 
-XS(XS_access_readonly)
+XS(XS_Internals_SvREADONLY)	/* This is dangerous stuff. */
 {
     dXSARGS;
     SV *sv = SvRV(ST(0));
-    IV old = SvREADONLY(sv);
-    if (items == 2) {
+    if (items == 1) {
+	 if (SvREADONLY(sv))
+	     XSRETURN_YES;
+	 else
+	     XSRETURN_NO;
+    }
+    else if (items == 2) {
 	if (SvTRUE(ST(1))) {
 	    SvREADONLY_on(sv);
+	    XSRETURN_YES;
 	}
 	else {
+	    /* I hope you really know what you are doing. */
 	    SvREADONLY_off(sv);
+	    XSRETURN_NO;
 	}
     }
-    if (old)
-	XSRETURN_YES;
-    else
-	XSRETURN_NO;
+    XSRETURN_UNDEF; /* Can't happen. */
+}
+
+XS(XS_Internals_SvREFCNT)	/* This is dangerous stuff. */
+{
+    dXSARGS;
+    SV *sv = SvRV(ST(0));
+    if (items == 1)
+	 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
+    else if (items == 2) {
+         /* I hope you really know what you are doing. */
+	 SvREFCNT(sv) = SvIV(ST(1));
+	 XSRETURN_IV(SvREFCNT(sv));
+    }
+    XSRETURN_UNDEF; /* Can't happen. */
 }