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

Bug 30233: Stop running call number split regexes as code 

C4::ClassSplitRoutine::RegEx::split_callnumber ran the admin-configured rule
through eval "\$cn_item =~ $regex", executing arbitrary Perl. Parse the
rule as s<DELIM>PATTERN<DELIM>REPLACEMENT<DELIM>FLAGS, reject the /e flag,
compile the pattern with qr// and expand the replacement as data via
Koha::Regex::Replacement::expand_template, so the rule is applied without
eval.

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 c76e2dcc3360e2c4a7d3123f5625c3426dfe207e)
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 e55fd0407f
commit 0d3185d28a
No known key found for this signature in database
GPG Key ID: 60B447398B0D36CA
1 changed files with 49 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
C4/ClassSplitRoutine/RegEx.pm
View File

@ -19,6 +19,8 @@ package C4::ClassSplitRoutine::RegEx;
use Modern::Perl;
use Koha::Regex::Replacement;
=head1 NAME
C4::ClassSplitRoutine::RegEx - regex call number sorting key routine
@ -41,13 +43,59 @@ sub split_callnumber {
my ( $cn_item, $regexs ) = @_;
for my $regex (@$regexs) {
eval "\$cn_item =~ $regex"; ## no critic (StringyEval)
_apply_substitution( \$cn_item, $regex );
}
my @lines = split "\n", $cn_item;
return @lines;
}
=head2 _apply_substitution
_apply_substitution( \$string, $regex );
Applies a single admin-configured s/// substitution to $string in place,
without ever evaluating the input as code. The rule is parsed as
s<DELIM>PATTERN<DELIM>REPLACEMENT<DELIM>FLAGS; the pattern is compiled with
qr// (so embedded-code assertions are treated as a runtime pattern and blocked
by Perl), and the replacement is expanded as data via
Koha::Regex::Replacement::expand_template. The
/e flag is rejected and anything that is not a plain substitution is ignored.
This replaces the previous C<eval "\$cn_item =~ $regex"> stringy eval, which
executed arbitrary Perl.
=cut
sub _apply_substitution {
my ( $ref, $regex ) = @_;
return unless defined $regex;
# Parse s<DELIM>PATTERN<DELIM>REPLACEMENT<DELIM>FLAGS, allowing any
# non-space delimiter and backslash-escaped delimiters inside the pattern
# and replacement. Anything that is not a well-formed plain substitution is
# ignored rather than executed.
return unless $regex =~ m{^s(\S)((?:\\.|(?!\1).)*)\1((?:\\.|(?!\1).)*)\1([a-z]*)\z}s;
my ( $pattern, $replacement, $flags ) = ( $2, $3, $4 );
return if $flags =~ /e/; # never evaluate the replacement as code
my $global = $flags =~ /g/ ? 1 : 0;
my $ci = $flags =~ /i/ ? '(?i)' : '';
my $compiled = eval { qr/$ci$pattern/ };
return unless defined $compiled;
my $expand = sub { Koha::Regex::Replacement::expand_template( $replacement, [@{^CAPTURE}], {%+} ) };
if ($global) {
${$ref} =~ s/$compiled/$expand->()/ge;
} else {
${$ref} =~ s/$compiled/$expand->()/e;
}
return;
}
1;
=head1 AUTHOR