Move security RT#131079 fix from Grammar to Actions

This lets us catch compound name cases Use appropriate syntax errors before flagging restricted status Give prohibition on longname aliases a typed exception
rakudo · Sep 28, 2017 · 2448195 · 2448195
1 parent 7363f89
commit 2448195
Show file tree

Hide file tree

Showing 3 changed files with 21 additions and 2 deletions.
diff --git a/src/Perl6/Actions.nqp b/src/Perl6/Actions.nqp
@@ -9922,6 +9922,22 @@ class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions {
         my $qast;
         # We got something like <::($foo)>
         if $lng.contains_indirect_lookup() {
+            if $<assertion> {
+                if +$lng.components() > 1 {
+                    $/.typed_panic('X::Syntax::Regex::Alias::LongName');
+                }
+                else {
+                    # If ever implemented, take care with RESTRICTED
+                    $/.typed_panic('X::Syntax::Reserved', :reserved('dynamic alias name in regex'));
+                }
+            }
+            if +$lng.components() > 1 {
+                # If ever implemented, take care with RESTRICTED
+                $/.typed_panic('X::NYI', :feature('long dynamic name in regex assertion'));
+            }
+            if $*RESTRICTED {
+                $/.typed_panic('X::SecurityPolicy::Eval', :payload($*RESTRICTED));
+            }
             $qast := QAST::Regex.new( :rxtype<subrule>, :subtype<method>, :node($/),
                 QAST::NodeList.new(QAST::SVal.new( :value('INDMETHOD') ), $lng.name_past()) );
         }
@@ -9931,7 +9947,7 @@ class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions {
             my $c     := $/;
             if $<assertion> {
                 if +@parts {
-                    $c.panic("Can only alias to a short name (without '::')");
+                    $c.typed_panic('X::Syntax::Regex::Alias::LongName');
                 }
                 $qast := $<assertion>.ast;
                 if $qast.rxtype eq 'subrule' {

diff --git a/src/Perl6/Grammar.nqp b/src/Perl6/Grammar.nqp
@@ -5421,7 +5421,6 @@ grammar Perl6::RegexGrammar is QRegex::P6Regex::Grammar does STD does MatchPacka
     }
 
     token assertion:sym<name> {
-        <!before '::' <RESTRICTED>>
         <longname=.LANG('MAIN','longname')>
             [
             | <?[>]>

diff --git a/src/core/Exception.pm b/src/core/Exception.pm
@@ -1708,6 +1708,10 @@ my class X::Syntax::Regex::SolitaryBacktrackControl does X::Syntax {
     method message { "Backtrack control ':' does not seem to have a preceding atom to control" }
 }
 
+my class X::Syntax::Regex::Alias::LongName does X::Syntax {
+    method message() { "Can only alias to a short name (without '::')"; }
+}
+
 my class X::Syntax::Term::MissingInitializer does X::Syntax {
     method message { 'Term definition requires an initializer' }
 }