diff --git a/plugin/core/src/main/java/com/perl5/lang/perl/idea/PerlElementPatterns.java b/plugin/core/src/main/java/com/perl5/lang/perl/idea/PerlElementPatterns.java index 86c2b35dff..7c07325536 100644 --- a/plugin/core/src/main/java/com/perl5/lang/perl/idea/PerlElementPatterns.java +++ b/plugin/core/src/main/java/com/perl5/lang/perl/idea/PerlElementPatterns.java @@ -17,6 +17,7 @@ package com.perl5.lang.perl.idea; import com.intellij.patterns.PsiElementPattern; +import com.intellij.patterns.StandardPatterns; import com.intellij.psi.PsiElement; import com.perl5.lang.perl.psi.*; import com.perl5.lang.perl.psi.impl.PerlNoStatementElement; @@ -162,7 +163,12 @@ private PerlElementPatterns() { ); public static final PsiElementPattern.Capture EXPORT_VARIABLE = - psiElement(PsiPerlArrayVariable.class).withText("@EXPORT"); + psiElement(PsiPerlArrayVariable.class).withText( + StandardPatterns.string().andOr( + StandardPatterns.string().endsWith("::EXPORT"), + StandardPatterns.string().equalTo("@EXPORT") + ) + ); public static final PsiElementPattern.Capture EXPORT_DECLARATION = psiElement(PsiPerlVariableDeclarationGlobal.class) .withChild( @@ -177,7 +183,11 @@ private PerlElementPatterns() { ); public static final PsiElementPattern.Capture EXPORT_OK_VARIABLE = - psiElement(PsiPerlArrayVariable.class).withText("@EXPORT_OK"); + psiElement(PsiPerlArrayVariable.class).withText( + StandardPatterns.string().andOr( + StandardPatterns.string().endsWith("::EXPORT_OK"), + StandardPatterns.string().equalTo("@EXPORT_OK") + )); public static final PsiElementPattern.Capture EXPORT_OK_DECLARATION = psiElement(PsiPerlVariableDeclarationGlobal.class) .withChild( diff --git a/plugin/core/src/main/java/com/perl5/lang/perl/psi/mixins/PerlNamespaceDefinitionMixin.java b/plugin/core/src/main/java/com/perl5/lang/perl/psi/mixins/PerlNamespaceDefinitionMixin.java index 1501910f16..62008e1ffe 100644 --- a/plugin/core/src/main/java/com/perl5/lang/perl/psi/mixins/PerlNamespaceDefinitionMixin.java +++ b/plugin/core/src/main/java/com/perl5/lang/perl/psi/mixins/PerlNamespaceDefinitionMixin.java @@ -44,6 +44,7 @@ import java.util.ArrayList; import java.util.Collections; import java.util.List; +import java.util.Set; import java.util.Map; import static com.perl5.lang.perl.idea.PerlElementPatterns.*; @@ -245,27 +246,45 @@ public void subtreeChanged() { myParentNamespaces.drop(); } - public static class ExporterInfo implements Processor { + public class ExporterInfo implements Processor { private final @NotNull List EXPORT = new ArrayList<>(); private final @NotNull List EXPORT_OK = new ArrayList<>(); private final @NotNull Map> EXPORT_TAGS = Collections.emptyMap(); + // Deals with the following cases: + // use subs our @EXPORT_OK = qw( a b c ); + public PsiElement findAssignExpr(PsiElement element) { + PsiElement target = element.getFirstChild(); + while (target != null && !(target instanceof PsiPerlAssignExpr)) { + target = target.getNextSibling(); + } + return target; + } + + public void extractExport(PsiElement element, String exportName, List target) { + PsiElement assignExpr = findAssignExpr(element); + PsiElement leftSide = assignExpr.getFirstChild(); + PsiElement rightSide = assignExpr.getLastChild(); + String variableName = leftSide instanceof PerlVariableDeclarationExpr ? + leftSide.getLastChild().getText() : + leftSide.getText(); + + // @EXPORT or @{namespace}::EXPORT + // @EXPORT_OK or @{namespace}::EXPORT_OK + Set acceptedVariableName = Set.of("@" + exportName, "@" + getNamespaceName() + "::" + exportName); + if (acceptedVariableName.contains(variableName) && rightSide != null) { + target.clear(); + target.addAll(getRightSideStrings(rightSide)); + } + } + @Override public boolean process(PsiElement element) { if (ASSIGN_STATEMENT.accepts(element)) { if (EXPORT_ASSIGN_STATEMENT.accepts(element)) { - PsiElement rightSide = element.getFirstChild().getLastChild(); - if (rightSide != null) { - EXPORT.clear(); - EXPORT.addAll(getRightSideStrings(rightSide)); - } - } - else if (EXPORT_OK_ASSIGN_STATEMENT.accepts(element)) { - PsiElement rightSide = element.getFirstChild().getLastChild(); - if (rightSide != null) { - EXPORT_OK.clear(); - EXPORT_OK.addAll(getRightSideStrings(rightSide)); - } + extractExport(element, "EXPORT", EXPORT); + } else if (EXPORT_OK_ASSIGN_STATEMENT.accepts(element)) { + extractExport(element, "EXPORT_OK", EXPORT_OK); } } diff --git a/plugin/src/test/java/unit/perl/ExporterTest.java b/plugin/src/test/java/unit/perl/ExporterTest.java index 91af462d83..554738f2ac 100644 --- a/plugin/src/test/java/unit/perl/ExporterTest.java +++ b/plugin/src/test/java/unit/perl/ExporterTest.java @@ -33,6 +33,8 @@ protected String getBaseDataPath() { @Test public void testExport() { doTest("export.pl", "Foo", new String[]{"this", "is", "the", "end"}, new String[]{}); + doTest("boolean.pl", "boolean", new String[]{"true", "false", "boolean"}, new String[]{"isTrue", "isFalse", "isBoolean"}); + doTest("Opcode.pm", "Opcode", new String[]{}, new String[]{"opset", "opset_to_hex", "opdump"}); } @Test diff --git a/plugin/src/test/resources/unit/perl/exporter/Opcode.pm b/plugin/src/test/resources/unit/perl/exporter/Opcode.pm new file mode 100644 index 0000000000..604aeca8dd --- /dev/null +++ b/plugin/src/test/resources/unit/perl/exporter/Opcode.pm @@ -0,0 +1,14 @@ +package Opcode 1.64; + +use strict; + +use Carp; +use Exporter 'import'; +use XSLoader; + +sub opset (;@); +sub opset_to_hex ($); +sub opdump (;$); +use subs our @EXPORT_OK = qw( + opset opset_to_hex opdump +); diff --git a/plugin/src/test/resources/unit/perl/exporter/boolean.pl b/plugin/src/test/resources/unit/perl/exporter/boolean.pl new file mode 100644 index 0000000000..599ec814e1 --- /dev/null +++ b/plugin/src/test/resources/unit/perl/exporter/boolean.pl @@ -0,0 +1,83 @@ +use strict; use warnings; +package boolean; +our $VERSION = '0.46'; + +my ($true, $false); + +use overload + '""' => sub { ${$_[0]} }, + '!' => sub { ${$_[0]} ? $false : $true }, + fallback => 1; + +use base 'Exporter'; +@boolean::EXPORT = qw(true false boolean); +@boolean::EXPORT_OK = qw(isTrue isFalse isBoolean); +%boolean::EXPORT_TAGS = ( + all => [@boolean::EXPORT, @boolean::EXPORT_OK], + test => [qw(isTrue isFalse isBoolean)], +); + +sub import { + my @options = grep $_ ne '-truth', @_; + $_[0]->truth if @options != @_; + @_ = @options; + goto &Exporter::import; +} + +my ($true_val, $false_val, $bool_vals); + +BEGIN { + my $t = 1; + my $f = 0; + $true = do {bless \$t, 'boolean'}; + $false = do {bless \$f, 'boolean'}; + + $true_val = overload::StrVal($true); + $false_val = overload::StrVal($false); + $bool_vals = {$true_val => 1, $false_val => 1}; +} + +# refaddrs change on thread spawn, so CLONE fixes them up +sub CLONE { + $true_val = overload::StrVal($true); + $false_val = overload::StrVal($false); + $bool_vals = {$true_val => 1, $false_val => 1}; +} + +sub true() { $true } +sub false() { $false } +sub boolean($) { + die "Not enough arguments for boolean::boolean" if scalar(@_) == 0; + die "Too many arguments for boolean::boolean" if scalar(@_) > 1; + return not(defined $_[0]) ? false : + "$_[0]" ? $true : $false; +} +sub isTrue($) { + not(defined $_[0]) ? false : + (overload::StrVal($_[0]) eq $true_val) ? true : false; +} +sub isFalse($) { + not(defined $_[0]) ? false : + (overload::StrVal($_[0]) eq $false_val) ? true : false; +} +sub isBoolean($) { + not(defined $_[0]) ? false : + (exists $bool_vals->{overload::StrVal($_[0])}) ? true : false; +} + +sub truth { + die "-truth not supported on Perl 5.22 or later" if $] >= 5.021005; + # enable modifying true and false + &Internals::SvREADONLY( \ !!0, 0); + &Internals::SvREADONLY( \ !!1, 0); + # turn perl internal booleans into blessed booleans: + ${ \ !!0 } = $false; + ${ \ !!1 } = $true; + # make true and false read-only again + &Internals::SvREADONLY( \ !!0, 1); + &Internals::SvREADONLY( \ !!1, 1); +} + +sub TO_JSON { ${$_[0]} ? \1 : \0 } + +1;