From b0298e02ca6740365323c1c5e39a954dbf53e48b Mon Sep 17 00:00:00 2001 From: Sanjar Tulkinov Anvar o'g'li Date: Wed, 24 Jun 2026 22:56:19 -0400 Subject: [PATCH] Bug 30233: Add Koha::Regex::Replacement to expand replacements as data Add a small single-pass helper, Koha::Regex::Replacement::expand_template, that expands a user-supplied regex replacement string as data: numbered backreferences ($1..$n, ${n}, the legacy \1..\9 form), named captures ($+{name}, ${name}) and the \n \r \t escapes. Every other character is copied through literally, so \@{...}/${...} interpolation blocks end up as text rather than being run. This is used to replace the s///ee double-eval. The routine is fully qualified at the call sites rather than exported, and case folding is left out to keep it small. Signed-off-by: Sanjar Tulkinov Anvar o'g'li Signed-off-by: David Cook Signed-off-by: Martin Renvoize Signed-off-by: Baptiste Wojtkowski Signed-off-by: Lucas Gass Signed-off-by: Wainui Witika-Park --- Koha/Regex/Replacement.pm | 190 +++++++++++++++++++++++++++++++++++++ t/Koha/Regex/Replacement.t | 104 ++++++++++++++++++++ 2 files changed, 294 insertions(+) create mode 100644 Koha/Regex/Replacement.pm create mode 100644 t/Koha/Regex/Replacement.t diff --git a/Koha/Regex/Replacement.pm b/Koha/Regex/Replacement.pm new file mode 100644 index 0000000000..c93eb38d30 --- /dev/null +++ b/Koha/Regex/Replacement.pm @@ -0,0 +1,190 @@ +package Koha::Regex::Replacement; + +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# Koha is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Koha; if not, see . + +use Modern::Perl; + +=head1 NAME + +Koha::Regex::Replacement - expand a regular-expression replacement string as data + +=head1 SYNOPSIS + + use Koha::Regex::Replacement; + + if ( $value =~ /$search/ ) { + my $text = Koha::Regex::Replacement::expand_template( + $replacement, # the user-supplied replacement string + [ @{^CAPTURE} ], # numbered capture groups from the match ($1 is element 0) + { %+ }, # named capture groups from the match + ); + } + +=head1 DESCRIPTION + +Koha lets staff run regular-expression find and replace over MARC fields, item +fields and call numbers. The replacement half of those substitutions used to be +run through Perl's C, which evaluated the replacement as Perl code and +so allowed arbitrary code execution (see bug 30233). + +This module expands the replacement string as B instead of evaluating it. +It walks the string once, from left to right, and only acts on the handful of +placeholders a replacement legitimately contains: + +=over + +=item * numbered backreferences: C<$1> .. C<$n>, C<${n}>, and the older + C<\1> .. C<\9> form + +=item * named captures: C<$+{name}> and C<${name}> + +=item * the escapes C<\n>, C<\r> and C<\t>, plus C<\\> and C<\$> for a literal + backslash or dollar sign + +=back + +Every other character is copied through unchanged. Because the string is never +evaluated, interpolation blocks such as C<@{[ ... ]}> and C<${ ... }> end up in +the output as ordinary text rather than being run as Perl. + +Case-folding escapes (C<\U>, C<\L>, C<\u>, C<\l>, C<\E>) are deliberately left +out. They are a display nicety rather than a requirement, and omitting them +keeps this routine small and easy to follow. They can be added later if a real +call-number or MARC workflow turns out to need them. + +=head1 FUNCTIONS + +=head2 expand_template + + my $text = Koha::Regex::Replacement::expand_template( $replacement, \@captures, \%named_captures ); + +Returns C<$replacement> with the placeholders listed above resolved. Numbered +backreferences are looked up in C<\@captures> (element 0 is group 1, matching +C<@{^CAPTURE}>) and named captures in C<\%named_captures> (matching C<%+>). A +reference to a group that did not match, or to a name that is not present, +expands to the empty string. The input is treated purely as data and is never +run as code. + +=cut + +sub expand_template { + my ( $replacement, $captures, $named_captures ) = @_; + $captures //= []; + $named_captures //= {}; + + my $output = ''; + my @characters = split //, $replacement; + my $position = 0; + + while ( $position < @characters ) { + my $character = $characters[$position]; + + # Backslash escapes: \n \r \t, the legacy \1 .. \9 backreference, and + # \\ or \$ for a literal backslash or dollar. Any other \X is emitted as + # a literal X, so a stray backslash can never introduce executable syntax. + if ( $character eq '\\' && $position + 1 < @characters ) { + my $escaped = $characters[ $position + 1 ]; + + if ( $escaped eq 'n' ) { $output .= "\n"; } + elsif ( $escaped eq 'r' ) { $output .= "\r"; } + elsif ( $escaped eq 't' ) { $output .= "\t"; } + elsif ( $escaped =~ /[1-9]/ ) { # legacy \1 .. \9 backreference + my $group_value = $captures->[ $escaped - 1 ]; + $output .= defined $group_value ? $group_value : ''; + } + else { # \\ -> \, \$ -> $, any other \X -> X + $output .= $escaped; + } + + $position += 2; + next; + } + + if ( $character eq '$' ) { + + # ${name} or ${number}: read up to the closing brace, then treat a + # number as a positional group and anything else as a named group. + if ( $position + 1 < @characters && $characters[ $position + 1 ] eq '{' ) { + my $scan = $position + 2; + my $name = ''; + $name .= $characters[ $scan++ ] while $scan < @characters && $characters[$scan] ne '}'; + + if ( $scan < @characters ) { # found the closing brace + if ( $name =~ /^[0-9]+\z/ ) { + my $group_value = $name >= 1 ? $captures->[ $name - 1 ] : undef; + $output .= defined $group_value ? $group_value : ''; + } else { + my $named_value = $named_captures->{$name}; + $output .= defined $named_value ? $named_value : ''; + } + $position = $scan + 1; + next; + } + + # An unterminated ${ : emit the dollar literally and carry on. + $output .= '$'; + $position += 1; + next; + } + + # $+{name}: a named capture written with the %+ syntax. + if ( $position + 2 < @characters + && $characters[ $position + 1 ] eq '+' + && $characters[ $position + 2 ] eq '{' ) + { + my $scan = $position + 3; + my $name = ''; + $name .= $characters[ $scan++ ] while $scan < @characters && $characters[$scan] ne '}'; + + if ( $scan < @characters ) { + my $named_value = $named_captures->{$name}; + $output .= defined $named_value ? $named_value : ''; + $position = $scan + 1; + next; + } + + $output .= '$'; + $position += 1; + next; + } + + # $1 .. $n: a plain numbered backreference (a run of digits after $). + if ( $position + 1 < @characters && $characters[ $position + 1 ] =~ /[0-9]/ ) { + my $scan = $position + 1; + my $group_number = ''; + $group_number .= $characters[ $scan++ ] while $scan < @characters && $characters[$scan] =~ /[0-9]/; + + my $group_value = $group_number >= 1 ? $captures->[ $group_number - 1 ] : undef; + $output .= defined $group_value ? $group_value : ''; + $position = $scan; + next; + } + + # A lone $ that is not a backreference is a literal dollar sign. + $output .= '$'; + $position += 1; + next; + } + + # Anything that is not a recognised placeholder is copied verbatim. + $output .= $character; + $position += 1; + } + + return $output; +} + +1; diff --git a/t/Koha/Regex/Replacement.t b/t/Koha/Regex/Replacement.t new file mode 100644 index 0000000000..fdf75c6ba8 --- /dev/null +++ b/t/Koha/Regex/Replacement.t @@ -0,0 +1,104 @@ +#!/usr/bin/perl + +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# Koha is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Koha; if not, see . + +use Modern::Perl; + +use Test::NoWarnings; +use Test::More tests => 5; +use File::Temp qw( tempdir ); +use File::Spec; + +use Koha::Regex::Replacement; + +# Helper: run a real substitution the way the MARC and call-number sinks do, +# using expand_template as the replacement so $1..$n and %+ are populated per +# match. +sub subst { + my ( $value, $search, $replacement, $modifiers ) = @_; + $modifiers //= ''; + my $expand = sub { Koha::Regex::Replacement::expand_template( $replacement, [@{^CAPTURE}], {%+} ) }; + if ( $modifiers eq 'g' ) { $value =~ s/$search/$expand->()/ge } + elsif ( $modifiers eq 'i' ) { $value =~ s/$search/$expand->()/ie } + else { $value =~ s/$search/$expand->()/e } + return $value; +} + +subtest 'dollar capture-group backreferences' => sub { + plan tests => 6; + is( subst( 'foo bar', '(\w+) (\w+)', '$2 $1' ), 'bar foo', '$1 and $2 swap' ); + is( subst( 'foo bar', '(\w+) (\w+)', '${2}-${1}' ), 'bar-foo', '${n} braced form' ); + is( subst( 'abc', '(a)(b)(c)', '$3$2$1' ), 'cba', 'three groups reversed' ); + is( subst( 'x', '(x)', '[$1]' ), '[x]', 'backref surrounded by literals' ); + is( subst( 'x', '(x)', '$2' ), '', 'out-of-range group is empty' ); + is( + subst( 'a1 b2 c3', '(\w)(\d)', '$2$1', 'g' ), + '1a 2b 3c', + 'captures reset for each match under /g' + ); +}; + +subtest 'named captures' => sub { + plan tests => 2; + is( subst( 'jdoe', '(?\w+)', '$+{user}' ), 'jdoe', '$+{name}' ); + is( subst( 'jdoe', '(?\w+)', '${user}' ), 'jdoe', '${name}' ); +}; + +subtest 'legacy \1 backreferences and fixed escapes' => sub { + plan tests => 6; + + # The legacy \1 .. \9 form (bug 23873 / call-number usage). This is what the + # first cut of the expander missed and what Andrew's example relies on. + is( subst( 'foo bar', '(\w+) (\w+)', '\2 \1' ), 'bar foo', '\1 and \2 swap' ); + is( + subst( '20260623', '(\d{4})(\d{2})(\d{2})', '\1\-\2\-\3' ), + '2026-06-23', + 'Andrew example: \1\-\2\-\3 yields a dashed date' + ); + is( + subst( '20260623', '(\d{4})(\d{2})(\d{2})', '$1-$2-$3' ), + '2026-06-23', + 'the $1-$2-$3 form gives the same result' + ); + + is( subst( 'z', '.', 'a\nb' ), "a\nb", '\n becomes a newline' ); + is( subst( 'z', '.', 'a\tb' ), "a\tb", '\t becomes a tab' ); + is( subst( 'x', '(x)', '\$1' ), '$1', '\$ emits a literal dollar, not a backref' ); +}; + +subtest 'malicious replacements are inert (no code execution)' => sub { + plan tests => 4; + + my $dir = tempdir( CLEANUP => 1 ); + my $a = File::Spec->catfile( $dir, 'a' ); + my $b = File::Spec->catfile( $dir, 'b' ); + my $c = File::Spec->catfile( $dir, 'c' ); + + # Run each interpolation-block payload through a real substitution. + subst( 'Z', '.', qq{\@{[ system("touch $a") ]}}, 'g' ); + subst( 'Z', '.', qq{\${\\ system("touch $b") }}, 'g' ); + subst( 'Z', '.', qq{\@{[ `touch $c` ]}}, 'g' ); + + ok( !-e $a, 'array interpolation @{[ ... ]} did not run system()' ); + ok( !-e $b, 'scalar interpolation ${\ ... } did not run system()' ); + ok( !-e $c, 'backticks did not run' ); + + is( + Koha::Regex::Replacement::expand_template('@{[ system("id") ]}'), + '@{[ system("id") ]}', + 'an interpolation block is emitted verbatim as data' + ); +};