GH-68 Fix self-referential entity expansion

Changes

@@ -1,6 +1,8 @@
 Change history for HTML-Parser
 
 {{$NEXT}}
+    - Expand an entity whose value is the string being decoded to the
+      value that string had when the call began (GH#68)
 
 3.85      2026-05-19
     - Replace deprecated uvuni_to_utf8() with uvchr_to_utf8() (GH#50)

lib/HTML/Entities.pm

@@ -70,6 +70,14 @@ misfeature.
    _decode_entities($string, { nb => "@", nbsp => "\xA0" }, 1);
    print $string;  # will print "foo bar"
 
+An entity whose value is the string being decoded expands to the value
+that string had when the call began.  This routine does not scan
+replacement text again, so any entities inside it are left alone.
+
+Looking up a value can run Perl code, through a tied hash or an
+overloaded object.  If that code modifies the string being decoded,
+this routine dies.
+
 This routine is exported by default.
 
 =item encode_entities( $string )

t/entities.t

@@ -4,7 +4,7 @@ use utf8;
 
 use HTML::Entities
     qw(_decode_entities decode_entities encode_entities encode_entities_numeric);
-use Test::More tests => 32;
+use Test::More tests => 43;
 
 my $x = "Våre norske tegn bør &#230res";
 
@@ -100,8 +100,7 @@ is($x, $ent);
 # CVE-2026-8829
 # _decode_entities heap-use-after-free when the input SV is the same SV as
 # a self-referential entity value. The payload must be large enough to
-# force grow_gap() to realloc the SV's PV; the fix copies the entity value
-# into an owned buffer so repl is not left pointing at the freed allocation.
+# force grow_gap() to realloc the SV's PV.
 {
     my $prefix_a = "A" x 32;
     my $suffix_b = "B" x 8192;
@@ -112,6 +111,139 @@ is($x, $ent);
         "_decode_entities() with self-aliased entity hash value");
 }
 
+# An entity name that runs to the end of the input must not match a
+# "name;" key on a byte beyond the end.  Growing the string moves the
+# tail without its NUL, so that byte holds whatever the buffer held
+# before.  Trim the string in place so a ";" is left just past its end.
+{
+    my %t = ("ab;" => "X" x 40, "a;" => "Y");
+    my $s = "&ab;&a" . (";" x 200);
+    substr($s, 6) = "";
+    _decode_entities($s, \%t);
+    is(
+        $s,
+        ("X" x 40) . "&a",
+        "_decode_entities() does not read past the end of the input"
+    );
+}
+
+# GH#68
+# An entity whose value is the string being decoded expands to the value
+# that string had when the call began, which is what an entity table
+# holding a separate copy of that string has always given.  The first two
+# cases are the examples from the ticket.
+{
+    my %g;
+    $g{foo} = "";
+    $g{bar} = "&foo;X&bar;";
+    _decode_entities($g{bar}, \%g);
+    is($g{bar}, "X&foo;X&bar;",
+        "_decode_entities() expands a self-reference after another entity");
+
+    my %i;
+    $i{foo} = "[.....]";
+    $i{bar} = "&foo;X&bar;Y";
+    _decode_entities($i{bar}, \%i);
+    is($i{bar}, "[.....]X&foo;X&bar;YY",
+        "_decode_entities() leaves no stale bytes at a self-reference");
+
+    my %j;
+    $j{amp} = "&";
+    $j{bar} = "&bar;&";
+    _decode_entities($j{bar}, \%j);
+    is($j{bar}, "&bar;&&",
+        "_decode_entities() keeps decoding after a self-reference");
+
+    my %p;
+    $p{nb} = "&nbspX";
+    _decode_entities($p{nb}, \%p, 1);
+    is($p{nb}, "&nbspXspX",
+        "_decode_entities() expands a self-reference matched as a prefix");
+
+    my %u;
+    $u{smile} = "\x{263a}";
+    $u{bar}   = "\xe9⌣&bar;";
+    _decode_entities($u{bar}, \%u);
+    is(
+        $u{bar},
+        "\x{e9}\x{263a}\x{e9}⌣&bar;",
+        "_decode_entities() expands a self-reference after an upgrade"
+    );
+}
+
+# Looking up an entity value can run Perl code, through a tied hash or
+# an overloaded object.  That code must not be able to pull the string
+# out from under the decoder.
+{
+
+    package UndefOnFetch;
+    require Tie::Hash;
+    our @ISA = ("Tie::StdHash");
+    our $target;
+    sub FETCH { undef $$target; "x" }
+}
+{
+    my %tied;
+    tie %tied, "UndefOnFetch";
+    my $s = "&foo;" . ("a" x 100);
+    $UndefOnFetch::target = \$s;
+    eval { _decode_entities($s, \%tied) };
+    like(
+        $@,
+        qr/modified while fetching an entity value/,
+        "_decode_entities() dies when a tied table undefines the string"
+    );
+}
+{
+    package ReallocateOnFetch;
+    require Tie::Hash;
+    our @ISA = ("Tie::StdHash");
+    our $target;
+    sub FETCH { undef $$target; $$target = "Z" x 1000; undef }
+}
+{
+    my %tied;
+    tie %tied, "ReallocateOnFetch";
+    my $s = "&foo;" . ("a" x 100);
+    $ReallocateOnFetch::target = \$s;
+    eval { _decode_entities($s, \%tied) };
+    like(
+        $@,
+        qr/modified while fetching an entity value/,
+        "_decode_entities() dies when a tied table reallocates the string"
+    );
+}
+{
+    my $s = "&foo;" . ("a" x 100);
+    my %t = (foo => bless {}, "ShrinkOnStringify");
+    {
+
+        package ShrinkOnStringify;
+        use overload
+            '""'     => sub { undef $s; $s = "Z" x 10; "x" },
+            fallback => 1;
+    }
+    eval { _decode_entities($s, \%t) };
+    like(
+        $@,
+        qr/modified while fetching an entity value/,
+        "_decode_entities() dies when a value shrinks the string"
+    );
+}
+{
+    my %h;
+    {
+
+        package DeleteOnStringify;
+        use overload '""' => sub { delete $h{str}; "x" }, fallback => 1;
+    }
+    $h{obj} = bless {}, "DeleteOnStringify";
+    $h{str} = "&obj;" . ("a" x 100);
+    eval { _decode_entities($h{str}, \%h) };
+    is($@, "", "_decode_entities() survives a value deleting the string");
+    ok(!exists $h{str}, "the deleted string stays deleted");
+}
+
 # From: Bill Simpson-Young <bill.simpson-young@cmis.csiro.au>
 # Subject: HTML entities problem with 5.11
 # To: libwww-perl@ics.uci.edu

util.c

@@ -61,6 +61,16 @@ grow_gap(pTHX_ SV* sv, STRLEN grow, char** t, char** s, char** e)
     *e += grow;
 }
 
