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.

diff --git a/embed.fnc b/embed.fnc
index 704a5dd..6bdc12f 100644 (file)
--- 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 7bce0eb..da7a5fd 100644 (file)
--- 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 999762f..fffbdca 100644 (file)
--- 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 b1b2af5..16fae9a 100644 (file)
--- 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 */