X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=22be54f128f0266789d454ad3c3730094064cc48;hb=702815ca71820e02fb479da23518a6420e31af8b;hp=8b2044393b82bf202b0582cf4b3e300c7d25c070;hpb=0562c0e3630958db13a0e70db1b90c05d3fee158;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index 8b20443..22be54f 100644
--- a/universal.c
+++ b/universal.c
@@ -1,14 +1,35 @@
+/*    universal.c
+ *
+ *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ *    by Larry Wall and others
+ *
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "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"
 
+#ifdef USE_PERLIO
+#include "perliol.h" /* For the PERLIO_F_XXX */
+#endif
+
 /*
  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  */
 
 STATIC SV *
-S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
+S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
+             int len, int level)
 {
     AV* av;
     GV* gv;
@@ -16,8 +37,10 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
     HV* hv = Nullhv;
     SV* subgen = Nullsv;
 
-    if (!stash)
-	return &PL_sv_undef;
+    /* A stash/class can go by many names (ie. User == main::User), so 
+       we compare the stash itself just in case */
+    if (name_stash && (stash == name_stash))
+        return &PL_sv_yes;
 
     if (strEQ(HvNAME(stash), name))
 	return &PL_sv_yes;
@@ -31,7 +54,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
 	&& (hv = GvHV(gv)))
     {
-	if (SvIV(subgen) == PL_sub_generation) {
+	if (SvIV(subgen) == (IV)PL_sub_generation) {
 	    SV* sv;
 	    SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
 	    if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
@@ -75,12 +98,13 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
 		HV* basestash = gv_stashsv(sv, FALSE);
 		if (!basestash) {
 		    if (ckWARN(WARN_MISC))
-			Perl_warner(aTHX_ WARN_SYNTAX,
-		             "Can't locate package %s for @%s::ISA",
-			    SvPVX(sv), HvNAME(stash));
+			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+		             "Can't locate package %"SVf" for @%s::ISA",
+			    sv, HvNAME(stash));
 		    continue;
 		}
-		if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
+		if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 
+                                             len, level + 1)) {
 		    (void)hv_store(hv,name,len,&PL_sv_yes,0);
 		    return &PL_sv_yes;
 		}
@@ -93,6 +117,8 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
 }
 
 /*
+=head1 SV Manipulation Functions
+
 =for apidoc sv_derived_from
 
 Returns a boolean indicating whether the SV is derived from the specified
@@ -107,6 +133,7 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 {
     char *type;
     HV *stash;
+    HV *name_stash;
 
     stash = Nullhv;
     type = Nullch;
@@ -124,17 +151,27 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
         stash = gv_stashsv(sv, FALSE);
     }
 
+    name_stash = gv_stashpv(name, FALSE);
+
     return (type && strEQ(type,name)) ||
-            (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
+            (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 
+             == &PL_sv_yes)
         ? TRUE
         : FALSE ;
 }
 
 #include "XSUB.h"
 
-void XS_UNIVERSAL_isa(pTHXo_ CV *cv);
-void XS_UNIVERSAL_can(pTHXo_ CV *cv);
-void XS_UNIVERSAL_VERSION(pTHXo_ CV *cv);
+void XS_UNIVERSAL_isa(pTHX_ CV *cv);
+void XS_UNIVERSAL_can(pTHX_ CV *cv);
+void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
+XS(XS_version_new);
+XS(XS_version_stringify);
+XS(XS_version_numify);
+XS(XS_version_vcmp);
+XS(XS_version_boolean);
+XS(XS_version_noop);
+XS(XS_utf8_is_utf8);
 XS(XS_utf8_valid);
 XS(XS_utf8_encode);
 XS(XS_utf8_decode);
@@ -142,6 +179,11 @@ XS(XS_utf8_upgrade);
 XS(XS_utf8_downgrade);
 XS(XS_utf8_unicode_to_native);
 XS(XS_utf8_native_to_unicode);
+XS(XS_Internals_SvREADONLY);
+XS(XS_Internals_SvREFCNT);
+XS(XS_Internals_hv_clear_placehold);
+XS(XS_PerlIO_get_layers);
+XS(XS_Regexp_DESTROY);
 
 void
 Perl_boot_core_UNIVERSAL(pTHX)
@@ -151,6 +193,25 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
     newXS("UNIVERSAL::VERSION", 	XS_UNIVERSAL_VERSION, 	  file);
+    {
+	/* register the overloading (type 'A') magic */
+	PL_amagic_generation++;
+	/* Make it findable via fetchmethod */
+	newXS("version::()", XS_version_noop, file);
+	newXS("version::new", XS_version_new, file);
+	newXS("version::(\"\"", XS_version_stringify, file);
+	newXS("version::stringify", XS_version_stringify, file);
+	newXS("version::(0+", XS_version_numify, file);
+	newXS("version::numify", XS_version_numify, file);
+	newXS("version::(cmp", XS_version_vcmp, file);
+	newXS("version::(<=>", XS_version_vcmp, file);
+	newXS("version::vcmp", XS_version_vcmp, file);
+	newXS("version::(bool", XS_version_boolean, file);
+	newXS("version::boolean", XS_version_boolean, file);
+	newXS("version::(nomethod", XS_version_noop, file);
+	newXS("version::noop", XS_version_noop, 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);
@@ -158,6 +219,13 @@ 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("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
+    newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
+    newXSproto("Internals::hv_clear_placeholders",
+               XS_Internals_hv_clear_placehold, file, "\\%");
+    newXSproto("PerlIO::get_layers",
+               XS_PerlIO_get_layers, file, "*;@");
+    newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
 }
 
 
