gitea
/
Koha-clms
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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 <sanjarbiy11@gmail.com>
Signed-off-by: David Cook <dcook@prosentient.com.au>
Signed-off-by: Martin Renvoize <martin.renvoize@openfifth.co.uk>
Signed-off-by: Baptiste Wojtkowski <baptiste.wojtkowski@biblibre.com>
Signed-off-by: Lucas Gass <lucas@bywatersolutions.com>
(cherry picked from commit ac067c0dbb743a0d7e0918e9dc419194620245e8)
Signed-off-by: Lucas Gass <lucas@bywatersolutions.com>
This commit is contained in:
Sanjar Tulkinov Anvar o'g'li 2026-06-24 22:56:19 -04:00 committed by Lucas Gass
parent 64bea0833a
commit e283e72131
No known key found for this signature in database
GPG Key ID: 60B447398B0D36CA
2 changed files with 294 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

190
Koha/Regex/Replacement.pm Normal file
View File

@ -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 <https://www.gnu.org/licenses>.
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<s///ee>, which evaluated the replacement as Perl code and
so allowed arbitrary code execution (see bug 30233).
This module expands the replacement string as B<data> 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;

104
t/Koha/Regex/Replacement.t Normal file
View File

@ -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 <https://www.gnu.org/licenses>.
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', '(?<user>\w+)', '$+{user}' ), 'jdoe', '$+{name}' );
is( subst( 'jdoe', '(?<user>\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'
);
};