Package: perl
Version: 5.40.1-3
Severity: normal
Hello dear perl team,
this is a weird one. It appeared while debugging adduser for the
Installer; the Installer people can reproduce that with full adduser as
well. I am presenting here a stripped down example of the issue.
tl;dr: die() hangs with high CPU usage in a certain environment with a
lot of preparation.
I tried this in a debspawn container, but the Installer people,
especially Pascal Hambourg, can see that in their test environments as
well.
Steps to reproduce:
debspawn create --suite sid sid
debspawn login sid
(this is not reproducible on my full system, it must have something to
do with the minimal package set in the container)
copy the attached adduser and AdduserCommon.pm in the container
in the container:
apt purge adduser (just to make sure)
change to the directory where adduser and AdduserCommon.pm were copied
to
mkdir Debian
mv AdduserCommon.pm Debian
export LANG=C.UTF-8
perl -T -I. ./adduser --comment="ÓæÓæßéÀ"
(see it work)
export LANG=C
pull the adduser command line from shell history; the weird characters
will show as some \octals.
see it hang after trace point 4.
This is a minimal reproducer, as minimal as it was possible for me. The
following aspects ARE needed for the bug to show:
- LANG=C
- the weird string must be handed in via command line option, setting the
string inside the code makes the bug go away
- sanitize_string must be in a module in the Debian namespace, moving the
function to the main program or moving Debian::AdduserCommon to
AdduserCommon without the Debian prefix makes the bug go away
- the codeset and charset gymnastics must be present, not setting
STDERR's binmode makes the bug go away
-- System Information:
Debian Release: trixie/sid
APT prefers unstable
APT policy: (500, 'unstable')
Architecture: amd64 (x86_64)
Kernel: Linux 6.12.25-amd64 (SMP w/12 CPU threads; PREEMPT)
Locale: LANG=C, LC_CTYPE=C.UTF-8 (charmap=UTF-8), LANGUAGE not set
Shell: /bin/sh linked to /usr/bin/dash
Init: unable to detect
Versions of packages perl depends on:
ii libperl5.40 5.40.1-3
ii perl-base 5.40.1-3
ii perl-modules-5.40 5.40.1-3
Versions of packages perl recommends:
ii netbase 6.5
Versions of packages perl suggests:
pn libtap-harness-archive-perl <none>
pn libterm-readline-gnu-perl | libterm-readline-perl-perl <none>
ii make 4.4.1-2
pn perl-doc <none>
-- no debconf information
#! /usr/bin/perl -T
# Copyright (C) 1994 Debian Association, Inc.
# 1995 Ted Hajek <[email protected]>
# 1995 Ian A. Murdock <[email protected]>
# 1997-1999 Guy Maor <[email protected]>
# 2000-2004 Roland Bauerschmidt <[email protected]>
# 2004-2025 Marc Haber <[email protected]>
# 2005-2009 Joerg Hoh <[email protected]>
# 2006-2011 Stephen Gran <[email protected]>
# 2016 Dr. Helge Kreutzmann <[email protected]>
# 2016-2017 Afif Elghraoui <[email protected]>
# 2021-2022 Jason Franklin <[email protected]>
# 2022 Matt Barry <[email protected]>
# 2022 Benjamin Drung <[email protected]>
# 2023 Guillem Jover <[email protected]>
#
# Original adduser:
# Copyright (C) 1997-1999 Guy Maor <[email protected]>
#
# Copyright (C) 1995 Ted Hajek <[email protected]>
# Ian A. Murdock <[email protected]>
#
# The general scheme of this program was adapted from the original
# Debian "adduser" program by Ian A. Murdock <[email protected]>.
#
# License: GPL-2+
use Getopt::Long;
use Debian::AdduserCommon;
use Encode;
use I18N::Langinfo;
my $codeset = I18N::Langinfo->CODESET;
print "codeset $codeset\n";
my $charset = langinfo($codeset);
print "charset $charset\n";
binmode(STDERR, ":encoding($charset)");
our $new_comment = undef;
GetOptions(
'comment:s' => \$new_comment,
) or &usage_error;
$new_comment = sanitize_string( $new_comment, commentre);
# vim: tabstop=4 shiftwidth=4 expandtab
package Debian::AdduserCommon;
use 5.40.0;
# Subroutines shared by the "adduser" and "deluser" utilities.
#
# Copyright (C) 2000-2004 Roland Bauerschmidt <[email protected]>
# 2004-2025 Marc Haber <[email protected]>
# 2005-2009 Joerg Hoh <[email protected]>
# 2006-2008 Stephen Gran <[email protected]>
# 2016 Nis Martensen <[email protected]>
# 2016 Afif Elghraoui <[email protected]>
# 2021-2022 Jason Franklin <[email protected]>
# 2022 Matt Barry <[email protected]>
# 2023 Guillem Jover <[email protected]>
#
# Someo of the subroutines here are adopted from Debian's
# original "adduser" program.
#
# Copyright (C) 1997-1999 Guy Maor <[email protected]>
#
# Copyright (C) 1995 Ted Hajek <[email protected]>
# Ian A. Murdock <[email protected]>
#
# License: GPL-2+
use parent qw(Exporter);
use vars qw(@EXPORT);
use constant {
commentre => qr/[-"_\.+!\$%&()\]\[;\/'’ A-Za-z0-9\x{a1}-\x{ac}\x{ae}-\x{ff}\p{L}\p{Nd}\p{Zs}]*/,
};
@EXPORT = (
'sanitize_string',
"commentre",
);
sub sanitize_string {
my ($input, $pattern) = @_;
# Set a default pattern to allow alphanumeric characters,
# spaces, and underscores.
$pattern //= qr/[a-zA-Z0-9 _]*/;
# If the input matches the pattern,
# extract and return the untainted value.
print "trace point 1\n";
print "input: $input\n";
print "trace point 2\n";
if ($input =~ qr/^($pattern)$/ ) {
return $1; # $1 is the captured, untainted portion of the string.
} else {
print "trace point 3\n";
print "input: $input\n";
print "trace point 4\n";
die "invalid characters in $input";
}
}
# vim: tabstop=4 shiftwidth=4 expandtab
