fix File::Spec->abs2rel() to return absolute $path more often for VMS

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

diff --git a/universal.c b/universal.c
index e7889fb..6ba5a13 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -45,6 +45,9 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
     if (strEQ(HvNAME(stash), name))
        return &PL_sv_yes;
 
+    if (strEQ(name, "UNIVERSAL"))
+       return &PL_sv_yes;
+
     if (level > 100)
        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
                   HvNAME(stash));
@@ -112,8 +115,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
            (void)hv_store(hv,name,len,&PL_sv_no,0);
        }
     }
-
-    return boolSV(strEQ(name, "UNIVERSAL"));
+    return &PL_sv_no;
 }
 
 /*
@@ -171,6 +173,8 @@ XS(XS_version_numify);
 XS(XS_version_vcmp);
 XS(XS_version_boolean);
 XS(XS_version_noop);
+XS(XS_version_is_alpha);
+XS(XS_utf8_is_utf8);
 XS(XS_utf8_valid);
 XS(XS_utf8_encode);
 XS(XS_utf8_decode);
@@ -209,7 +213,9 @@ Perl_boot_core_UNIVERSAL(pTHX)
        newXS("version::boolean", XS_version_boolean, file);
        newXS("version::(nomethod", XS_version_noop, file);
        newXS("version::noop", XS_version_noop, file);
+       newXS("version::is_alpha", XS_version_is_alpha, file);
     }
+    newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
     newXS("utf8::valid", XS_utf8_valid, file);
     newXS("utf8::encode", XS_utf8_encode, file);
     newXS("utf8::decode", XS_utf8_decode, file);
@@ -383,107 +389,157 @@ XS(XS_version_new)
 
 XS(XS_version_stringify)
 {
-    dXSARGS;
-    if (items < 1)
-       Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
-    SP -= items;
-    {
-       SV *    lobj;
-
-        if (sv_derived_from(ST(0), "version")) {
-                SV *tmp = SvRV(ST(0));
-               lobj = tmp;
-        }
-        else
-                Perl_croak(aTHX_ "lobj is not of type version");
-
-{
-    PUSHs(vstringify(lobj));
-}
-
-       PUTBACK;
-       return;
-    }
+     dXSARGS;
+     if (items < 1)
+         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
+     SP -= items;
+     {
+         SV *  lobj;
+
+         if (sv_derived_from(ST(0), "version")) {
+              SV *tmp = SvRV(ST(0));
+              lobj = tmp;
+         }
+         else
+              Perl_croak(aTHX_ "lobj is not of type version");
+
+         {
+              PUSHs(vstringify(lobj));
+         }
+
+         PUTBACK;
+         return;
+     }
 }
 
 XS(XS_version_numify)
 {
-    dXSARGS;
-    if (items < 1)
-       Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
-    SP -= items;
-    {
-       SV *    lobj;
-
-        if (sv_derived_from(ST(0), "version")) {
-                SV *tmp = SvRV(ST(0));
-               lobj = tmp;
-        }
-        else
-                Perl_croak(aTHX_ "lobj is not of type version");
-
-{
-    PUSHs(vnumify(lobj));
-}
-
-       PUTBACK;
-       return;
-    }
+     dXSARGS;
+     if (items < 1)
+         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
+     SP -= items;
+     {
+         SV *  lobj;
+
+         if (sv_derived_from(ST(0), "version")) {
+              SV *tmp = SvRV(ST(0));
+              lobj = tmp;
+         }
+         else
+              Perl_croak(aTHX_ "lobj is not of type version");
+
+         {
+              PUSHs(vnumify(lobj));
+         }
+
+         PUTBACK;
+         return;
+     }
 }
 
 XS(XS_version_vcmp)
 {
-    dXSARGS;
-    if (items < 1)
-       Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
-    SP -= items;
-    {
-       SV *    lobj;
-
-        if (sv_derived_from(ST(0), "version")) {
-                SV *tmp = SvRV(ST(0));
-               lobj = tmp;
-        }
-        else
-                Perl_croak(aTHX_ "lobj is not of type version");
+     dXSARGS;
+     if (items < 1)
+         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
+     SP -= items;
+     {
+         SV *  lobj;
+
+         if (sv_derived_from(ST(0), "version")) {
+              SV *tmp = SvRV(ST(0));
+              lobj = tmp;
+         }
+         else
+              Perl_croak(aTHX_ "lobj is not of type version");
+
+         {
+              SV       *rs;
+              SV       *rvs;
+              SV * robj = ST(1);
+              IV        swap = (IV)SvIV(ST(2));
+
+              if ( ! sv_derived_from(robj, "version") )
+              {
+                   robj = new_version(robj);
+              }
+              rvs = SvRV(robj);
+
+              if ( swap )
+              {
+                   rs = newSViv(vcmp(rvs,lobj));
+              }
+              else
+              {
+                   rs = newSViv(vcmp(lobj,rvs));
+              }
+
+              PUSHs(rs);
+         }
+
+         PUTBACK;
+         return;
+     }
+}
 
+XS(XS_version_boolean)
 {
-    SV *rs;
-    SV *rvs;
-    SV * robj = ST(1);
-    IV  swap = (IV)SvIV(ST(2));
-
-    if ( ! sv_derived_from(robj, "version") )
-    {
-       robj = new_version(robj);
-    }
-    rvs = SvRV(robj);
-
-    if ( swap )
-    {
-        rs = newSViv(vcmp(rvs,lobj));
-    }
-    else
-    {
-        rs = newSViv(vcmp(lobj,rvs));
-    }
-
-    PUSHs(rs);
+     dXSARGS;
+     if (items < 1)
+         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
+     SP -= items;
+     {
+         SV *  lobj;
+
+         if (sv_derived_from(ST(0), "version")) {
+              SV *tmp = SvRV(ST(0));
+              lobj = tmp;
+         }
+         else
+              Perl_croak(aTHX_ "lobj is not of type version");
+
+         {
+              SV       *rs;
+              rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
+              PUSHs(rs);
+         }
+
+         PUTBACK;
+         return;
+     }
 }
 
-       PUTBACK;
-       return;
-    }
+XS(XS_version_noop)
+{
+     dXSARGS;
+     if (items < 1)
+         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
+     {
+         SV *  lobj;
+
+         if (sv_derived_from(ST(0), "version")) {
+              SV *tmp = SvRV(ST(0));
+              lobj = tmp;
+         }
+         else
+              Perl_croak(aTHX_ "lobj is not of type version");
+
+         {
+              Perl_croak(aTHX_ "operation not supported with version object");
+         }
+
+     }
+     XSRETURN_EMPTY;
 }
 
-XS(XS_version_boolean)
+XS(XS_version_is_alpha)
 {
     dXSARGS;
-    if (items < 1)
-       Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
+    if (items != 1)
+       Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
     SP -= items;
     {
-       SV *    lobj;
+       SV *lobj;
 
         if (sv_derived_from(ST(0), "version")) {
                 SV *tmp = SvRV(ST(0));
@@ -491,58 +547,53 @@ XS(XS_version_boolean)
         }
         else
                 Perl_croak(aTHX_ "lobj is not of type version");
-
 {
-    SV *rs;
-    rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
-    PUSHs(rs);
+    I32 len = av_len((AV *)lobj);
+    I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
+    if ( digit < 0 )
+       XSRETURN_YES;
+    else
+       XSRETURN_NO;
 }
-
        PUTBACK;
        return;
     }
 }
 
-XS(XS_version_noop)
-{
-    dXSARGS;
-    if (items < 1)
-       Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
-    {
-       SV *    lobj;
-
-        if (sv_derived_from(ST(0), "version")) {
-                SV *tmp = SvRV(ST(0));
-               lobj = tmp;
-        }
-        else
-                Perl_croak(aTHX_ "lobj is not of type version");
-
+XS(XS_utf8_is_utf8)
 {
-    Perl_croak(aTHX_ "operation not supported with version object");
-}
-
-    }
-    XSRETURN_EMPTY;
+     dXSARGS;
+     if (items != 1)
+         Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
+     {
+         SV *  sv = ST(0);
+         {
+              if (SvUTF8(sv))
+                   XSRETURN_YES;
+              else
+                   XSRETURN_NO;
+         }
+     }
+     XSRETURN_EMPTY;
 }
 
 XS(XS_utf8_valid)
 {
-    dXSARGS;
-    if (items != 1)
-       Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
-    {
-       SV *    sv = ST(0);
- {
-  STRLEN len;
-  char *s = SvPV(sv,len);
-  if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
-   XSRETURN_YES;
-  else
-   XSRETURN_NO;
- }
-    }
-    XSRETURN_EMPTY;
+     dXSARGS;
+     if (items != 1)
+         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
+     {
+         SV *  sv = ST(0);
+         {
+              STRLEN len;
+              char *s = SvPV(sv,len);
+              if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
+                   XSRETURN_YES;
+              else
+                   XSRETURN_NO;
+         }
+     }
+     XSRETURN_EMPTY;
 }
 
 XS(XS_utf8_encode)
@@ -704,7 +755,7 @@ XS(XS_Internals_hv_clear_placehold)
             && items) {
             SV *val = hv_iterval(hv, entry);
 
-            if (val == &PL_sv_undef) {
+            if (val == &PL_sv_placeholder) {
 
                 /* It seems that I have to go back in the front of the hash
                    API to delete a hash, even though I have a HE structure