+static void
+save_original(pTHX_ SV* sv, STRLEN len, char** orig)
+{
+    if (*orig)
+	return;
+    Newx(*orig, len ? len : 1, char);
+    SAVEFREEPV(*orig);
+    Copy(SvPVX(sv), *orig, len, char);
+}
+
 EXTERN SV*
 decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix)
 {
@@ -72,7 +82,8 @@ decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix)
 
     char *repl;
     STRLEN repl_len;
-    char *repl_allocated = 0;
+    char *orig = 0;
+    int orig_utf8 = SvUTF8(sv);
     char buf[UTF8_MAXLEN];
     int repl_utf8;
     int high_surrogate = 0;
@@ -82,6 +93,12 @@ decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix)
     repl_utf8 = 0;
 #endif
 
+    /* Looking up an entity value can run Perl code, which must not be
+     * able to free sv while we hold pointers into it. */
+    ENTER;
+    SvREFCNT_inc_simple_void(sv);
+    SAVEFREESV(sv);
+
     while (s < end) {
 	assert(t <= s);
 
@@ -90,7 +107,6 @@ decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix)
 
 	ent_start = s;
 	repl = 0;
-	repl_allocated = 0;
 
 	if (s < end && *s == '#') {
 	    UV num = 0;
@@ -174,57 +190,62 @@ decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix)
 		s++;
 	    if (ent_name != s && entity2char) {
 		SV** svp;
+		char *pvx = SvPVX(sv);
+		STRLEN cur = SvCUR(sv);
+		STRLEN alloc = SvLEN(sv);
+		U32 utf8 = SvUTF8(sv);
 		if (              (svp = hv_fetch(entity2char, ent_name, s - ent_name, 0)) ||
-		    (*s == ';' && (svp = hv_fetch(entity2char, ent_name, s - ent_name + 1, 0)))
+		    (s < end && *s == ';' && (svp = hv_fetch(entity2char, ent_name, s - ent_name + 1, 0)))
 		   )
 		{
-		    char *src = SvPV(*svp, repl_len);
-		    repl_utf8 = SvUTF8(*svp);
 		    if ((SV*)*svp == sv) {
-			/* Self-aliased: hash entry SV == input SV.
-			 * grow_gap() may realloc sv's PV later; copy
-			 * the entity value into an owned buffer first.
-			 * Freed by the repl_allocated cleanup below. */
-			Newx(repl_allocated, repl_len ? repl_len : 1, char);
-			Copy(src, repl_allocated, repl_len, char);
-			repl = repl_allocated;
+			save_original(aTHX_ sv, len, &orig);
+			repl = orig;
+			repl_len = len;
+			repl_utf8 = orig_utf8;
 		    } else {
-			repl = src;
+			repl = SvPV(*svp, repl_len);
+			repl_utf8 = SvUTF8(*svp);
 		    }
 		}
 		else if (expand_prefix) {
 		    char *ss = s - 1;
 		    while (ss > ent_name) {
 			svp = hv_fetch(entity2char, ent_name, ss - ent_name, 0);
 			if (svp) {
-			    char *src = SvPV(*svp, repl_len);
-			    repl_utf8 = SvUTF8(*svp);
 			    if ((SV*)*svp == sv) {
-				Newx(repl_allocated, repl_len ? repl_len : 1, char);
-				Copy(src, repl_allocated, repl_len, char);
-				repl = repl_allocated;
+				save_original(aTHX_ sv, len, &orig);
+				repl = orig;
+				repl_len = len;
+				repl_utf8 = orig_utf8;
 			    } else {
-				repl = src;
+				repl = SvPV(*svp, repl_len);
+				repl_utf8 = SvUTF8(*svp);
 			    }
 			    s = ss;
 			    break;
 			}
 			ss--;
 		    }
 		}
+		/* The lookups may have run Perl code, and we still hold
+		 * pointers into the buffer it could have changed. */
+		if (SvPVX(sv) != pvx || SvCUR(sv) != cur ||
+		    SvLEN(sv) != alloc || SvUTF8(sv) != utf8)
+		    croak("String being decoded was modified"
+			  " while fetching an entity value");
 	    }
 	    high_surrogate = 0;
 	}
 
 	if (repl) {
-	    /* repl_allocated is now function-scoped; set by the
-	     * named-entity self-alias path above or by the UTF8 mismatch
-	     * branch below. Same cleanup in either case. */
+	    char *repl_allocated = 0;
+	    save_original(aTHX_ sv, len, &orig);
 	    if (s < end && *s == ';')
 		s++;
 	    t--;  /* '&' already copied, undo it */
 
-	    if (*s != '&') {
+	    if (s >= end || *s != '&') {
 		high_surrogate = 0;
 	    }
 
@@ -271,6 +292,8 @@ decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix)
     *t = '\0';
     SvCUR_set(sv, t - SvPVX(sv));
 
+    LEAVE;
+
     return sv;
 }