From c2b65f61df0796fd6835f378caf048544ed93e68 Mon Sep 17 00:00:00 2001 From: Paul Johnson Date: Sat, 19 Sep 2026 01:40:40 +0200 Subject: [PATCH 1/3] Don't read past the end of the input Ticket GH-68 - After the string grows, the byte at its end holds whatever the buffer held before, so an entity name that ran to the end could match a "name;" key on that stale byte. --- t/entities.t | 18 +++++++++++++++++- util.c | 4 ++-- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/t/entities.t b/t/entities.t index 012e7bb..aa44db1 100644 --- a/t/entities.t +++ b/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 => 33; my $x = "Våre norske tegn bør æres"; @@ -112,6 +112,22 @@ 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" + ); +} + # From: Bill Simpson-Young # Subject: HTML entities problem with 5.11 # To: libwww-perl@ics.uci.edu diff --git a/util.c b/util.c index da91adf..70bf666 100644 --- a/util.c +++ b/util.c @@ -175,7 +175,7 @@ decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix) if (ent_name != s && entity2char) { SV** svp; 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); @@ -224,7 +224,7 @@ decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix) s++; t--; /* '&' already copied, undo it */ - if (*s != '&') { + if (s >= end || *s != '&') { high_surrogate = 0; } From df657bf43ebf87f7a87f46cf598c7479767e7777 Mon Sep 17 00:00:00 2001 From: Paul Johnson Date: Fri, 18 Sep 2026 23:16:48 +0200 Subject: [PATCH 2/3] Fix self-referential entity expansion Ticket GH-68 - Copy the string before the first write and expand from that copy, so `_decode_entities` gives the same result whether the entity table holds the string itself or a separate copy of it. - Drop the buffer added for CVE-2026-8829, which is not needed now that no pointer into the string survives a realloc. - Die if looking up a value runs Perl code that changes the string, since we hold pointers into it. Hold a reference to the string for the duration of the call and free the copy from the savestack, so neither is lost when that code dies. --- Changes | 2 + lib/HTML/Entities.pm | 8 ++++ t/entities.t | 103 +++++++++++++++++++++++++++++++++++++++++-- util.c | 65 ++++++++++++++++++--------- 4 files changed, 154 insertions(+), 24 deletions(-) diff --git a/Changes b/Changes index ab70bd5..b6850bc 100644 --- a/Changes +++ b/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) diff --git a/lib/HTML/Entities.pm b/lib/HTML/Entities.pm index 3a79398..e17c1a4 100644 --- a/lib/HTML/Entities.pm +++ b/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 ) diff --git a/t/entities.t b/t/entities.t index aa44db1..610823d 100644 --- a/t/entities.t +++ b/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 => 33; +use Test::More tests => 42; my $x = "Våre norske tegn bør æres"; @@ -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; @@ -128,6 +127,104 @@ is($x, $ent); ); } +# 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} = " X"; + _decode_entities($p{nb}, \%p, 1); + is($p{nb}, " XspX", + "_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" + ); +} +{ + 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 # Subject: HTML entities problem with 5.11 # To: libwww-perl@ics.uci.edu diff --git a/util.c b/util.c index 70bf666..3068b8e 100644 --- a/util.c +++ b/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,22 +190,22 @@ 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 < 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) { @@ -197,14 +213,14 @@ decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix) 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; @@ -212,14 +228,19 @@ decode_entities(pTHX_ SV* sv, HV* entity2char, bool expand_prefix) 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 */ @@ -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; } From 1511c9cf38259eeb7b3576fab1b46433237ba127 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Sat, 19 Sep 2026 21:35:44 +0000 Subject: [PATCH 3/3] Add regression test for reallocation during entity-value fetch A tied entity table whose FETCH frees and reallocates the string being decoded must be caught by the mutation guard rather than left to read through a dangling pointer. Co-Authored-By: Claude Opus 4.8 --- t/entities.t | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/t/entities.t b/t/entities.t index 610823d..83ab6d7 100644 --- a/t/entities.t +++ b/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 => 42; +use Test::More tests => 43; my $x = "Våre norske tegn bør æres"; @@ -194,6 +194,25 @@ is($x, $ent); "_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");