ext/re/t/lexical_debug.pl generate debug output for lexical re 'debug'
ext/re/t/lexical_debug.t test that lexical re 'debug' works
ext/re/t/qr.t test that qr// is a Regexp
+ext/re/t/reflags.t see if re '/xism' pragma works
ext/re/t/re_funcs.t See if exportable 're' funcs in re.xs work
ext/re/t/regop.pl generate debug output for various patterns
ext/re/t/regop.t test RE optimizations by scraping debug output
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;
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') {
} 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: ",
/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
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
--- /dev/null
+#!./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';
+}
else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
pmop->op_pmflags |= RXf_PMf_UNICODE;
}
+ if (PL_hints & HINT_RE_FLAGS) {
+ SV *reflags = Perl_refcounted_he_fetch(aTHX_
+ PL_compiling.cop_hints_hash, 0, STR_WITH_LEN("reflags"), 0, 0
+ );
+ if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
+ reflags = Perl_refcounted_he_fetch(aTHX_
+ PL_compiling.cop_hints_hash, 0, STR_WITH_LEN("reflags_dul"), 0, 0
+ );
+ if (reflags && SvOK(reflags)) {
+ pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
+ pmop->op_pmflags |= SvIV(reflags);
+ }
+ }
#ifdef USE_ITHREADS
/* This tells where the first of these bits is. Setting it to 0 saved cycles
* and memory. I (khw) think the code will work if changed back, but haven't
* tested it */
+/* Make sure to update lib/re.pm when changing this! */
#define RXf_PMf_STD_PMMOD_SHIFT 0
/* The bits need to be ordered so that the msix are contiguous starting at bit
* RXf_PMf_STD_PMMOD_SHIFT, followed by the p. See STD_PAT_MODS and
* INT_PAT_MODS in regexp.h for the reason contiguity is needed */
+/* Make sure to update lib/re.pm when changing these! */
#define RXf_PMf_MULTILINE (1 << (RXf_PMf_STD_PMMOD_SHIFT+0)) /* /m */
#define RXf_PMf_SINGLELINE (1 << (RXf_PMf_STD_PMMOD_SHIFT+1)) /* /s */
#define RXf_PMf_FOLD (1 << (RXf_PMf_STD_PMMOD_SHIFT+2)) /* /i */
#define HINT_NO_AMAGIC 0x01000000 /* overloading pragma */
+#define HINT_RE_FLAGS 0x02000000 /* re '/xism' pragma */
+
/* The following are stored in $^H{sort}, not in PL_hints */
#define HINT_SORT_SORT_BITS 0x000000FF /* allow 256 different ones */
#define HINT_SORT_QUICKSORT 0x00000001
projects / platform / upstream / perl.git / commitdiff