@@ -176,7 +244,8 @@ XS(XS_UNIVERSAL_isa)
     if (SvGMAGICAL(sv))
 	mg_get(sv);
 
-    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
+    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
+		|| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 	XSRETURN_UNDEF;
 
     name = (char *)SvPV(ST(1),n_a);
@@ -202,7 +271,8 @@ XS(XS_UNIVERSAL_can)
     if (SvGMAGICAL(sv))
 	mg_get(sv);
 
-    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
+    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
+		|| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 	XSRETURN_UNDEF;
 
     name = (char *)SvPV(ST(1),n_a);
@@ -263,75 +333,235 @@ 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 (!SvNIOK(sv) && SvPOK(sv)) {
-	    char *str = SvPVx(sv,len);
-	    while (len) {
-		--len;
-		/* XXX could DWIM "1.2.3" here */
-		if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
-		    break;
-	    }
-	    if (len) {
-		if (SvNOK(req) && SvPOK(req)) {
-		    /* they said C<use Foo v1.2.3> and $Foo::VERSION
-		     * doesn't look like a float: do string compare */
-		    if (sv_cmp(req,sv) == 1) {
-			Perl_croak(aTHX_ "%s v%"VDf" required--"
-				   "this is only v%"VDf,
-				   HvNAME(pkg), req, sv);
-		    }
-		    goto finish;
-		}
-		/* they said C<use Foo 1.002_003> and $Foo::VERSION
-		 * doesn't look like a float: force numeric compare */
-		(void)SvUPGRADE(sv, SVt_PVNV);
-		SvNVX(sv) = str_to_version(sv);
-		SvPOK_off(sv);
-		SvNOK_on(sv);
-	    }
-	}
-	/* if we get here, we're looking for a numeric comparison,
-	 * so force the required version into a float, even if they
-	 * said C<use Foo v1.2.3> */
-	if (SvNOK(req) && SvPOK(req)) {
-	    NV n = SvNV(req);
-	    req = sv_newmortal();
-	    sv_setnv(req, n);
+	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 ( !sv_derived_from(sv, "version"))
+	    sv = new_version(sv);
 
-	if (SvNV(req) > SvNV(sv)) {
-	    Perl_croak(aTHX_ "%s version %s required--this is only version %s",
-		       HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv,len));
-	}
+	if ( !sv_derived_from(req, "version"))
+	    req = new_version(req);
+
+	if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
+	    Perl_croak(aTHX_
+		"%s version %"SVf" required--this is only version %"SVf,
+		HvNAME(pkg), req, sv);
     }
 
-finish:
     ST(0) = sv;
 
     XSRETURN(1);
 }
 
-XS(XS_utf8_valid)
+XS(XS_version_new)
 {
     dXSARGS;
-    if (items != 1)
-	Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
+    if (items > 3)
+	Perl_croak(aTHX_ "Usage: version::new(class, version)");
+    SP -= items;
     {
-	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;
- }
+/*	char *	class = (char *)SvPV_nolen(ST(0)); */
+        SV *version = ST(1);
+	if (items == 3 )
+	{
+	    char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
+	    version = Perl_newSVpvf(aTHX_ "v%s",vs);
+	}
+
+	PUSHs(new_version(version));
+	PUTBACK;
+	return;
     }
-    XSRETURN_EMPTY;
+}
+
+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;
+     }
+}
+
+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;
+     }
+}
+
+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");
+
+	  {
+	       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)
+{
+     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;
+     }
+}
+
+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_utf8_is_utf8)
+{
+     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;
 }
 
 XS(XS_utf8_encode)
@@ -426,4 +656,221 @@ XS(XS_utf8_unicode_to_native)
  XSRETURN(1);
 }
 
