From 7d51c70a19efc54cdc9b3486b945c8bcd067a351 Mon Sep 17 00:00:00 2001 From: Penn Mackintosh Date: Mon, 2 Jun 2025 14:52:26 +0000 Subject: [PATCH 1/4] Improve matching of `use base`-style statements with arrays. Previously, we were not able to match `use base ("Package1", "Package2");`. This style is used extensively by OpenAPI Generator (https://openapi-generator.tech). As a result, all Perl code generated by this tool fails to install the correct dependencies when using perl-generators in the specfile. With this change, we check for a single- or double-quoted array (as opposed to the current lexing of qw arrays) following a `use X` statement, and parse this into the $list scalar, stripping out quotes, splitting on quotes and joining on commas, to keep the same format that $list currently uses. --- t/02_list.t | 2 ++ t/data/list | 2 ++ template/bin/perl.req | 10 +++++++++- 3 files changed, 13 insertions(+), 1 deletion(-) diff --git a/t/02_list.t b/t/02_list.t index a0b8206..33ca85b 100644 --- a/t/02_list.t +++ b/t/02_list.t @@ -29,6 +29,8 @@ my @expectedrequires = ( "$perl_ns(base)\n", "$perl_ns(parent)\n", "$perl_ns(Theta)\n", + "$perl_ns(Omicron)\n", + "$perl_ns(Xi)\n", "$perl_ns(Kappa::Lambda)\n", "$perl_ns(Mu::Nu)\n", "$perl_ns(Try)\n", diff --git a/t/data/list b/t/data/list index 3636e38..d77d9b7 100644 --- a/t/data/list +++ b/t/data/list @@ -4,6 +4,8 @@ use base qw; use parent 'Epsilon'; use parent qw{Theta}; +use base ("Xi", "Omicron"); + # 'Zeta', 'Iota', 'Not::Require*' should not be found use parent -norequire, qw(Zeta Iota); use parent -norequire, 'Not::Require1', 'Not::Require2'; diff --git a/template/bin/perl.req b/template/bin/perl.req index 67a4f7a..94e9241 100755 --- a/template/bin/perl.req +++ b/template/bin/perl.req @@ -244,10 +244,11 @@ sub process_file { (?:$begin_re\s* ([^)\/"'\$!|}]*?) \s*$end_re| + \s*(\((?:['"][^"'\$]*["']\s*,\s*)+['"][^"'\$]*["']\s*\))| (?:qw<|qq?<)([^>]*?)>|([\w\:]+)|)\s*(.*) /x) ) { - my ($whitespace, $statement, $module, $version, $params, $list, $rest) = ($1, $2, $3, $5, $6, $7 || $8 || $9, $10); + my ($whitespace, $statement, $module, $version, $params, $list, $rest) = ($1, $2, $3, $5, $6, $7 || $8 || $9 || $10, $11); $version = undef if ($version eq ''); # Ignore line which contains direct method calls @@ -276,6 +277,13 @@ sub process_file { } } + # Executed in the case of a standard quoted array in the list of modules. + # use base ("Package1", "Package2"); + if (defined($list) && $list =~ /^\(((?:['"][^"'\$]*["']\s*,\s*)+['"][^"'\$]*["']\s*)\)$/) { + my @list = split /,/, $1; + $list = join ' ', map { s/^\s*['"]|['"]\s*$//gr } @list; + } + # we only consider require statements that are flushed against # the left edge. any other require statements give too many # false positives, as they are usually inside of an if statement From e889f70ff426e2cecd513af75c7aba2f15ad727f Mon Sep 17 00:00:00 2001 From: Penn Mackintosh Date: Mon, 2 Jun 2025 15:07:34 +0000 Subject: [PATCH 2/4] Clean up $list to @list The existing code stores the arguments of various statements into $list as a space-separated scalar. It's much cleaner to store this as an array, so we now do that instead. --- template/bin/perl.req | 36 ++++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/template/bin/perl.req b/template/bin/perl.req index 94e9241..68b5e18 100755 --- a/template/bin/perl.req +++ b/template/bin/perl.req @@ -255,33 +255,37 @@ sub process_file { # use base __PACKAGE__->subroutine(...); $list = "" if ($list =~ /^[^;#]*?->/ || $rest =~ /^[^;#]*?->/); + my @list = split ' ', $list; + # # Executed in case that multiline q{} quoted sections is used for # list of modules if (defined($list) && $list =~ /^q[qxwr]?$/) { $list = ""; if ($rest =~ m/^\s*([{([#|!\/])\s*([^})\]#|!\/]*)$/) { + @list = (); $tag = $1; $list = $2; - chomp($list); $tag =~ tr/{\(\[\#|!\//})]#|!\//; $tag = quotemeta($tag); while () { - my $line = $_; - chomp($line); - if ($line =~ m/^\s*(.*?)$tag/) { - $list .= ' ' . $1 if ($1 ne ''); - last; - } else { $list .= ' ' . $line; } + chomp(my $line = $_); + # If line contains tag, remove it and finish iteration. + my $last = $line =~ s/$tag.*$//; + push(@list, split(' ', $line)); + last if $last; } + $list = ""; } } # Executed in the case of a standard quoted array in the list of modules. # use base ("Package1", "Package2"); if (defined($list) && $list =~ /^\(((?:['"][^"'\$]*["']\s*,\s*)+['"][^"'\$]*["']\s*)\)$/) { - my @list = split /,/, $1; - $list = join ' ', map { s/^\s*['"]|['"]\s*$//gr } @list; + $list = ""; + @list = split /,/, $1; + # Remove ignored spaces and quotes. + s/^\s*['"]|['"]\s*$//g for @list; } # we only consider require statements that are flushed against @@ -370,17 +374,17 @@ sub process_file { # use aliased qw(Foo::Bar) dependencies if ($statement eq "use" && ($module eq "base" || $module eq "aliased")) { add_require($module, $version); - if (defined($list) && $list ne "") { - add_require($_, undef) for split(' ', $list); + if (@list) { + add_require($_, undef) for @list; } next; } # use parent -norequire, 'No::Version'; # $params == "-norequire," - # use parent qw/-norequire XML::XPath::Node/; # $list == "-norequire XML::XPath::Node" + # use parent qw/-norequire XML::XPath::Node/; # @list == qw(-norequire XML::XPath::Node} if ($statement eq "use" && $module eq "parent") { add_require($module, $version); - if (defined($list) && $list ne "" && $list !~ /-norequire/ && $params !~ /-norequire/) { - add_require($_, undef) for split(' ', $list); + if (@list && !grep(/-norequire/, @list) && $params !~ /-norequire/) { + add_require($_, undef) for @list; } next; } @@ -389,8 +393,8 @@ sub process_file { # Mouse or Mouse::Role will be added if ($statement eq "use" && $module eq "Any::Moose") { add_require($module, $version); - if (defined($list) && $list ne "") { - if (grep { !/^Role$/ } split(' ', $list)) { + if (@list) { + if (grep { !/^Role$/ } @list) { add_require('Mouse::Role', undef); } else { add_require('Mouse', undef); From 36c9c0042285e256ce32e9a34b1ff71dd9a44dc5 Mon Sep 17 00:00:00 2001 From: Penn Mackintosh Date: Wed, 18 Jun 2025 13:05:44 +0000 Subject: [PATCH 3/4] Add additional tests for identified failure cases Handling tabs and spaces is tricky, especially around in the complex logic that surrounds use base qw{ stuff }; --- t/02_list.t | 3 +++ t/data/list | 5 +++++ 2 files changed, 8 insertions(+) diff --git a/t/02_list.t b/t/02_list.t index 33ca85b..13528df 100644 --- a/t/02_list.t +++ b/t/02_list.t @@ -40,6 +40,9 @@ my @expectedrequires = ( "$perl_ns(TARGET_CLASS)\n", "$perl_ns(XML::XQL::Element)\n", "$perl_ns(Class::Accessor::Fast)\n", + "$perl_ns(AfterTab)\n", + "$perl_ns(AfterSpace)\n", + "$perl_ns(AfterNLAndTab)\n", ); is_deeply([ sort @requires ], [ sort @expectedrequires ], "Only expected requires were found."); diff --git a/t/data/list b/t/data/list index d77d9b7..c39239a 100644 --- a/t/data/list +++ b/t/data/list @@ -42,3 +42,8 @@ use base TARGET_CLASS; # Do not ignore line which contains '->' in a coment use base 'XML::XQL::Element'; # L -> L + +use base qw { + AfterTab AfterSpace + AfterNLAndTab +}; From ce2e46e4a231906e65bff1c0c5ad8abe370a09d7 Mon Sep 17 00:00:00 2001 From: Penn Mackintosh Date: Wed, 18 Jun 2025 13:42:18 +0000 Subject: [PATCH 4/4] Add support for trailing commas in ("") style --- t/02_list.t | 1 + t/data/list | 1 + template/bin/perl.req | 8 +++++--- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/t/02_list.t b/t/02_list.t index 13528df..e4f1d86 100644 --- a/t/02_list.t +++ b/t/02_list.t @@ -31,6 +31,7 @@ my @expectedrequires = ( "$perl_ns(Theta)\n", "$perl_ns(Omicron)\n", "$perl_ns(Xi)\n", + "$perl_ns(WithTrailingComma)\n", "$perl_ns(Kappa::Lambda)\n", "$perl_ns(Mu::Nu)\n", "$perl_ns(Try)\n", diff --git a/t/data/list b/t/data/list index c39239a..1e6a6e4 100644 --- a/t/data/list +++ b/t/data/list @@ -5,6 +5,7 @@ use parent 'Epsilon'; use parent qw{Theta}; use base ("Xi", "Omicron"); +use base ("WithTrailingComma",); # 'Zeta', 'Iota', 'Not::Require*' should not be found use parent -norequire, qw(Zeta Iota); diff --git a/template/bin/perl.req b/template/bin/perl.req index 68b5e18..cb4f193 100755 --- a/template/bin/perl.req +++ b/template/bin/perl.req @@ -219,6 +219,8 @@ sub process_file { $_ = ; } + my $quoted_list = q/\s*(?:['"][^"'\$]*["']\s*,\s*)*\s*['"][^"'\$]*["']\s*,?\s*/; + if ( # ouch could be in a eval, perhaps we do not want these since we catch @@ -244,7 +246,7 @@ sub process_file { (?:$begin_re\s* ([^)\/"'\$!|}]*?) \s*$end_re| - \s*(\((?:['"][^"'\$]*["']\s*,\s*)+['"][^"'\$]*["']\s*\))| + \s*(\($quoted_list\))| (?:qw<|qq?<)([^>]*?)>|([\w\:]+)|)\s*(.*) /x) ) { @@ -281,9 +283,9 @@ sub process_file { # Executed in the case of a standard quoted array in the list of modules. # use base ("Package1", "Package2"); - if (defined($list) && $list =~ /^\(((?:['"][^"'\$]*["']\s*,\s*)+['"][^"'\$]*["']\s*)\)$/) { + if (defined($list) && $list =~ /^\(($quoted_list)\)$/) { $list = ""; - @list = split /,/, $1; + @list = grep { /\S/ } (split /,/, $1); # Remove ignored spaces and quotes. s/^\s*['"]|['"]\s*$//g for @list; }