X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=22be54f128f0266789d454ad3c3730094064cc48;hb=ca9279baf07d6843f58a31f1ce3ff7dc875faf1a;hp=f5ce23e5a3119cb73c0f3c029f3a0167d43a336d;hpb=4c79ee7a1e7564ef83d0ac25d6677fdebb3ec7aa;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index f5ce23e..22be54f 100644
--- a/universal.c
+++ b/universal.c
@@ -1,6 +1,7 @@
 /*    universal.c
  *
- *    Copyright (c) 1997-2003, Larry Wall
+ *    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.
@@ -17,6 +18,10 @@
 #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
@@ -166,6 +171,7 @@ 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);
@@ -176,6 +182,8 @@ 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)
@@ -203,6 +211,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
 	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);
@@ -214,6 +223,9 @@ Perl_boot_core_UNIVERSAL(pTHX)
     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);
 }
 
 
@@ -373,166 +385,183 @@ 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");
-
-{
-    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;
-    }
+     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;
-    }
+     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");
+     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;
 }
 
-    }
-    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;
+     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)
@@ -714,3 +743,134 @@ XS(XS_Internals_hv_clear_placehold)
 
     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);
+}
+