From 423131e792335dd44818a36b8ad3674bcec525c6 Mon Sep 17 00:00:00 2001 From: trexnegr0 Date: Sun, 10 May 2026 19:58:44 +0000 Subject: [PATCH] debconf: avoid string eval when loading plugin modules Replace string eval based plugin loading with a small reusable loader (Debconf::Plugin) that validates debconf plugin / module names before translating them into module paths and loading them via require. This avoids executing dynamically constructed Perl code while preserving the existing dynamic plugin behaviour for valid debconf Format, DbDriver, FrontEnd, and Element plugin names. Invalid plugin names containing path separators, traversal components, spaces, dots, or Perl metacharacters are rejected before path construction, so a configured value never reaches the Perl compiler as source code. Sites converted: * Debconf/DbDriver/File.pm - Debconf::Format:: * Debconf/DbDriver/Directory.pm - Debconf::Format:: * Debconf/DbDriver/Pipe.pm - Debconf::Format:: * Debconf/Db.pm (makedriver) - Debconf::DbDriver:: * Debconf/AutoSelect.pm - Debconf::FrontEnd:: * Debconf/FrontEnd.pm - Debconf::Element:: Tests added under t/ (Test::More): t/plugin.t covers name validation, class/path composition, require failure, and code-execution prevention on metacharacter-laden names; t/dbdriver_format_loader.t exercises the real DbDriver::File and DbDriver::Pipe init paths to confirm no shell payload runs when a malicious "format" value is supplied. The helper module name is open: Debconf::Plugin is the working name; if the maintainers prefer Debconf::Loader or to inline the helper, the move is mechanical. Closes: #1136114 --- Debconf/AutoSelect.pm | 13 +-- Debconf/Db.pm | 5 +- Debconf/DbDriver/Directory.pm | 7 +- Debconf/DbDriver/File.pm | 7 +- Debconf/DbDriver/Pipe.pm | 7 +- Debconf/FrontEnd.pm | 11 +- Debconf/Plugin.pm | 138 ++++++++++++++++++++++++++ t/dbdriver_format_loader.t | 103 +++++++++++++++++++ t/plugin.t | 182 ++++++++++++++++++++++++++++++++++ 9 files changed, 451 insertions(+), 22 deletions(-) create mode 100644 Debconf/Plugin.pm create mode 100644 t/dbdriver_format_loader.t create mode 100644 t/plugin.t diff --git a/Debconf/AutoSelect.pm b/Debconf/AutoSelect.pm index ff7074a..385c84c 100644 --- a/Debconf/AutoSelect.pm +++ b/Debconf/AutoSelect.pm @@ -90,12 +90,13 @@ sub make_frontend { else { warn(sprintf(gettext("falling back to frontend: %s"), $trytype)); } - ## no critic (BuiltinFunctions::ProhibitStringyEval) - $frontend=eval qq{ - use Debconf::FrontEnd::$trytype; - Debconf::FrontEnd::$trytype->new(); - }; - ## use critic + require Debconf::Plugin; + my $frontend_class = eval { Debconf::Plugin::load("Debconf::FrontEnd", $trytype) }; + if (defined $frontend_class) { + $frontend = eval { $frontend_class->new() }; + } else { + $frontend = undef; + } if (defined $frontend) { $type = $trytype; return $frontend; diff --git a/Debconf/Db.pm b/Debconf/Db.pm index 90f0082..fea2443 100644 --- a/Debconf/Db.pm +++ b/Debconf/Db.pm @@ -67,8 +67,9 @@ sub makedriver { # Make sure that the class is loaded.. if (! UNIVERSAL::can("Debconf::DbDriver::$type", 'new')) { - eval qq{use Debconf::DbDriver::$type}; - die $@ if $@; + require Debconf::Plugin; + my $driver_class = eval { Debconf::Plugin::load("Debconf::DbDriver", $type) }; + die $@ unless defined $driver_class; } delete $config{driver}; # not a field for the object diff --git a/Debconf/DbDriver/Directory.pm b/Debconf/DbDriver/Directory.pm index 4896721..885e5cb 100644 --- a/Debconf/DbDriver/Directory.pm +++ b/Debconf/DbDriver/Directory.pm @@ -68,11 +68,12 @@ sub init { $this->{backup} = 1 unless exists $this->{backup}; $this->error("No format specified") unless $this->{format}; - eval "use Debconf::Format::$this->{format}"; - if ($@) { + require Debconf::Plugin; + my $format_class = eval { Debconf::Plugin::load("Debconf::Format", $this->{format}) }; + if (!defined $format_class) { $this->error("Error setting up format object $this->{format}: $@"); } - $this->{format}="Debconf::Format::$this->{format}"->new; + $this->{format} = $format_class->new; if (not ref $this->{format}) { $this->error("Unable to make format object"); } diff --git a/Debconf/DbDriver/File.pm b/Debconf/DbDriver/File.pm index 6a312bf..47853fd 100644 --- a/Debconf/DbDriver/File.pm +++ b/Debconf/DbDriver/File.pm @@ -72,11 +72,12 @@ sub init { $this->{backup} = 1 unless exists $this->{backup}; $this->error("No format specified") unless $this->{format}; - eval "use Debconf::Format::$this->{format}"; - if ($@) { + require Debconf::Plugin; + my $format_class = eval { Debconf::Plugin::load("Debconf::Format", $this->{format}) }; + if (!defined $format_class) { $this->error("Error setting up format object $this->{format}: $@"); } - $this->{format}="Debconf::Format::$this->{format}"->new; + $this->{format} = $format_class->new; if (not ref $this->{format}) { $this->error("Unable to make format object"); } diff --git a/Debconf/DbDriver/Pipe.pm b/Debconf/DbDriver/Pipe.pm index a9da2d2..2287b7a 100644 --- a/Debconf/DbDriver/Pipe.pm +++ b/Debconf/DbDriver/Pipe.pm @@ -63,11 +63,12 @@ sub init { $this->{format} = "822" unless exists $this->{format}; $this->error("No format specified") unless $this->{format}; - eval "use Debconf::Format::$this->{format}"; - if ($@) { + require Debconf::Plugin; + my $format_class = eval { Debconf::Plugin::load("Debconf::Format", $this->{format}) }; + if (!defined $format_class) { $this->error("Error setting up format object $this->{format}: $@"); } - $this->{format}="Debconf::Format::$this->{format}"->new; + $this->{format} = $format_class->new; if (not ref $this->{format}) { $this->error("Unable to make format object"); } diff --git a/Debconf/FrontEnd.pm b/Debconf/FrontEnd.pm index ce06aa2..fd0f59b 100644 --- a/Debconf/FrontEnd.pm +++ b/Debconf/FrontEnd.pm @@ -131,13 +131,14 @@ sub _loadelementclass { my $type=shift; my $nodebug=shift; - # See if we need to load up the object class.. The eval - # inside here is leak-prone if run multiple times on a - # given type, so make sure to only ever do it once per type. + # See if we need to load up the object class. Use the + # Debconf::Plugin loader so the dynamically chosen $type is + # validated and loaded via require, not via string eval. if (! UNIVERSAL::can("Debconf::Element::$type", 'new')) { return if $nouse{$type}; - eval qq{use Debconf::Element::$type}; - if ($@ || ! UNIVERSAL::can("Debconf::Element::$type", 'new')) { + require Debconf::Plugin; + my $element_class = eval { Debconf::Plugin::load("Debconf::Element", $type) }; + if (!defined $element_class || ! UNIVERSAL::can("Debconf::Element::$type", 'new')) { warn sprintf(gettext("Unable to load Debconf::Element::%s. Failed because: %s"), $type, $@) if ! $nodebug; $nouse{$type}=1; return; diff --git a/Debconf/Plugin.pm b/Debconf/Plugin.pm new file mode 100644 index 0000000..1146b73 --- /dev/null +++ b/Debconf/Plugin.pm @@ -0,0 +1,138 @@ +#!/usr/bin/perl + +=head1 NAME + +Debconf::Plugin - safe loader for dynamically chosen debconf plugin modules + +=cut + +package Debconf::Plugin; +use warnings; +use strict; + +=head1 DESCRIPTION + +Several parts of debconf load Perl modules whose names depend on values +read from configuration (debconf.conf, environment variables, command +line, or templates). Examples: + + Debconf::Format:: (DbDriver field "format") + Debconf::DbDriver:: (DbDriver field "driver" / "Config:" line) + Debconf::FrontEnd:: (DEBIAN_FRONTEND, Config "frontend" line) + Debconf::Element:: (per-frontend element subclass) + +Historically these used C, +which pastes the configured value verbatim into a Perl source string and +compiles it. This module replaces that pattern with a small loader that +validates the requested plugin name and uses C on a constructed +file path, so the configured value never reaches the Perl compiler as +source code. + +=head1 SYNOPSIS + + require Debconf::Plugin; + + my $class = eval { Debconf::Plugin::load("Debconf::Format", $format_name) }; + if (!defined $class) { + # $@ holds the failure message (validate or require error) + die "Failed to load Format $format_name: $@"; + } + my $obj = $class->new(); + +=cut + +# A debconf plugin name is one or more identifier segments joined with +# '::'. Each segment is C<[A-Za-z0-9_]+>. This accepts every plugin +# name shipped under Debconf/{Format,DbDriver,FrontEnd,Element}/ today, +# including digit-leading segments like Debconf::Format::822 and the +# multi-segment Element types like Dialog::Boolean. It rejects path +# separators, '..', spaces, dots, semicolons, and Perl metacharacters. +my $NAME_RE = qr{\A[A-Za-z0-9_]+(?:::[A-Za-z0-9_]+)*\z}; + +=head1 FUNCTIONS + +=over 4 + +=item valid_name($name) + +True if C<$name> is a syntactically acceptable debconf plugin name. + +=cut + +sub valid_name { + my ($name) = @_; + return 0 unless defined $name; + return $name =~ $NAME_RE ? 1 : 0; +} + +# Internal: validate $prefix and $name, then return the list of +# identifier segments that make up the fully-qualified module. Dies on +# invalid input. Single point of validation used by class_name(), +# _module_path(), and load(). +sub _segments { + my ($prefix, $name) = @_; + die "Debconf::Plugin: undefined plugin name\n" + unless defined $name; + die "Debconf::Plugin: invalid plugin name '$name'\n" + unless valid_name($name); + my @parts; + if (defined $prefix && length $prefix) { + die "Debconf::Plugin: invalid plugin prefix '$prefix'\n" + unless valid_name($prefix); + push @parts, split(/::/, $prefix); + } + push @parts, split(/::/, $name); + return @parts; +} + +=item class_name($prefix, $name) + +Return the fully-qualified class name C<"$prefix::$name"> (or C<"$name"> +if C<$prefix> is empty/undef). Validates both arguments and dies on +invalid input. + +=cut + +sub class_name { + my ($prefix, $name) = @_; + return join('::', _segments($prefix, $name)); +} + +# Internal: build the .pm file path that 'require' expects. +sub _module_path { + my ($prefix, $name) = @_; + return join('/', _segments($prefix, $name)) . '.pm'; +} + +=item load($prefix, $name) + +Validate C<$prefix> and C<$name>, then C the resulting module. +Returns the fully-qualified class name on success. Dies on either +invalid plugin name or C failure, so callers can use the +ordinary C idiom and inspect C<$@> for the failure +message: + + my $class = eval { Debconf::Plugin::load($prefix, $name) }; + if (!defined $class) { + $this->error("...: $@"); + } + +=cut + +sub load { + my ($prefix, $name) = @_; + my @parts = _segments($prefix, $name); + my $path = join('/', @parts) . '.pm'; + require $path; + return join('::', @parts); +} + +=back + +=head1 AUTHOR + +Submitted as part of fixing Debian Bug#1136114. + +=cut + +1 diff --git a/t/dbdriver_format_loader.t b/t/dbdriver_format_loader.t new file mode 100644 index 0000000..0d48a94 --- /dev/null +++ b/t/dbdriver_format_loader.t @@ -0,0 +1,103 @@ +#!/usr/bin/perl +# Integration test for Bug#1136114: confirm that DbDriver::{File,Pipe} now +# route their dynamic Debconf::Format:: loading through Debconf::Plugin +# and reject path-injection / metacharacter names without executing any of +# the injected payload. +# +# DbDriver::error calls 'exit 1' when {required} is true (the default), +# so the exploit-rejection cases run in a sub-perl child to keep the test +# harness alive. +use strict; +use warnings; +use FindBin; +use lib "$FindBin::Bin/.."; +use File::Temp qw(tempdir tempfile); +use File::Spec; +use Test::More; + +use_ok('Debconf::Plugin'); +use_ok('Debconf::DbDriver::File'); +use_ok('Debconf::DbDriver::Pipe'); + +my $TOPDIR = "$FindBin::Bin/.."; + +# --------------------------------------------------------------------------- +# Regression: legitimate format "822" still loads through the new path. +# --------------------------------------------------------------------------- +{ + my $tmp = tempdir(CLEANUP => 1); + my $dbfile = "$tmp/db"; + my $driver = Debconf::DbDriver::File->new( + name => "regression-822", + filename => $dbfile, + format => "822", + readonly => 1, + ); + ok( ref($driver), "DbDriver::File loads format=822 (regression)" ); + isa_ok( $driver->{format}, 'Debconf::Format::822', + "DbDriver::File->{format} is a Debconf::Format::822 instance" ); +} + +# --------------------------------------------------------------------------- +# Code-execution prevention: a malicious format name that, under the old +# eval STRING regime, would have executed shell at load time. The marker +# file in /tmp must NOT appear. Run inside a sub-perl so the +# DbDriver::error(exit 1) does not kill the test harness. +# --------------------------------------------------------------------------- +sub run_exploit_in_child { + my ($driver_class, $marker) = @_; + my $bad = "822;system(q{touch $marker});1"; + my $script = <<"PERL"; +use strict; use warnings; +use lib q{$TOPDIR}; +use $driver_class; +my \$d = $driver_class->new( + name => 'exploit-attempt', + @{[ $driver_class eq 'Debconf::DbDriver::Pipe' + ? "infd => 'none', outfd => 'none'," : "filename => '/tmp/_unused_db'," ]} + format => q{$bad}, + readonly => 1, +); +PERL + my $cmd = ['perl', '-e', $script]; + # Capture stderr so it does not pollute the test log. + my $pid = open(my $fh, '-|') // die "fork: $!"; + if ($pid == 0) { + open(STDERR, '>', '/dev/null'); + exec @$cmd; + exit 127; + } + close $fh; + waitpid($pid, 0); + return $?; +} + +{ + my (undef, $marker) = tempfile( + 'debconf_bug1136114_XXXXXX', + DIR => File::Spec->tmpdir, OPEN => 0, UNLINK => 0, + ); + unlink $marker; + ok( ! -e $marker, "marker absent before File exploit attempt" ); + my $rc = run_exploit_in_child('Debconf::DbDriver::File', $marker); + ok( $rc != 0, "DbDriver::File child exits non-zero on malicious format" ); + ok( ! -e $marker, + "no marker file created — eval STRING vector closed for File" ); + unlink $marker if -e $marker; +} + +{ + my (undef, $marker) = tempfile( + 'debconf_bug1136114_XXXXXX', + DIR => File::Spec->tmpdir, OPEN => 0, UNLINK => 0, + ); + unlink $marker; + ok( ! -e $marker, "marker absent before Pipe exploit attempt" ); + my $rc = run_exploit_in_child('Debconf::DbDriver::Pipe', $marker); + ok( $rc != 0, "DbDriver::Pipe child exits non-zero on malicious format" ); + ok( ! -e $marker, + "no marker file created — eval STRING vector closed for Pipe" ); + unlink $marker if -e $marker; +} + +done_testing(); diff --git a/t/plugin.t b/t/plugin.t new file mode 100644 index 0000000..750dd4c --- /dev/null +++ b/t/plugin.t @@ -0,0 +1,182 @@ +#!/usr/bin/perl +# Tests for Debconf::Plugin — the safe loader introduced for Bug#1136114. +use strict; +use warnings; +use FindBin; +use lib "$FindBin::Bin/.."; +use File::Temp qw(tempdir); +use File::Spec; +use Test::More; + +BEGIN { use_ok('Debconf::Plugin'); } + +# --------------------------------------------------------------------------- +# Name validation — accept everything debconf actually ships. +# --------------------------------------------------------------------------- +my @valid = ( + '822', # Debconf::Format::822 — digit-leading + 'File', + 'Directory', + 'Pipe', + 'Backup', + 'Cache', + 'Copy', + 'Debug', + 'DirTree', + 'LDAP', + 'PackageDir', + 'Stack', + 'Dialog', + 'Editor', + 'Gnome', + 'Kde', + 'Noninteractive', + 'Passthrough', + 'Readline', + 'ScreenSize', + 'Teletype', + 'Text', + 'Web', + 'Boolean', + 'Multiselect', + 'Password', + 'Progress', + 'Select', + 'String', + 'Note', + 'Error', + 'Dialog::Boolean', # Debconf::Element::Dialog::Boolean + 'Dialog::Multiselect', + 'Noninteractive::Progress', + 'Web::Password', + 'A_B', # underscore-bearing identifier + 'X1', # trailing digit +); +for my $name (@valid) { + ok( Debconf::Plugin::valid_name($name), "valid_name accepts '$name'" ); +} + +# --------------------------------------------------------------------------- +# Name validation — reject path-injection / metacharacter attempts. +# --------------------------------------------------------------------------- +my @invalid = ( + undef, + '', + '../../Foo', + 'Foo/Bar', + '/Foo', + 'Foo\\Bar', + 'Foo.pm', + 'Foo;BEGIN{qx(touch /tmp/debconf_poc)};1', + 'Foo Bar', + 'Foo-Bar', # no current plugin uses '-' + 'A::../../B', + ':Foo', + 'Foo::', + '::Foo', + 'Foo::', + 'Foo::Bar/Baz', + 'Foo::Bar.pm', + 'Foo$', + 'Foo`id`', + "Foo\nBar", + 'Foo;1', +); +for my $name (@invalid) { + my $repr = defined $name ? "'$name'" : 'undef'; + ok( !Debconf::Plugin::valid_name($name), "valid_name rejects $repr" ); +} + +# --------------------------------------------------------------------------- +# class_name + _module_path — round-trip on a few representative names. +# --------------------------------------------------------------------------- +is( Debconf::Plugin::class_name("Debconf::Format", "822"), + "Debconf::Format::822", "class_name composes Debconf::Format::822" ); +is( Debconf::Plugin::class_name("Debconf::DbDriver", "File"), + "Debconf::DbDriver::File", "class_name composes DbDriver::File" ); +is( Debconf::Plugin::class_name("Debconf::Element", "Dialog::Boolean"), + "Debconf::Element::Dialog::Boolean", "class_name handles multi-segment name" ); + +is( Debconf::Plugin::_module_path("Debconf::Format", "822"), + "Debconf/Format/822.pm", "_module_path Format::822" ); +is( Debconf::Plugin::_module_path("Debconf::Element", "Dialog::Boolean"), + "Debconf/Element/Dialog/Boolean.pm", "_module_path Element::Dialog::Boolean" ); + +# --------------------------------------------------------------------------- +# class_name / _module_path die on invalid input — no string ever reaches +# the file system or Perl compiler. +# --------------------------------------------------------------------------- +for my $bad ('../../Foo', 'Foo/Bar', 'Foo;1', 'Foo Bar', '') { + eval { Debconf::Plugin::class_name("Debconf::Format", $bad) }; + like( $@, qr/invalid plugin name/i, + "class_name dies on '$bad'" ); + eval { Debconf::Plugin::_module_path("Debconf::Format", $bad) }; + like( $@, qr/invalid plugin name/i, + "_module_path dies on '$bad'" ); +} + +# --------------------------------------------------------------------------- +# load() — non-existent but syntactically valid name dies with the +# require error reported in $@. Caller idiom: `eval { ::load(...) }`. +# --------------------------------------------------------------------------- +{ + my $r = eval { Debconf::Plugin::load("Debconf::Format", "DoesNotExistXYZ") }; + is( $r, undef, "load via eval returns undef when require fails" ); + like( $@, qr/Can't locate Debconf\/Format\/DoesNotExistXYZ\.pm/, + "\$@ contains the require error" ); +} + +# --------------------------------------------------------------------------- +# load() — invalid plugin name dies and never touches the file system. +# A marker file in a temp @INC entry that *would* be created by a +# would-be malicious payload must stay absent. +# --------------------------------------------------------------------------- +{ + my $tmp = tempdir(CLEANUP => 1); + my $marker = "$tmp/debconf_plugin_test_marker"; + unshift @INC, $tmp; + my $bad = "Foo;system('touch $marker');1"; + my $r = eval { Debconf::Plugin::load("Debconf::Format", $bad) }; + is( $r, undef, "load via eval returns undef on invalid name" ); + like( $@, qr/invalid plugin name/i, + "\$@ identifies the validation failure" ); + ok( ! -e $marker, + "no marker file created — name was rejected pre-path" ); + ok( $@ !~ /Can't locate/, + "no require attempt was made (\$@ does not mention 'Can't locate')" ); +} + +# --------------------------------------------------------------------------- +# load() — happy-path on a real shipped Format module. +# --------------------------------------------------------------------------- +{ + my $class = eval { Debconf::Plugin::load("Debconf::Format", "822") }; + is( $@, '', "no error on successful load" ); + is( $class, "Debconf::Format::822", + "load returns the fully-qualified class name on success" ); + ok( UNIVERSAL::can($class, 'new'), + "loaded class has a new() method" ); +} + +# --------------------------------------------------------------------------- +# Caller idiom: $@ semantics across `eval { load() }`. This protects +# the warn("$@") fallback path used by Debconf::AutoSelect::make_frontend +# and Debconf::FrontEnd::_loadelementclass: after a failing +# `eval { load(...) }` the require / validate error must be visible in +# $@ to the immediate caller. +# --------------------------------------------------------------------------- +{ + # require failure case + my $r = eval { Debconf::Plugin::load("Debconf::Format", "DoesNotExistXYZ2") }; + is( $r, undef, "caller idiom: undef return on require failure" ); + like( $@, qr/Can't locate Debconf\/Format\/DoesNotExistXYZ2/, + "caller idiom: \$@ visible in caller scope after eval" ); + + # validate failure case + my $r2 = eval { Debconf::Plugin::load("Debconf::Format", "../Foo") }; + is( $r2, undef, "caller idiom: undef return on validate failure" ); + like( $@, qr/invalid plugin name/, + "caller idiom: \$@ identifies validation failure in caller scope" ); +} + +done_testing(); -- 2.53.0