X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/00bf72ff155f3450b111622b688bd0036a18326c..636a19183afddcfee3e377f79668687caee21a8f:/universal.c

diff --git a/universal.c b/universal.c
index a748d45..4da6fc5 100644
--- a/universal.c
+++ b/universal.c
@@ -33,8 +33,8 @@
 #include "perliol.h" /* For the PERLIO_F_XXX */
 #endif
 
-HV *
-Perl_get_isa_hash(pTHX_ HV *const stash)
+static HV *
+S_get_isa_hash(pTHX_ HV *const stash)
 {
     dVAR;
     struct mro_meta *const meta = HvMROMETA(stash);
@@ -78,7 +78,7 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name)
 {
     dVAR;
     const struct mro_meta *const meta = HvMROMETA(stash);
-    HV *const isa = meta->isa ? meta->isa : Perl_get_isa_hash(aTHX_ stash);
+    HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash);
     STRLEN len = strlen(name);
     const HV *our_stash;
 
@@ -221,6 +221,7 @@ XS(XS_version_noop);
 #endif
 XS(XS_version_is_alpha);
 XS(XS_version_qv);
+XS(XS_version_is_qv);
 XS(XS_utf8_is_utf8);
 XS(XS_utf8_valid);
 XS(XS_utf8_encode);
@@ -233,11 +234,9 @@ XS(XS_Internals_SvREADONLY);
 XS(XS_Internals_SvREFCNT);
 XS(XS_Internals_hv_clear_placehold);
 XS(XS_PerlIO_get_layers);
-XS(XS_Regexp_DESTROY);
 XS(XS_Internals_hash_seed);
 XS(XS_Internals_rehash_seed);
 XS(XS_Internals_HvREHASH);
-XS(XS_Internals_inc_sub_generation);
 XS(XS_re_is_regexp); 
 XS(XS_re_regname);
 XS(XS_re_regnames);
@@ -269,6 +268,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
 	/* Make it findable via fetchmethod */
 	newXS("version::()", XS_version_noop, file);
 	newXS("version::new", XS_version_new, file);
+	newXS("version::parse", XS_version_new, file);
 	newXS("version::(\"\"", XS_version_stringify, file);
 	newXS("version::stringify", XS_version_stringify, file);
 	newXS("version::(0+", XS_version_numify, file);
@@ -283,6 +283,8 @@ Perl_boot_core_UNIVERSAL(pTHX)
 	newXS("version::noop", XS_version_noop, file);
 	newXS("version::is_alpha", XS_version_is_alpha, file);
 	newXS("version::qv", XS_version_qv, file);
+	newXS("version::declare", XS_version_qv, file);
+	newXS("version::is_qv", XS_version_is_qv, file);
     }
     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
     newXS("utf8::valid", XS_utf8_valid, file);
@@ -298,7 +300,9 @@ Perl_boot_core_UNIVERSAL(pTHX)
                XS_Internals_hv_clear_placehold, file, "\\%");
     newXSproto("PerlIO::get_layers",
                XS_PerlIO_get_layers, file, "*;@");
-    newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
+    /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
+    CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
+	= (char *)file;
     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
@@ -729,25 +733,54 @@ XS(XS_version_qv)
 {
     dVAR;
     dXSARGS;
-    if (items != 1)
-	croak_xs_usage(cv, "ver");
+    PERL_UNUSED_ARG(cv);
     SP -= items;
     {
-	SV *	ver = ST(0);
-	if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
-	    SV * const rv = sv_newmortal();
+	SV * ver = ST(0);
+	SV * rv;
+	const char * classname = "";
+	if ( items == 2 && (ST(1)) != &PL_sv_undef ) {
+	    /* getting called as object or class method */
+	    ver = ST(1);
+	    classname = 
+		sv_isobject(ST(0)) /* class called as an object method */
+		    ? HvNAME_get(SvSTASH(SvRV(ST(0))))
+		    : (char *)SvPV_nolen(ST(0));
+	}
+	if ( !SvVOK(ver) ) { /* not already a v-string */
+	    rv = sv_newmortal();
 	    sv_setsv(rv,ver); /* make a duplicate */
 	    upg_version(rv, TRUE);
-	    PUSHs(rv);
+	} else {
+	    rv = sv_2mortal(new_version(ver));
 	}
-	else
-	{
-	    mPUSHs(new_version(ver));
+	if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
+	    sv_bless(rv, gv_stashpv(classname, GV_ADD));
 	}
+	PUSHs(rv);
+    }
+    PUTBACK;
+    return;
+}
 
+XS(XS_version_is_qv)
+{
+    dVAR;
+    dXSARGS;
+    if (items != 1)
+	croak_xs_usage(cv, "lobj");
+    SP -= items;
+    if (sv_derived_from(ST(0), "version")) {
+	SV * const lobj = ST(0);
+	if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
+	    XSRETURN_YES;
+	else
+	    XSRETURN_NO;
 	PUTBACK;
 	return;
     }
+    else
+	Perl_croak(aTHX_ "lobj is not of type version");
 }
 
 XS(XS_utf8_is_utf8)
@@ -927,12 +960,6 @@ XS(XS_Internals_hv_clear_placehold)
     }
 }
 
-XS(XS_Regexp_DESTROY)
-{
-    PERL_UNUSED_CONTEXT;
-    PERL_UNUSED_ARG(cv);
-}
-
 XS(XS_PerlIO_get_layers)
 {
     dVAR;
@@ -1025,7 +1052,7 @@ XS(XS_PerlIO_get_layers)
 					       (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
 					       | SVs_TEMP)
 			      : &PL_sv_undef);
-		       XPUSHs(namok
+		       XPUSHs(flgok
 			      ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
 			      : &PL_sv_undef);
 		       nitem += 3;