+XS(XS_Internals_SvREADONLY)	/* This is dangerous stuff. */
+{
+    dXSARGS;
+    SV *sv = SvRV(ST(0));
+    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;
+	}
+    }
+    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. */
+}
+
+/* Maybe this should return the number of placeholders found in scalar context,
+   and a list of them in list context.  */
+XS(XS_Internals_hv_clear_placehold)
+{
+    dXSARGS;
+    HV *hv = (HV *) SvRV(ST(0));
+
+    /* I don't care how many parameters were passed in, but I want to avoid
+       the unused variable warning. */
+
+    items = (I32)HvPLACEHOLDERS(hv);
+
+    if (items) {
+        HE *entry;
+        I32 riter = HvRITER(hv);
+        HE *eiter = HvEITER(hv);
+        hv_iterinit(hv);
+        /* This may look suboptimal with the items *after* the iternext, but
+           it's quite deliberate. We only get here with items==0 if we've
+           just deleted the last placeholder in the hash. If we've just done
+           that then it means that the hash is in lazy delete mode, and the
+           HE is now only referenced in our iterator. If we just quit the loop
+           and discarded our iterator then the HE leaks. So we do the && the
+           other way to ensure iternext is called just one more time, which
+           has the side effect of triggering the lazy delete.  */
+        while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
+            && items) {
+            SV *val = hv_iterval(hv, entry);
+
+            if (val == &PL_sv_undef) {
+
+                /* 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
+                   pointing to the very entry I want to delete, and could hold
+                   onto the previous HE that points to it. And it's easier to
+                   go in with SVs as I can then specify the precomputed hash,
+                   and don't have fun and games with utf8 keys.  */
+                SV *key = hv_iterkeysv(entry);
+
+                hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
+                items--;
+            }
+        }
+        HvRITER(hv) = riter;
+        HvEITER(hv) = eiter;
+    }
+
+    XSRETURN(0);
+}
+
+XS(XS_Regexp_DESTROY)
+{
+
+}
+
+XS(XS_PerlIO_get_layers)
+{
+    dXSARGS;
+    if (items < 1 || items % 2 == 0)
+	Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
+#ifdef USE_PERLIO
+    {
+	SV *	sv;
+	GV *	gv;
+	IO *	io;
+	bool	input = TRUE;
+	bool	details = FALSE;
+
+	if (items > 1) {
+	     SV **svp;
+	     
+	     for (svp = MARK + 2; svp <= SP; svp += 2) {
+		  SV **varp = svp;
+		  SV **valp = svp + 1;
+		  STRLEN klen;
+		  char *key = SvPV(*varp, klen);
+
+		  switch (*key) {
+		  case 'i':
+		       if (klen == 5 && memEQ(key, "input", 5)) {
+			    input = SvTRUE(*valp);
+			    break;
+		       }
+		       goto fail;
+		  case 'o': 
+		       if (klen == 6 && memEQ(key, "output", 6)) {
+			    input = !SvTRUE(*valp);
+			    break;
+		       }
+		       goto fail;
+		  case 'd':
+		       if (klen == 7 && memEQ(key, "details", 7)) {
+			    details = SvTRUE(*valp);
+			    break;
+		       }
+		       goto fail;
+		  default:
+		  fail:
+		       Perl_croak(aTHX_
+				  "get_layers: unknown argument '%s'",
+				  key);
+		  }
+	     }
+
+	     SP -= (items - 1);
+	}
+
+	sv = POPs;
+	gv = (GV*)sv;
+
+	if (!isGV(sv)) {
+	     if (SvROK(sv) && isGV(SvRV(sv)))
+		  gv = (GV*)SvRV(sv);
+	     else
+		  gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
+	}
+
+	if (gv && (io = GvIO(gv))) {
+	     dTARGET;
+	     AV* av = PerlIO_get_layers(aTHX_ input ?
+					IoIFP(io) : IoOFP(io));
+	     I32 i;
+	     I32 last = av_len(av);
+	     I32 nitem = 0;
+	     
+	     for (i = last; i >= 0; i -= 3) {
+		  SV **namsvp;
+		  SV **argsvp;
+		  SV **flgsvp;
+		  bool namok, argok, flgok;
+
+		  namsvp = av_fetch(av, i - 2, FALSE);
+		  argsvp = av_fetch(av, i - 1, FALSE);
+		  flgsvp = av_fetch(av, i,     FALSE);
+
+		  namok = namsvp && *namsvp && SvPOK(*namsvp);
+		  argok = argsvp && *argsvp && SvPOK(*argsvp);
+		  flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
+
+		  if (details) {
+		       XPUSHs(namok ?
+			     newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
+		       XPUSHs(argok ?
+			     newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
+		       if (flgok)
+			    XPUSHi(SvIVX(*flgsvp));
+		       else
+			    XPUSHs(&PL_sv_undef);
+		       nitem += 3;
+		  }
+		  else {
+		       if (namok && argok)
+			    XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
+					       *namsvp, *argsvp));
+		       else if (namok)
+			    XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
+		       else
+			    XPUSHs(&PL_sv_undef);
+		       nitem++;
+		       if (flgok) {
+			    IV flags = SvIVX(*flgsvp);
+
+			    if (flags & PERLIO_F_UTF8) {
+				 XPUSHs(newSVpvn("utf8", 4));
+				 nitem++;
+			    }
+		       }
+		  }
+	     }
+
+	     SvREFCNT_dec(av);
+
+	     XSRETURN(nitem);
+	}
+    }
+#endif
+
+    XSRETURN(0);
+}