Package: perl-tk
Version: 1:804.036+dfsg1-6
Severity: important
Tags: upstream patch
Forwarded: https://rt.cpan.org/Public/Bug/Display.html?id=155323
There's an issue with this module where instantiating a Tk::MainWindow
multiple times leads to segmentation faults in Tk_GetOptionValue().
It is undeterministic and hence rather hard to debug.
I ran into it while testing libconfig-model-itself-perl against
Perl 5.42 (currently in experimental). It was mostly reproducible
with the perl_5.42.2-1/amd64 binary, but disappeared again
with 5.42.2-2. The same issue is also reported upstream at
<https://rt.cpan.org/Public/Bug/Display.html?id=155323>.
I have spent quite some time poking at this, and I believe what is
happening is that certain cached pointers in Tcl objects don't get
invalidated when the Tcl interpreter is destroyed, and can get reused
while still pointing to the old (and now invalid) data.
Specifically, creating Tk Option objects requires traversing
through option tables (see TkConfig.c:GetOption()), and the result
gets cached in the internal representation of Tcl objects (see
TkConfig.c:GetOptionFromObj()). This internal representation is not
zeroed when the current Tcl interpreter is destroyed, so if the
memory gets reused for a new Option, the cache in objPtr.internalRep
looks valid but points to a freed (or reused) memory area.
I've been struggling about how to make a useful report about this, given
it's so hard to reproduce. Fortunately I found that electric-fence catches
this case quite nicely, regardless of the Perl build. The attached test
script, slightly adapted from the one in the upstream ticket, segfaults
for me on all of bookworm, trixie, sid, and experimental.
Below is a backtrace from sid with debugperl (from perl-debug) and
perl-tk 1:804.036+dfsg1-6 rebuilt with DEB_BUILD_OPTIONS="noopt nostrip",
running the test script with
$ xvfb-run env LD_PRELOAD=/usr/lib/libefence.so.0.0 debugperl stress-tk.pl
Core was generated by `/usr/bin/debugperl stress-tk.pl'.
Program terminated with signal SIGSEGV, Segmentation fault.
#0 Tk_GetOptionValue (interp=0x7fb1d372c358, recordPtr=0x7fb1c95e3f28
"`\236?\311\261\177", optionTable=0x7fb1c9759e90, namePtr=0x7fb1cac1c940,
tkwin=0x7fb1c93f9e60)
at ./pTk/tkConfig.c:2280
warning: 2280 ./pTk/tkConfig.c: No such file or directory
(gdb) bt
#0 Tk_GetOptionValue (interp=0x7fb1d372c358, recordPtr=0x7fb1c95e3f28
"`\236?\311\261\177", optionTable=0x7fb1c9759e90, namePtr=0x7fb1cac1c940,
tkwin=0x7fb1c93f9e60)
at ./pTk/tkConfig.c:2280
#1 0x00007fb1cd5c210b in FrameWidgetObjCmd (clientData=0x7fb1c95e3f28,
interp=0x7fb1d372c358, objc=3, objv=0x7fb1d3cdfc08) at ./pTk/tkFrame.c:772
#2 0x00007fb1cd581d5c in Call_Tk (info=0x7fb1c95e7f9c, items=3,
args=0x7fb1d3cdfc08) at ./tkGlue.c:2277
#3 0x00007fb1cd582f2d in XStoWidget (my_perl=0x7fb1d3ccd148,
cv=0x7fb1cce42358) at ./tkGlue.c:2644
#4 0x0000558efa6bb94f in Perl_rpp_invoke_xs (my_perl=0x7fb1d3ccd148,
cv=0x7fb1cce42358) at ./build-debug/inline.h:1193
#5 Perl_pp_entersub (my_perl=0x7fb1d3ccd148) at ./build-debug/pp_hot.c:6495
#6 0x0000558efa60dbea in Perl_runops_debug (my_perl=0x7fb1d3ccd148) at
./build-debug/dump.c:2866
#7 0x0000558efa5f735a in S_run_body (my_perl=0x7fb1d3ccd148, oldscope=1)
at ./build-debug/perl.c:2860
#8 perl_run (my_perl=0x7fb1d3ccd148) at ./build-debug/perl.c:2780
#9 0x0000558efa5c1d5c in main (argc=<optimized out>, argv=<optimized out>,
env=<optimized out>) at ./build-debug/perlmain.c:127
I'm also attaching a patch/workaround, which bakes the current interpreter
address to the cache key (ptr1) with xor, so another interpreter won't use
the old cached value in ptr2 as long as the interpreter memory addresses
differ. This seems to work great for me, fixing all instances of the
problem. I'm not sure how portable the unsigned long casts in the patch
are; there's probably a better way to do that.
I suppose we could use something better than xor, but I suspect that
full blown digests are so expensive that there would be no point in
caching in the first place.
I also tried another approach of adding a freeIntRepProc function
to the tkOptionObjType structure, and using it to zero out the cached
pointer when the corresponding Option got freed. I couldn't get
that to work: the freeIntRepProc function sometimes got called
in time and sometimes not.
Please consider this patch, or any other better fix of course. The issue
is very real even though it's hard to reproduce. There seem to be several
packages in Debian (at least libconfig-model-*) having a test pattern
that can trigger this.
I'll update the upstream ticket next with my findings.
Thanks for your work on Debian,
--
Niko Tyni [email protected]
#!/usr/bin/perl
# Note that an additional forced initialisation did not help as it blocked
# the mainloop.
#########################################################################
use v5.14;
#use strictures;
#no indirect 'fatal';
#no multidimensional;
use Time::HiRes 'usleep';
use Tk;
foreach (1..100)
{
print $_;
my $mw = MainWindow->new(-title => 'Dialog');
print '.';
$mw->focus;
print '.';
$mw->grab;
print '.';
my $button;
$button = $mw
->Button(-text => 'Close',
-command => sub {
local $_ = $mw;
$_->grabRelease;
$button = undef;
$mw = undef;
$_->destroy;
})
->grid(-row => 0, -column => 0);
print '.';
$button->invoke;
print '.';
MainLoop;
say '.';
usleep(50000); # wait 50 ms (1/20 s)
}
say 'DONE (no segmentation fault???)';
>From fb3b7bc55b76b8d543a81ddbcf22d5c0b39aca47 Mon Sep 17 00:00:00 2001
From: Niko Tyni <[email protected]>
Date: Sat, 13 Jun 2026 17:25:46 +0100
Subject: [PATCH] Prevent reusing cached Option pointers between Tcl
interpreters
Mixing the interpreter address to the cache key protects it from use by
another interpreter, which could otherwise see a reused memory area as
containing a valid cached pointer.
Bug: https://rt.cpan.org/Public/Bug/Display.html?id=155323
---
pTk/mTk/generic/tkConfig.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/pTk/mTk/generic/tkConfig.c b/pTk/mTk/generic/tkConfig.c
index 5c43d7c..054e231 100644
--- a/pTk/mTk/generic/tkConfig.c
+++ b/pTk/mTk/generic/tkConfig.c
@@ -1211,7 +1211,7 @@ GetOptionFromObj(interp, objPtr, tablePtr)
*/
if (objPtr->typePtr == &tkOptionObjType) {
- if (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr) {
+ if (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) ((unsigned long) tablePtr ^ (unsigned long) interp)) {
return (Option *) objPtr->internalRep.twoPtrValue.ptr2;
}
}
@@ -1230,7 +1230,7 @@ GetOptionFromObj(interp, objPtr, tablePtr)
&& (objPtr->typePtr->freeIntRepProc != NULL)) {
objPtr->typePtr->freeIntRepProc(objPtr);
}
- objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) ((unsigned long) tablePtr ^ (unsigned long) interp);
objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) bestPtr;
TclObjSetType(objPtr,&tkOptionObjType);
return bestPtr;
--
2.53.0
