1			/*    universal.c
     2			 *
     3			 *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
     4			 *    2005, by Larry Wall and others
     5			 *
     6			 *    You may distribute under the terms of either the GNU General Public
     7			 *    License or the Artistic License, as specified in the README file.
     8			 *
     9			 */
    10			
    11			/*
    12			 * "The roots of those mountains must be roots indeed; there must be
    13			 * great secrets buried there which have not been discovered since the
    14			 * beginning." --Gandalf, relating Gollum's story
    15			 */
    16			
    17			/* This file contains the code that implements the functions in Perl's
    18			 * UNIVERSAL package, such as UNIVERSAL->can().
    19			 */
    20			
    21			#include "EXTERN.h"
    22			#define PERL_IN_UNIVERSAL_C
    23			#include "perl.h"
    24			
    25			#ifdef USE_PERLIO
    26			#include "perliol.h" /* For the PERLIO_F_XXX */
    27			#endif
    28			
    29			/*
    30			 * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
    31			 * The main guts of traverse_isa was actually copied from gv_fetchmeth
    32			 */
    33			
    34			STATIC SV *
    35			S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
    36			             int len, int level)
    37	       28867    {
    38	       28867        AV* av;
    39	       28867        GV* gv;
    40	       28867        GV** gvp;
    41	       28867        HV* hv = Nullhv;
    42	       28867        SV* subgen = Nullsv;
    43	       28867        const char *hvname;
    44			
    45			    /* A stash/class can go by many names (ie. User == main::User), so 
    46			       we compare the stash itself just in case */
    47	       28867        if (name_stash && (stash == name_stash))
    48	       23661            return &PL_sv_yes;
    49			
    50	        5206        hvname = HvNAME_get(stash);
    51			
    52	        5206        if (strEQ(hvname, name))
    53	      ######    	return &PL_sv_yes;
    54			
    55	        5206        if (strEQ(name, "UNIVERSAL"))
    56	           6    	return &PL_sv_yes;
    57			
    58	        5200        if (level > 100)
    59	      ######    	Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
    60					   hvname);
    61			
    62	        5200        gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
    63			
    64	        5200        if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
    65				&& (hv = GvHV(gv)))
    66			    {
    67	        4414    	if (SvIV(subgen) == (IV)PL_sub_generation) {
    68	        3819    	    SV* sv;
    69	        3819    	    SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
    70	        3819    	    if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
    71				        DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
    72	        3068    				  name, hvname) );
    73	        3068    		return sv;
    74				    }
    75				}
    76				else {
    77				    DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
    78	         595    			      hvname) );
    79	         595    	    hv_clear(hv);
    80	         595    	    sv_setiv(subgen, PL_sub_generation);
    81				}
    82			    }
    83			
    84	        2132        gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
    85			
    86	        2132        if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
    87	        1662    	if (!hv || !subgen) {
    88	         316    	    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
    89			
    90	         316    	    gv = *gvp;
    91			
    92	         316    	    if (SvTYPE(gv) != SVt_PVGV)
    93	         316    		gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
    94			
    95	         316    	    if (!hv)
    96	         316    		hv = GvHVn(gv);
    97	         316    	    if (!subgen) {
    98	         316    		subgen = newSViv(PL_sub_generation);
    99	         316    		GvSV(gv) = subgen;
   100				    }
   101				}
   102	        1662    	if (hv) {
   103	        1662    	    SV** svp = AvARRAY(av);
   104				    /* NOTE: No support for tied ISA */
   105	        1662    	    I32 items = AvFILLp(av) + 1;
   106	        3640    	    while (items--) {
   107	        2055    		SV* sv = *svp++;
   108	        2055    		HV* basestash = gv_stashsv(sv, FALSE);
   109	        2055    		if (!basestash) {
   110	      ######    		    if (ckWARN(WARN_MISC))
   111	      ######    			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
   112							    "Can't locate package %"SVf" for @%s::ISA",
   113							    sv, hvname);
   114	      ######    		    continue;
   115					}
   116	        2055    		if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 
   117			                                             len, level + 1)) {
   118	          77    		    (void)hv_store(hv,name,len,&PL_sv_yes,0);
   119	          77    		    return &PL_sv_yes;
   120					}
   121				    }
   122	        1585    	    (void)hv_store(hv,name,len,&PL_sv_no,0);
   123				}
   124			    }
   125	        2055        return &PL_sv_no;
   126			}
   127			
   128			/*
   129			=head1 SV Manipulation Functions
   130			
   131			=for apidoc sv_derived_from
   132			
   133			Returns a boolean indicating whether the SV is derived from the specified
   134			class.  This is the function that implements C<UNIVERSAL::isa>.  It works
   135			for class names as well as for objects.
   136			
   137			=cut
   138			*/
   139			
   140			bool
   141			Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
   142	       66286    {
   143	       66286        const char *type = Nullch;
   144	       66286        HV *stash = Nullhv;
   145	       66286        HV *name_stash;
   146			
   147	       66286        if (SvGMAGICAL(sv))
   148	          10            mg_get(sv) ;
   149			
   150	       66286        if (SvROK(sv)) {
   151	       31543            sv = SvRV(sv);
   152	       31543            type = sv_reftype(sv,0);
   153	       31543            if (SvOBJECT(sv))
   154	       26523                stash = SvSTASH(sv);
   155			    }
   156			    else {
   157	       34743            stash = gv_stashsv(sv, FALSE);
   158			    }
   159			
   160	       66286        name_stash = gv_stashpv(name, FALSE);
   161			
   162	       66286        return (type && strEQ(type,name)) ||
   163			            (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 
   164			             == &PL_sv_yes)
   165			        ? TRUE
   166			        : FALSE ;
   167			}
   168			
   169			#include "XSUB.h"
   170			
   171			PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
   172			PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
   173			PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
   174			XS(XS_version_new);
   175			XS(XS_version_stringify);
   176			XS(XS_version_numify);
   177			XS(XS_version_normal);
   178			XS(XS_version_vcmp);
   179			XS(XS_version_boolean);
   180			#ifdef HASATTRIBUTE_NORETURN
   181			XS(XS_version_noop) __attribute__noreturn__;
   182			#else
   183			XS(XS_version_noop);
   184			#endif
   185			XS(XS_version_is_alpha);
   186			XS(XS_version_qv);
   187			XS(XS_utf8_is_utf8);
   188			XS(XS_utf8_valid);
   189			XS(XS_utf8_encode);
   190			XS(XS_utf8_decode);
   191			XS(XS_utf8_upgrade);
   192			XS(XS_utf8_downgrade);
   193			XS(XS_utf8_unicode_to_native);
   194			XS(XS_utf8_native_to_unicode);
   195			XS(XS_Internals_SvREADONLY);
   196			XS(XS_Internals_SvREFCNT);
   197			XS(XS_Internals_hv_clear_placehold);
   198			XS(XS_PerlIO_get_layers);
   199			XS(XS_Regexp_DESTROY);
   200			XS(XS_Internals_hash_seed);
   201			XS(XS_Internals_rehash_seed);
   202			XS(XS_Internals_HvREHASH);
   203			
   204			void
   205			Perl_boot_core_UNIVERSAL(pTHX)
   206	        4500    {
   207	        4500        const char file[] = __FILE__;
   208			
   209	        4500        newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
   210	        4500        newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
   211	        4500        newXS("UNIVERSAL::VERSION", 	XS_UNIVERSAL_VERSION, 	  file);
   212			    {
   213				/* register the overloading (type 'A') magic */
   214	        4500    	PL_amagic_generation++;
   215				/* Make it findable via fetchmethod */
   216	        4500    	newXS("version::()", XS_version_noop, file);
   217	        4500    	newXS("version::new", XS_version_new, file);
   218	        4500    	newXS("version::(\"\"", XS_version_stringify, file);
   219	        4500    	newXS("version::stringify", XS_version_stringify, file);
   220	        4500    	newXS("version::(0+", XS_version_numify, file);
   221	        4500    	newXS("version::numify", XS_version_numify, file);
   222	        4500    	newXS("version::normal", XS_version_normal, file);
   223	        4500    	newXS("version::(cmp", XS_version_vcmp, file);
   224	        4500    	newXS("version::(<=>", XS_version_vcmp, file);
   225	        4500    	newXS("version::vcmp", XS_version_vcmp, file);
   226	        4500    	newXS("version::(bool", XS_version_boolean, file);
   227	        4500    	newXS("version::boolean", XS_version_boolean, file);
   228	        4500    	newXS("version::(nomethod", XS_version_noop, file);
   229	        4500    	newXS("version::noop", XS_version_noop, file);
   230	        4500    	newXS("version::is_alpha", XS_version_is_alpha, file);
   231	        4500    	newXS("version::qv", XS_version_qv, file);
   232			    }
   233	        4500        newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
   234	        4500        newXS("utf8::valid", XS_utf8_valid, file);
   235	        4500        newXS("utf8::encode", XS_utf8_encode, file);
   236	        4500        newXS("utf8::decode", XS_utf8_decode, file);
   237	        4500        newXS("utf8::upgrade", XS_utf8_upgrade, file);
   238	        4500        newXS("utf8::downgrade", XS_utf8_downgrade, file);
   239	        4500        newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
   240	        4500        newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
   241	        4500        newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
   242	        4500        newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
   243			    newXSproto("Internals::hv_clear_placeholders",
   244	        4500                   XS_Internals_hv_clear_placehold, file, "\\%");
   245			    newXSproto("PerlIO::get_layers",
   246	        4500                   XS_PerlIO_get_layers, file, "*;@");
   247	        4500        newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
   248	        4500        newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
   249	        4500        newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
   250	        4500        newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
   251			}
   252			
   253			
   254			XS(XS_UNIVERSAL_isa)
   255	       25166    {
   256	       25166        dXSARGS;
   257	       25166        SV *sv;
   258	       25166        const char *name;
   259			
   260	       25166        if (items != 2)
   261	      ######    	Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
   262			
   263	       25166        sv = ST(0);
   264			
   265	       25166        if (SvGMAGICAL(sv))
   266	          10    	mg_get(sv);
   267			
   268	       25166        if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
   269					|| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
   270	         953    	XSRETURN_UNDEF;
   271			
   272	       24213        name = SvPV_nolen_const(ST(1));
   273			
   274	       24213        ST(0) = boolSV(sv_derived_from(sv, name));
   275	       24213        XSRETURN(1);
   276			}
   277			
   278			XS(XS_UNIVERSAL_can)
   279	       88611    {
   280	       88611        dXSARGS;
   281	       88611        SV   *sv;
   282	       88611        const char *name;
   283	       88611        SV   *rv;
   284	       88611        HV   *pkg = NULL;
   285			
   286	       88611        if (items != 2)
   287	      ######    	Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
   288			
   289	       88611        sv = ST(0);
   290			
   291	       88611        if (SvGMAGICAL(sv))
   292	           2    	mg_get(sv);
   293			
   294	       88611        if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
   295					|| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
   296	           9    	XSRETURN_UNDEF;
   297			
   298	       88602        name = SvPV_nolen_const(ST(1));
   299	       88602        rv = &PL_sv_undef;
   300			
   301	       88602        if (SvROK(sv)) {
   302	       80103            sv = (SV*)SvRV(sv);
   303	       80103            if (SvOBJECT(sv))
   304	       80054                pkg = SvSTASH(sv);
   305			    }
   306			    else {
   307	        8499            pkg = gv_stashsv(sv, FALSE);
   308			    }
   309			
   310	       88602        if (pkg) {
   311	       88545            GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
   312	       88545            if (gv && isGV(gv))
   313	       39502    	    rv = sv_2mortal(newRV((SV*)GvCV(gv)));
   314			    }
   315			
   316	       88602        ST(0) = rv;
   317	       88602        XSRETURN(1);
   318			}
   319			
   320			XS(XS_UNIVERSAL_VERSION)
   321	         277    {
   322	         277        dXSARGS;
   323	         277        HV *pkg;
   324	         277        GV **gvp;
   325	         277        GV *gv;
   326	         277        SV *sv;
   327	         277        const char *undef;
   328			
   329	         277        if (SvROK(ST(0))) {
   330	           3            sv = (SV*)SvRV(ST(0));
   331	           3            if (!SvOBJECT(sv))
   332	      ######                Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
   333	           3            pkg = SvSTASH(sv);
   334			    }
   335			    else {
   336	         274            pkg = gv_stashsv(ST(0), FALSE);
   337			    }
   338			
   339	         277        gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
   340			
   341	         277        if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
   342	         276            SV *nsv = sv_newmortal();
   343	         276            sv_setsv(nsv, sv);
   344	         276            sv = nsv;
   345	         276    	if ( !sv_derived_from(sv, "version"))
   346	         276    	    upg_version(sv);
   347	         276            undef = Nullch;
   348			    }
   349			    else {
   350	           1            sv = (SV*)&PL_sv_undef;
   351	           1            undef = "(undef)";
   352			    }
   353			
   354	         277        if (items > 1) {
   355	         243    	SV *req = ST(1);
   356			
   357	         243    	if (undef) {
   358	           1    	    if (pkg) {
   359	      ######    		const char *name = HvNAME_get(pkg);
   360	      ######    		Perl_croak(aTHX_
   361						   "%s does not define $%s::VERSION--version check failed",
   362						   name, name);
   363				    } else {
   364	           1    		Perl_croak(aTHX_
   365						     "%s defines neither package nor VERSION--version check failed",
   366	           1    			     SvPVx_nolen_const(ST(0)) );
   367				     }
   368				}
   369			
   370	         242    	if ( !sv_derived_from(req, "version")) {
   371				    /* req may very well be R/O, so create a new object */
   372	         242    	    SV *nsv = sv_newmortal();
   373	         242    	    sv_setsv(nsv, req);
   374	         242    	    req = nsv;
   375	         242    	    upg_version(req);
   376				}
   377			
   378	         242    	if ( vcmp( req, sv ) > 0 )
   379	          15    	    Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
   380					    "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg),
   381					    vnumify(req),vnormal(req),vnumify(sv),vnormal(sv));
   382			    }
   383			
   384	         261        if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
   385	         261    	ST(0) = vnumify(sv);
   386			    } else {
   387	      ######    	ST(0) = sv;
   388			    }
   389			
   390	         261        XSRETURN(1);
   391			}
   392			
   393			XS(XS_version_new)
   394	          82    {
   395	          82        dXSARGS;
   396	          82        if (items > 3)
   397	      ######    	Perl_croak(aTHX_ "Usage: version::new(class, version)");
   398	          82        SP -= items;
   399			    {
   400	          82            SV *vs = ST(1);
   401	          82    	SV *rv;
   402	          82    	const char *classname;
   403			
   404				/* get the class if called as an object method */
   405	          82    	if ( sv_isobject(ST(0)) ) {
   406	           4    	    classname = HvNAME(SvSTASH(SvRV(ST(0))));
   407				}
   408				else {
   409	          78    	    classname = (char *)SvPV_nolen(ST(0));
   410				}
   411			
   412	          82    	if ( items == 1 ) {
   413				    /* no parameter provided */
   414	           2    	    if ( sv_isobject(ST(0)) ) {
   415					/* copy existing object */
   416	           2    		vs = ST(0);
   417				    }
   418				    else {
   419					/* create empty object */
   420	      ######    		vs = sv_newmortal();
   421	      ######    		sv_setpvn(vs,"",0);
   422				    }
   423				}
   424	          80    	else if ( items == 3 ) {
   425	           4    	    vs = sv_newmortal();
   426	           4    	    Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
   427				}
   428			
   429	          82    	rv = new_version(vs);
   430	          78    	if ( strcmp(classname,"version") != 0 ) /* inherited new() */
   431	          34    	    sv_bless(rv, gv_stashpv(classname,TRUE));
   432			
   433	          78    	PUSHs(sv_2mortal(rv));
   434	          78    	PUTBACK;
   435				return;
   436			    }
   437			}
   438			
   439			XS(XS_version_stringify)
   440	          48    {
   441	          48         dXSARGS;
   442	          48         if (items < 1)
   443	      ######    	  Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
   444	          48         SP -= items;
   445			     {
   446	          48    	  SV *	lobj = Nullsv;
   447			
   448	          48    	  if (sv_derived_from(ST(0), "version")) {
   449	          48    	       lobj = SvRV(ST(0));
   450				  }
   451				  else
   452	      ######    	       Perl_croak(aTHX_ "lobj is not of type version");
   453			
   454	          48    	  PUSHs(sv_2mortal(vstringify(lobj)));
   455			
   456	          48    	  PUTBACK;
   457				  return;
   458			     }
   459			}
   460			
   461			XS(XS_version_numify)
   462	          13    {
   463	          13         dXSARGS;
   464	          13         if (items < 1)
   465	      ######    	  Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
   466	          13         SP -= items;
   467			     {
   468	          13    	  SV *	lobj = Nullsv;
   469			
   470	          13    	  if (sv_derived_from(ST(0), "version")) {
   471	          13    	       lobj = SvRV(ST(0));
   472				  }
   473				  else
   474	      ######    	       Perl_croak(aTHX_ "lobj is not of type version");
   475			
   476	          13    	  PUSHs(sv_2mortal(vnumify(lobj)));
   477			
   478	          13    	  PUTBACK;
   479				  return;
   480			     }
   481			}
   482			
   483			XS(XS_version_normal)
   484	           3    {
   485	           3         dXSARGS;
   486	           3         if (items < 1)
   487	      ######    	  Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
   488	           3         SP -= items;
   489			     {
   490	           3    	  SV *	lobj = Nullsv;
   491			
   492	           3    	  if (sv_derived_from(ST(0), "version")) {
   493	           3    	       lobj = SvRV(ST(0));
   494				  }
   495				  else
   496	      ######    	       Perl_croak(aTHX_ "lobj is not of type version");
   497			
   498	           3    	  PUSHs(sv_2mortal(vnormal(lobj)));
   499			
   500	           3    	  PUTBACK;
   501				  return;
   502			     }
   503			}
   504			
   505			XS(XS_version_vcmp)
   506	        1579    {
   507	        1579         dXSARGS;
   508	        1579         if (items < 1)
   509	      ######    	  Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
   510	        1579         SP -= items;
   511			     {
   512	        1579    	  SV *	lobj = Nullsv;
   513			
   514	        1579    	  if (sv_derived_from(ST(0), "version")) {
   515	        1579    	       lobj = SvRV(ST(0));
   516				  }
   517				  else
   518	      ######    	       Perl_croak(aTHX_ "lobj is not of type version");
   519			
   520				  {
   521	        1579    	       SV	*rs;
   522	        1579    	       SV	*rvs;
   523	        1579    	       SV * robj = ST(1);
   524	        1579    	       IV	 swap = (IV)SvIV(ST(2));
   525			
   526	        1579    	       if ( ! sv_derived_from(robj, "version") )
   527				       {
   528	        1518    		    robj = new_version(robj);
   529				       }
   530	        1579    	       rvs = SvRV(robj);
   531			
   532	        1579    	       if ( swap )
   533				       {
   534	          10    		    rs = newSViv(vcmp(rvs,lobj));
   535				       }
   536				       else
   537				       {
   538	        1569    		    rs = newSViv(vcmp(lobj,rvs));
   539				       }
   540			
   541	        1579    	       PUSHs(sv_2mortal(rs));
   542				  }
   543			
   544	        1579    	  PUTBACK;
   545				  return;
   546			     }
   547			}
   548			
   549			XS(XS_version_boolean)
   550	        1476    {
   551	        1476         dXSARGS;
   552	        1476         if (items < 1)
   553	      ######    	  Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
   554	        1476         SP -= items;
   555			     {
   556	        1476    	  SV *	lobj = Nullsv;
   557			
   558	        1476    	  if (sv_derived_from(ST(0), "version")) {
   559	        1476    	       lobj = SvRV(ST(0));
   560				  }
   561				  else
   562	      ######    	       Perl_croak(aTHX_ "lobj is not of type version");
   563			
   564				  {
   565	        1476    	       SV	*rs;
   566	        1476    	       rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
   567	        1476    	       PUSHs(sv_2mortal(rs));
   568				  }
   569			
   570	        1476    	  PUTBACK;
   571				  return;
   572			     }
   573			}
   574			
   575			XS(XS_version_noop)
   576	          10    {
   577	          10        dXSARGS;
   578	          10        if (items < 1)
   579	      ######    	Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
   580	          10        if (sv_derived_from(ST(0), "version"))
   581	          10    	Perl_croak(aTHX_ "operation not supported with version object");
   582			    else
   583	      ######    	Perl_croak(aTHX_ "lobj is not of type version");
   584			#ifndef HASATTRIBUTE_NORETURN
   585			    XSRETURN_EMPTY;
   586			#endif
   587			}
   588			
   589			XS(XS_version_is_alpha)
   590	           4    {
   591	           4        dXSARGS;
   592	           4        if (items != 1)
   593	      ######    	Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
   594	           4        SP -= items;
   595			    {
   596	           4    	SV * lobj = Nullsv;
   597			
   598	           4            if (sv_derived_from(ST(0), "version"))
   599	           4            	lobj = ST(0);
   600			        else
   601	      ######                    Perl_croak(aTHX_ "lobj is not of type version");
   602			{
   603	           4        if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
   604	           2    	XSRETURN_YES;
   605			    else
   606	           2    	XSRETURN_NO;
   607			}
   608	           4    	PUTBACK;
   609	           4    	return;
   610			    }
   611			}
   612			
   613			XS(XS_version_qv)
   614	           6    {
   615	           6        dXSARGS;
   616	           6        if (items != 1)
   617	      ######    	Perl_croak(aTHX_ "Usage: version::qv(ver)");
   618	           6        SP -= items;
   619			    {
   620	           6    	SV *	ver = ST(0);
   621	           6    	if ( !SvVOK(ver) ) /* only need to do with if not already v-string */
   622				{
   623	           4    	    SV *vs = sv_newmortal();
   624	           4    	    char *version;
   625	           4    	    if ( SvNOK(ver) ) /* may get too much accuracy */
   626				    {
   627	           2    		char tbuf[64];
   628	           2    		sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
   629	           2    		version = savepv(tbuf);
   630				    }
   631				    else
   632				    {
   633	           2    		version = savesvpv(ver);
   634				    }
   635	           4    	    (void)scan_version(version,vs,TRUE);
   636	           4    	    Safefree(version);
   637			
   638	           4    	    PUSHs(vs);
   639				}
   640				else
   641				{
   642	           2    	    PUSHs(sv_2mortal(new_version(ver)));
   643				}
   644			
   645	           6    	PUTBACK;
   646				return;
   647			    }
   648			}
   649			
   650			XS(XS_utf8_is_utf8)
   651	          57    {
   652	          57         dXSARGS;
   653	          57         if (items != 1)
   654	      ######    	  Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
   655			     {
   656	          57              const SV *sv = ST(0);
   657				  {
   658	          57    	       if (SvUTF8(sv))
   659	          28    		    XSRETURN_YES;
   660				       else
   661	          29    		    XSRETURN_NO;
   662				  }
   663			     }
   664	          57         XSRETURN_EMPTY;
   665			}
   666			
   667			XS(XS_utf8_valid)
   668	         524    {
   669	         524         dXSARGS;
   670	         524         if (items != 1)
   671	      ######    	  Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
   672			     {
   673	         524    	  SV *	sv = ST(0);
   674				  {
   675	         524    	       STRLEN len;
   676	         524    	       const char *s = SvPV_const(sv,len);
   677	         524    	       if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
   678	         524    		    XSRETURN_YES;
   679				       else
   680	      ######    		    XSRETURN_NO;
   681				  }
   682			     }
   683	         524         XSRETURN_EMPTY;
   684			}
   685			
   686			XS(XS_utf8_encode)
   687	      268352    {
   688	      268352        dXSARGS;
   689	      268352        if (items != 1)
   690	      ######    	Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
   691			    {
   692	      268352    	SV *	sv = ST(0);
   693			
   694	      268352    	sv_utf8_encode(sv);
   695			    }
   696	      268351        XSRETURN_EMPTY;
   697			}
   698			
   699			XS(XS_utf8_decode)
   700	          17    {
   701	          17        dXSARGS;
   702	          17        if (items != 1)
   703	      ######    	Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
   704			    {
   705	          17    	SV *	sv = ST(0);
   706	          17    	const bool RETVAL = sv_utf8_decode(sv);
   707	          17    	ST(0) = boolSV(RETVAL);
   708	          17    	sv_2mortal(ST(0));
   709			    }
   710	          17        XSRETURN(1);
   711			}
   712			
   713			XS(XS_utf8_upgrade)
   714	          86    {
   715	          86        dXSARGS;
   716	          86        if (items != 1)
   717	      ######    	Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
   718			    {
   719	          86    	SV *	sv = ST(0);
   720	          86    	STRLEN	RETVAL;
   721	          86    	dXSTARG;
   722			
   723	          86    	RETVAL = sv_utf8_upgrade(sv);
   724	          86    	XSprePUSH; PUSHi((IV)RETVAL);
   725			    }
   726	          86        XSRETURN(1);
   727			}
   728			
   729			XS(XS_utf8_downgrade)
   730	          40    {
   731	          40        dXSARGS;
   732	          40        if (items < 1 || items > 2)
   733	      ######    	Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
   734			    {
   735	          40    	SV *	sv = ST(0);
   736	          40            const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
   737	          40            const bool RETVAL = sv_utf8_downgrade(sv, failok);
   738			
   739	          39    	ST(0) = boolSV(RETVAL);
   740	          39    	sv_2mortal(ST(0));
   741			    }
   742	          39        XSRETURN(1);
   743			}
   744			
   745			XS(XS_utf8_native_to_unicode)
   746	      ######    {
   747	      ######     dXSARGS;
   748	      ######     const UV uv = SvUV(ST(0));
   749			
   750	      ######     if (items > 1)
   751	      ######         Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
   752			
   753	      ######     ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
   754	      ######     XSRETURN(1);
   755			}
   756			
   757			XS(XS_utf8_unicode_to_native)
   758	      268273    {
   759	      268273     dXSARGS;
   760	      268273     const UV uv = SvUV(ST(0));
   761			
   762	      268273     if (items > 1)
   763	      ######         Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
   764			
   765	      268273     ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
   766	      268273     XSRETURN(1);
   767			}
   768			
   769			XS(XS_Internals_SvREADONLY)	/* This is dangerous stuff. */
   770	         307    {
   771	         307        dXSARGS;
   772	         307        SV *sv = SvRV(ST(0));
   773			
   774	         307        if (items == 1) {
   775	         109    	 if (SvREADONLY(sv))
   776	          92    	     XSRETURN_YES;
   777				 else
   778	          17    	     XSRETURN_NO;
   779			    }
   780	         198        else if (items == 2) {
   781	         198    	if (SvTRUE(ST(1))) {
   782	         114    	    SvREADONLY_on(sv);
   783	         114    	    XSRETURN_YES;
   784				}
   785				else {
   786				    /* I hope you really know what you are doing. */
   787	          84    	    SvREADONLY_off(sv);
   788	          84    	    XSRETURN_NO;
   789				}
   790			    }
   791	      ######        XSRETURN_UNDEF; /* Can't happen. */
   792			}
   793			
   794			XS(XS_Internals_SvREFCNT)	/* This is dangerous stuff. */
   795	           8    {
   796	           8        dXSARGS;
   797	           8        SV *sv = SvRV(ST(0));
   798			
   799	           8        if (items == 1)
   800	           8    	 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
   801	      ######        else if (items == 2) {
   802			         /* I hope you really know what you are doing. */
   803	      ######    	 SvREFCNT(sv) = SvIV(ST(1));
   804	      ######    	 XSRETURN_IV(SvREFCNT(sv));
   805			    }
   806	      ######        XSRETURN_UNDEF; /* Can't happen. */
   807			}
   808			
   809			XS(XS_Internals_hv_clear_placehold)
   810	          34    {
   811	          34        dXSARGS;
   812	          34        HV *hv = (HV *) SvRV(ST(0));
   813			
   814	          34        if (items != 1)
   815	      ######    	Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
   816	          34        hv_clear_placeholders(hv);
   817	          34        XSRETURN(0);
   818			}
   819			
   820			XS(XS_Regexp_DESTROY)
   821	       31483    {
   822	       31483        PERL_UNUSED_ARG(cv);
   823			}
   824			
   825			XS(XS_PerlIO_get_layers)
   826	          13    {
   827	          13        dXSARGS;
   828	          13        if (items < 1 || items % 2 == 0)
   829	      ######    	Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
   830			#ifdef USE_PERLIO
   831			    {
   832	          13    	SV *	sv;
   833	          13    	GV *	gv;
   834	          13    	IO *	io;
   835	          13    	bool	input = TRUE;
   836	          13    	bool	details = FALSE;
   837			
   838	          13    	if (items > 1) {
   839	           2    	     SV **svp;
   840				     
   841	           4    	     for (svp = MARK + 2; svp <= SP; svp += 2) {
   842	           2    		  SV **varp = svp;
   843	           2    		  SV **valp = svp + 1;
   844	           2    		  STRLEN klen;
   845	           2                      const char *key = SvPV_const(*varp, klen);
   846			
   847	           2    		  switch (*key) {
   848					  case 'i':
   849	           1    		       if (klen == 5 && memEQ(key, "input", 5)) {
   850	           1    			    input = SvTRUE(*valp);
   851	           1    			    break;
   852					       }
   853	           1    		       goto fail;
   854					  case 'o': 
   855	           1    		       if (klen == 6 && memEQ(key, "output", 6)) {
   856	           1    			    input = !SvTRUE(*valp);
   857	           1    			    break;
   858					       }
   859	      ######    		       goto fail;
   860					  case 'd':
   861	      ######    		       if (klen == 7 && memEQ(key, "details", 7)) {
   862	      ######    			    details = SvTRUE(*valp);
   863	      ######    			    break;
   864					       }
   865	      ######    		       goto fail;
   866					  default:
   867					  fail:
   868	      ######    		       Perl_croak(aTHX_
   869							  "get_layers: unknown argument '%s'",
   870							  key);
   871					  }
   872				     }
   873			
   874	           2    	     SP -= (items - 1);
   875				}
   876			
   877	          13    	sv = POPs;
   878	          13    	gv = (GV*)sv;
   879			
   880	          13    	if (!isGV(sv)) {
   881	          12    	     if (SvROK(sv) && isGV(SvRV(sv)))
   882	      ######    		  gv = (GV*)SvRV(sv);
   883				     else
   884	          12    		  gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
   885				}
   886			
   887	          13    	if (gv && (io = GvIO(gv))) {
   888	          13    	     dTARGET;
   889	          13    	     AV* av = PerlIO_get_layers(aTHX_ input ?
   890	          13    					IoIFP(io) : IoOFP(io));
   891	          13    	     I32 i;
   892	          13    	     I32 last = av_len(av);
   893	          13    	     I32 nitem = 0;
   894				     
   895	          47    	     for (i = last; i >= 0; i -= 3) {
   896	          34    		  SV **namsvp;
   897	          34    		  SV **argsvp;
   898	          34    		  SV **flgsvp;
   899	          34    		  bool namok, argok, flgok;
   900			
   901	          34    		  namsvp = av_fetch(av, i - 2, FALSE);
   902	          34    		  argsvp = av_fetch(av, i - 1, FALSE);
   903	          34    		  flgsvp = av_fetch(av, i,     FALSE);
   904			
   905	          34    		  namok = namsvp && *namsvp && SvPOK(*namsvp);
   906	          34    		  argok = argsvp && *argsvp && SvPOK(*argsvp);
   907	          34    		  flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
   908			
   909	          34    		  if (details) {
   910					       XPUSHs(namok
   911						      ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
   912	      ######    			      : &PL_sv_undef);
   913					       XPUSHs(argok
   914						      ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
   915	      ######    			      : &PL_sv_undef);
   916	      ######    		       if (flgok)
   917	      ######    			    XPUSHi(SvIVX(*flgsvp));
   918					       else
   919	      ######    			    XPUSHs(&PL_sv_undef);
   920	      ######    		       nitem += 3;
   921					  }
   922					  else {
   923	          34    		       if (namok && argok)
   924						    XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
   925	           3    					       *namsvp, *argsvp));
   926	          31    		       else if (namok)
   927	          31    			    XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
   928					       else
   929	      ######    			    XPUSHs(&PL_sv_undef);
   930	          34    		       nitem++;
   931	          34    		       if (flgok) {
   932	          34    			    IV flags = SvIVX(*flgsvp);
   933			
   934	          34    			    if (flags & PERLIO_F_UTF8) {
   935	           4    				 XPUSHs(newSVpvn("utf8", 4));
   936	           4    				 nitem++;
   937						    }
   938					       }
   939					  }
   940				     }
   941			
   942	          13    	     SvREFCNT_dec(av);
   943			
   944	          13    	     XSRETURN(nitem);
   945				}
   946			    }
   947			#endif
   948			
   949	      ######        XSRETURN(0);
   950			}
   951			
   952			XS(XS_Internals_hash_seed)
   953	      ######    {
   954			    /* Using dXSARGS would also have dITEM and dSP,
   955			     * which define 2 unused local variables.  */
   956	      ######        dAXMARK;
   957	      ######        PERL_UNUSED_ARG(cv);
   958	      ######        PERL_UNUSED_VAR(mark);
   959	      ######        XSRETURN_UV(PERL_HASH_SEED);
   960			}
   961			
   962			XS(XS_Internals_rehash_seed)
   963	           1    {
   964			    /* Using dXSARGS would also have dITEM and dSP,
   965			     * which define 2 unused local variables.  */
   966	           1        dAXMARK;
   967	           1        PERL_UNUSED_ARG(cv);
   968	           1        PERL_UNUSED_VAR(mark);
   969	           1        XSRETURN_UV(PL_rehash_seed);
   970			}
   971			
   972			XS(XS_Internals_HvREHASH)	/* Subject to change  */
   973	           5    {
   974	           5        dXSARGS;
   975	           5        if (SvROK(ST(0))) {
   976	           5    	const HV *hv = (HV *) SvRV(ST(0));
   977	           5    	if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
   978	           5    	    if (HvREHASH(hv))
   979	           2    		XSRETURN_YES;
   980				    else
   981	           3    		XSRETURN_NO;
   982				}
   983			    }
   984	      ######        Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
   985			}
   986			
   987			/*
   988			 * Local variables:
   989			 * c-indentation-style: bsd
   990			 * c-basic-offset: 4
   991			 * indent-tabs-mode: t
   992			 * End:
   993			 *
   994			 * ex: set ts=8 sts=4 sw=4 noet:
   995			 */