Upgrade to Math::BigInt 1.56, Math::BigRat 0.05,

[p5sagit/p5-mst-13.2.git] / universal.c

diff --git a/universal.c b/universal.c
index b2313f5..85a0916 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -7,6 +7,12 @@
  *
  */
 
+/*
+ * "The roots of those mountains must be roots indeed; there must be
+ * great secrets buried there which have not been discovered since the
+ * beginning." --Gandalf, relating Gollum's story
+ */
+
 #include "EXTERN.h"
 #define PERL_IN_UNIVERSAL_C
 #include "perl.h"
@@ -87,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;
@@ -161,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)
@@ -178,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, "\\[$%@];$");
 }
 
 
@@ -284,10 +292,18 @@ XS(XS_UNIVERSAL_VERSION)
        STRLEN len;
        SV *req = ST(1);
 
-       if (undef)
-           Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
-                      HvNAME(pkg), HvNAME(pkg));
-
+       if (undef) {
+            if (pkg)
+                 Perl_croak(aTHX_
+                            "%s does not define $%s::VERSION--version check failed",
+                            HvNAME(pkg), HvNAME(pkg));
+            else {
+                 char *str = SvPVx(ST(0), len);
+
+                 Perl_croak(aTHX_
+                            "%s defines neither package nor VERSION--version check failed", str);
+            }
+       }
        if (!SvNIOK(sv) && SvPOK(sv)) {
            char *str = SvPVx(sv,len);
            while (len) {
@@ -446,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. */
 }