Package: libregexp-pattern-license-perl
Version: v3.10.0
This package (as distributed on CPAN) will fail tests on Perl 5.37.10. The
code exploits historically undefined behavior which has become defined in
5.37.10.
Historically perl would "accumulate" capture buffer data in a quantified
subgroup in a regular expression, eg, "abc"=~/(?:(a)|(b)|(c))+/ would leave
$1, $2, $3 defined as "a", "b", "c". This behavior is problematic and has
been changed in Perl 5.37.10 so that after such an expression only one of
the three capture buffers will be defined, that which was matched in the
last iteration of the quantified group.
The test code for Regexp::Pattern::License exploits this undefined behavior
to accumulate the results of multiple iterations of a quantified group.
Replacing that code with a while (/.../g) loop fixes the problem. The
attached patch fixes it so that the code should work on older and newer
perls regardless as to the status of this undefined behavior.
Note this perl package uses the debian bug tracker, however this bug is
visible on any platform using Perl 5.37.10 or later. I am not filing this
bug report from a debian install, so I cannot provide any of the debian
specific data you request on your bug tracker page.
Also please note that https://metacpan.org/pod/Regexp::Pattern::License
specifies that the source code repository for this package is
https://salsa.debian.org/build-common-team/regexp-pattern-license.git
however that code does not build as it has incomplete Dist::Zilla
configuration. Thus I was not able to produce a patch against your repo,
the attached patch is against the released code on CPAN.
See also the "BBC" (Blead Breaks CPAN) Perl5 bug report ticket for this:
https://github.com/Perl/perl5/issues/21001
cheers,
Yves
--
perl -Mre=debug -e "/just|another|perl|hacker/"
commit 326895d48bbf9fb23d5dd121724c9456238ce7df
Author: Yves Orton <demer...@gmail.com>
Date: Sat Apr 1 15:41:19 2023 +0200
LicenseRegistry.pm - do not rely on undefined regex behavior
Using multiple capture buffers inside of a quantified group has
undefined behavior, and in modern perls only one of the capture groups
will be defined, whereas in older perls the different matches will
accumulate and overwrite each other.
Using while /g matches allows us to get the same behavior as before
without relying on the undefined behavior.
diff --git a/t/lib/Test2/Tools/LicenseRegistry.pm b/t/lib/Test2/Tools/LicenseRegistry.pm
index 199acc3..0dfec0a 100644
--- a/t/lib/Test2/Tools/LicenseRegistry.pm
+++ b/t/lib/Test2/Tools/LicenseRegistry.pm
@@ -14,15 +14,17 @@ my %RE = %Regexp::Pattern::License::RE;
my $any = '[A-Za-z_][A-Za-z0-9_]*';
my $str = '[A-Za-z][A-Za-z0-9_]*';
-my $re_prop_attrs = qr/
- \A(?'prop'$str)\.alt(?:
+my $_re_prop_start = qr/
+ \A(?'prop'$str)\.alt
+/x;
+my $_re_prop_attrs = qr/\G(?:
\.org\.(?'org'$str)|
\.version\.(?'version'$str)|
\.since\.date_(?'since_date'\d{8})|
\.until\.date_(?'until_date'\d{8})|
\.synth\.$any|
(?'other'\.$any)
- )*\z/x;
+ )/x;
sub license_org_metadata
{
@@ -68,28 +70,35 @@ sub get_org_props
my ( @main, @extra, $skipcount );
for ( keys %{ $RE{$key} } ) {
- /$re_prop_attrs/;
- next unless $+{prop} and $+{prop} eq $prop;
- next unless $+{org} and $+{org} eq $org;
- next if $+{version};
- if ( $+{since_date} ) {
- if ( defined $date and 1 < $date and $date < $+{since_date} ) {
- $skipcount++ unless $+{other};
+ my %props;
+ if (m/$_re_prop_start/g){
+ %props = %+;
+ while (m/$_re_prop_attrs/g) {
+ $props{$_} = $+{$_} for keys %+;
+ }
+ }
+
+ next unless $props{prop} and $props{prop} eq $prop;
+ next unless $props{org} and $props{org} eq $org;
+ next if $props{version};
+ if ( $props{since_date} ) {
+ if ( defined $date and 1 < $date and $date < $props{since_date} ) {
+ $skipcount++ unless $props{other};
next;
}
}
- if ( $+{until_date} ) {
- if ( not defined $date or $+{until_date} <= $date ) {
- $skipcount++ unless $+{other};
+ if ( $props{until_date} ) {
+ if ( not defined $date or $props{until_date} <= $date ) {
+ $skipcount++ unless $props{other};
next;
}
}
elsif ( defined $date and $date == 0 ) {
- $skipcount++ unless $+{other};
+ $skipcount++ unless $props{other};
next;
}
- if ( $+{other} ) {
+ if ( $props{other} ) {
push @extra, $RE{$key}{$_};
}
else {
