Change vverify() to return HV or NULL (RT#78286)

Multiple code paths were dereferencing version objects without
checking the underlying type, which could result in segmentation
faults per RT#78286

This patch consolidates all dereferencing into vverify() and
has vverify return the underlying HV or NULL instead of
a boolean value.

4 files changed, 32 insertions, 31 deletions

diff --git a/embed.fnc b/embed.fnc
index 704a5ddf32..6bdc12f221 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -853,7 +853,7 @@ Apd	|const char*	|prescan_version	|NN const char *s\
 	|NULLOK int *ssaw_decimal|NULLOK int *swidth|NULLOK bool *salpha
 Apd	|SV*	|new_version	|NN SV *ver
 Apd	|SV*	|upg_version	|NN SV *ver|bool qv
-Apd	|bool	|vverify	|NN SV *vs
+Apd	|SV*	|vverify	|NN SV *vs
 Apd	|SV*	|vnumify	|NN SV *vs
 Apd	|SV*	|vnormal	|NN SV *vs
 Apd	|SV*	|vstringify	|NN SV *vs
diff --git a/lib/version.t b/lib/version.t
index 7bce0ebbd9..da7a5fda07 100644
--- a/lib/version.t
+++ b/lib/version.t
@@ -96,9 +96,15 @@ like($@, qr/Invalid version object/,
 eval { my $test = ($testobj > 1.0) };
 like($@, qr/Invalid version object/,
     "Bad subclass vcmp");
-strict_lax_tests();
+
+# Invalid structure
+eval { $a = \\version->new(1); bless $a, "version"; print "# $a\n" };
+like($@, qr/Invalid version object/,
+    "Bad internal structure (RT#78286)");
 
 # do strict lax tests in a sub to isolate a package to test importing
+strict_lax_tests();
+
 sub strict_lax_tests {
   package temp12345;
   # copied from perl core test t/op/packagev.t
diff --git a/proto.h b/proto.h
index 999762f32a..fffbdca52f 100644
--- a/proto.h
+++ b/proto.h
@@ -4635,7 +4635,7 @@ PERL_CALLCONV SV*	Perl_vstringify(pTHX_ SV *vs)
 #define PERL_ARGS_ASSERT_VSTRINGIFY	\
 	assert(vs)
 
-PERL_CALLCONV bool	Perl_vverify(pTHX_ SV *vs)
+PERL_CALLCONV SV*	Perl_vverify(pTHX_ SV *vs)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_VVERIFY	\
 	assert(vs)
diff --git a/util.c b/util.c
index b1b2af5d3b..16fae9a027 100644
--- a/util.c
+++ b/util.c
@@ -5108,27 +5108,30 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 /*
 =for apidoc vverify
 
-Validates that the SV contains a valid version object.
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV).  If
+the structure is valid, it returns the HV.  If the structure is invalid,
+it returns NULL.
 
-    bool vverify(SV *vobj);
+    SV *hv = vverify(sv);
 
 Note that it only confirms the bare minimum structure (so as not to get
 confused by derived classes which may contain additional hash entries):
 
 =over 4
 
-=item * The SV contains a [reference to a] hash
+=item * The SV is an HV or a reference to an HV
 
 =item * The hash contains a "version" key
 
-=item * The "version" key has [a reference to] an AV as its value
+=item * The "version" key has a reference to an AV as its value
 
 =back
 
 =cut
 */
 
-bool
+SV *
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
@@ -5143,9 +5146,9 @@ Perl_vverify(pTHX_ SV *vs)
 	 && hv_exists(MUTABLE_HV(vs), "version", 7)
 	 && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
 	 && SvTYPE(sv) == SVt_PVAV )
-	return TRUE;
+	return vs;
     else
-	return FALSE;
+	return NULL;
 }
 
 /*
@@ -5173,10 +5176,9 @@ Perl_vnumify(pTHX_ SV *vs)
 
     PERL_ARGS_ASSERT_VNUMIFY;
 
-    if ( SvROK(vs) )
-	vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
 	Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
@@ -5252,10 +5254,9 @@ Perl_vnormal(pTHX_ SV *vs)
 
     PERL_ARGS_ASSERT_VNORMAL;
 
-    if ( SvROK(vs) )
-	vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
 	Perl_croak(aTHX_ "Invalid version object");
 
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
@@ -5307,10 +5308,9 @@ Perl_vstringify(pTHX_ SV *vs)
 {
     PERL_ARGS_ASSERT_VSTRINGIFY;
 
-    if ( SvROK(vs) )
-	vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
 	Perl_croak(aTHX_ "Invalid version object");
 
     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
@@ -5350,15 +5350,10 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 
     PERL_ARGS_ASSERT_VCMP;
 
-    if ( SvROK(lhv) )
-	lhv = SvRV(lhv);
-    if ( SvROK(rhv) )
-	rhv = SvRV(rhv);
-
-    if ( !vverify(lhv) )
-	Perl_croak(aTHX_ "Invalid version object");
-
-    if ( !vverify(rhv) )
+    /* extract the HVs from the objects */
+    lhv = vverify(lhv);
+    rhv = vverify(rhv);
+    if ( ! ( lhv && rhv ) )
 	Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */