[perl #78072] use re '/xism';

2 files changed, 198 insertions, 0 deletions

diff --git a/ext/re/re.pm b/ext/re/re.pm
index 90e31f3ff9..881323222d 100644
--- a/ext/re/re.pm
+++ b/ext/re/re.pm
@@ -16,6 +16,20 @@ my %bitmask = (
     eval    => 0x00200000, # HINT_RE_EVAL
 );
 
+my $flags_hint = 0x02000000; # HINT_RE_FLAGS
+my $PMMOD_SHIFT = 0;
+my %reflags = (
+    m => 1 << ($PMMOD_SHIFT + 0),
+    s => 1 << ($PMMOD_SHIFT + 1),
+    i => 1 << ($PMMOD_SHIFT + 2),
+    x => 1 << ($PMMOD_SHIFT + 3),
+    p => 1 << ($PMMOD_SHIFT + 4),
+# special cases:
+    l => 1 << ($PMMOD_SHIFT + 5),
+    u => 1 << ($PMMOD_SHIFT + 6),
+    d => 0,
+);
+
 sub setcolor {
  eval {				# Ignore errors
   require Term::Cap;
@@ -96,6 +110,7 @@ sub bits {
 	require Carp;
 	Carp::carp("Useless use of \"re\" pragma"); 
     }
+   ARG:
     foreach my $idx (0..$#_){
         my $s=$_[$idx];
         if ($s eq 'Debug' or $s eq 'Debugcolor') {
@@ -125,6 +140,33 @@ sub bits {
 	} elsif ($EXPORT_OK{$s}) {
 	    require Exporter;
 	    re->export_to_level(2, 're', $s);
+	} elsif ($s =~ s/^\///) {
+	    my $reflags = $^H{reflags} || 0;
+	    for(split//, $s) {
+		if (/[dul]/) {
+		    if ($on) {
+			$^H{reflags_dul} = $reflags{$_};
+		    }
+		    else {
+			delete $^H{reflags_dul}
+			 if  defined $^H{reflags_dul}
+			  && $^H{reflags_dul} == $reflags{$_};
+		    }
+		} elsif (exists $reflags{$_}) {
+		    $on
+		      ? $reflags |= $reflags{$_}
+		      : ($reflags &= ~$reflags{$_});
+		} else {
+		    require Carp;
+		    Carp::carp(
+		     qq'Unknown regular expression flag "$_"'
+		    );
+		    next ARG;
+		}
+	    }
+	    ($^H{reflags} = $reflags or defined $^H{reflags_dul})
+	     ? $^H |= $flags_hint
+	     : ($^H &= ~$flags_hint);
 	} else {
 	    require Carp;
 	    Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
@@ -170,6 +212,11 @@ re - Perl pragma to alter regular expression behaviour
 	/foo${pat}bar/;		   # disallowed (with or without -T switch)
     }
 
+    use re '/ix';
+    "FOO" =~ / foo /; # /ix implied
+    no re '/x';
+    "FOO" =~ /foo/; # just /i implied
+
     use re 'debug';		   # output debugging info during
     /^(.*)$/s;			   #     compile and run time
 
@@ -220,6 +267,41 @@ interpolation.  Thus:
 I<is> allowed if $pat is a precompiled regular expression, even
 if $pat contains C<(?{ ... })> assertions or C<(??{ ... })> subexpressions.
 
+=head2 '/flags' mode
+
+When C<use re '/flags'> is specified, the given flags are automatically
+added to every regular expression till the end of the lexical scope.
+
+C<no re '/flags'> will turn off the effect of C<use re '/flags'> for the
+given flags.
+
+For example, if you want all your regular expressions to have /msx on by
+default, simply put
+
+    use re '/msx';
+
+at the top of your code.
+
+The /dul flags cancel each other out. So, in this example,
+
+    use re "/u";
+    "ss" =~ /\xdf/;
+    use re "/d";
+    "ss" =~ /\xdf/;
+
+The second C<use re> does an implicit C<no re '/u'>.
+
+Turning on the /l and /u flags with C<use re> takes precedence over the
+C<locale> pragma and the 'unicode_strings' C<feature>, for regular
+expressions. Turning off one of these flags when it is active reverts to
+the behaviour specified by whatever other pragmata are in scope. For
+example:
+
+    use feature "unicode_strings";
+    no re "/u"; # does nothing
+    use re "/l";
+    no re "/l"; # reverts to unicode_strings behaviour
+
 =head2 'debug' mode
 
 When C<use re 'debug'> is in effect, perl emits debugging messages when
diff --git a/ext/re/t/reflags.t b/ext/re/t/reflags.t
new file mode 100644
index 0000000000..26e8f05235
--- /dev/null
+++ b/ext/re/t/reflags.t
@@ -0,0 +1,116 @@
+#!./perl
+
+BEGIN {
+	require Config;
+	if (($Config::Config{'extensions'} !~ /\bre\b/) ){
+        	print "1..0 # Skip -- Perl configured without re module\n";
+		exit 0;
+	}
+}
+
+use strict;
+
+use Test::More tests => 32;
+
+use re '/i';
+ok "Foo" =~ /foo/, 'use re "/i"';
+no re '/i';
+ok "Foo" !~ /foo/, 'no re "/i"';
+use re '/x';
+ok "foo" =~ / foo /, 'use re "/x"';
+no re '/x';
+ok "foo" !~ / foo /, 'no re "/x"';
+use re '/s';
+ok "\n" =~ /./, 'use re "/s"';
+no re '/s';
+ok "\n" !~ /./, 'no re "/s"';
+use re '/m';
+ok "\nfoo" =~ /^foo/, 'use re "/m"';
+no re '/m';
+ok "\nfoo" !~ /^foo/, 'no re "/m"';
+
+use re '/xism';
+ok qr// =~ /(?=.*x)(?=.*i)(?=.*s)(?=.*m)/, 'use re "/multiple"';
+no re '/ix';
+ok qr// =~ /(?!.*x)(?!.*i)(?=.*s)(?=.*m)/, 'no re "/i" only turns off /ix';
+no re '/sm';
+
+{
+  use re '/x';
+  ok 'frelp' =~ /f r e l p/, "use re '/x' in a lexical scope"
+}
+ok 'f r e l p' =~ /f r e l p/,
+ "use re '/x' turns off when it drops out of scope";
+
+SKIP: {
+  if (
+      !$Config::Config{d_setlocale}
+   || $Config::Config{ccflags} =~ /\bD?NO_LOCALE\b/
+  ) {
+    skip "no locale support", 7
+  }
+  use locale;
+  use re '/u';
+  is qr//, '(?^u:)', 'use re "/u" with active locale';
+  no re '/u';
+  is qr//, '(?^l:)', 'no re "/u" reverts to /l with locale in scope';
+  no re '/l';
+  is qr//, '(?^l:)', 'no re "/l" is a no-op with locale in scope';
+  use re '/d';
+  is qr//, '(?^:)', 'use re "/d" with locale in scope';
+  no re '/l';
+  no re '/u';
+  is qr//, '(?^:)',
+    'no re "/l" and "/u" are no-ops when not on (locale scope)';
+  no re "/d";
+  is qr//, '(?^l:)', 'no re "/d" reverts to /l with locale in scope';
+  use re "/u";
+  no re "/d";
+  is qr//, '(?^u:)', 'no re "/d" is a no-op when not on (locale scope)';
+}
+
+{
+  use feature "unicode_strings";
+  use re '/d';
+  is qr//, '(?^:)', 'use re "/d" in Unicode scope';
+  no re '/d';
+  is qr//, '(?^u:)', 'no re "/d" reverts to /u in Unicode scope';
+  no re '/u';
+  is qr//, '(?^u:)', 'no re "/u" is a no-op in Unicode scope';
+  no re '/d';
+  is qr//, '(?^u:)', 'no re "/d" is a no-op when not on';
+  use re '/u';
+  no feature 'unicode_strings';
+  is qr//, '(?^u:)', 'use re "/u" is not tied to unicode_strings feature';
+}
+
+use re '/u';
+is qr//, '(?^u:)', 'use re "/u"';
+no re '/u';
+is qr//, '(?^:)', 'no re "/u" reverts to /d';
+no re '/u';
+is qr//, '(?^:)', 'no re "/u" is a no-op when not on';
+no re '/d';
+is qr//, '(?^:)', 'no re "/d" is a no-op when not on';
+
+{
+  local $SIG{__WARN__} = sub {
+   ok $_[0] =~ /Unknown regular expression flag "\x{100}"/,
+       "warning with unknown regexp flags in use re '/flags'"
+  };
+  import re "/\x{100}"
+}
+
+# use re '/flags' in combination with explicit flags
+use re '/xi';
+ok "A\n\n" =~ / a.$/sm, 'use re "/xi" in combination with explicit /sm';
+{
+  local $::TODO = "test requires perl 5.16 syntax";
+  # (remove the evals, the quotes, and the ‘no warnings’ when removing the
+  # to-do notice)
+  no warnings;
+  use re '/u';
+  is eval 'qr//d', '(?^:)', 'explicit /d in re "/u" scope';
+  use re '/d';
+  is eval 'qr//u', '(?^u:)', 'explicit /u in re "/d" scope';
+}