summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/re.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/re.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/re.pm131
1 files changed, 125 insertions, 6 deletions
diff --git a/Master/tlpkg/tlperl/lib/re.pm b/Master/tlpkg/tlperl/lib/re.pm
index fb0b8d264c3..9d0921b80ea 100644
--- a/Master/tlpkg/tlperl/lib/re.pm
+++ b/Master/tlpkg/tlperl/lib/re.pm
@@ -4,7 +4,7 @@ package re;
use strict;
use warnings;
-our $VERSION = "0.11";
+our $VERSION = "0.18";
our @ISA = qw(Exporter);
our @EXPORT_OK = ('regmust',
qw(is_regexp regexp_pattern
@@ -16,6 +16,22 @@ 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:
+ d => 0,
+ l => 1,
+ u => 2,
+ a => 3,
+ aa => 4,
+);
+
sub setcolor {
eval { # Ignore errors
require Term::Cap;
@@ -66,7 +82,7 @@ $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
if (defined &DynaLoader::boot_DynaLoader) {
require XSLoader;
- XSLoader::load( __PACKAGE__, $VERSION);
+ XSLoader::load();
}
# else we're miniperl
# We need to work for miniperl, because the XS toolchain uses Text::Wrap, which
@@ -96,6 +112,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 +142,68 @@ sub bits {
} elsif ($EXPORT_OK{$s}) {
require Exporter;
re->export_to_level(2, 're', $s);
+ } elsif ($s =~ s/^\///) {
+ my $reflags = $^H{reflags} || 0;
+ my $seen_charset;
+ while ($s =~ m/( . )/gx) {
+ $_ = $1;
+ if (/[adul]/) {
+ # The 'a' may be repeated; hide this from the rest of the
+ # code by counting and getting rid of all of them, then
+ # changing to 'aa' if there is a repeat.
+ if ($_ eq 'a') {
+ my $sav_pos = pos $s;
+ my $a_count = $s =~ s/a//g;
+ pos $s = $sav_pos - 1; # -1 because got rid of the 'a'
+ if ($a_count > 2) {
+ require Carp;
+ Carp::carp(
+ qq 'The "a" flag may only appear a maximum of twice'
+ );
+ }
+ elsif ($a_count == 2) {
+ $_ = 'aa';
+ }
+ }
+ if ($on) {
+ if ($seen_charset) {
+ require Carp;
+ if ($seen_charset ne $_) {
+ Carp::carp(
+ qq 'The "$seen_charset" and "$_" flags '
+ .qq 'are exclusive'
+ );
+ }
+ else {
+ Carp::carp(
+ qq 'The "$seen_charset" flag may not appear '
+ .qq 'twice'
+ );
+ }
+ }
+ $^H{reflags_charset} = $reflags{$_};
+ $seen_charset = $_;
+ }
+ else {
+ delete $^H{reflags_charset}
+ if defined $^H{reflags_charset}
+ && $^H{reflags_charset} == $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_charset})
+ ? $^H |= $flags_hint
+ : ($^H &= ~$flags_hint);
} else {
require Carp;
Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
@@ -170,6 +249,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 +304,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 character set /adul 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 one of the character set 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
@@ -231,7 +350,7 @@ form of output that can be used to get a colorful display on terminals
that understand termcap color sequences. Set C<$ENV{PERL_RE_TC}> to a
comma-separated list of C<termcap> properties to use for highlighting
strings on/off, pre-point part on/off.
-See L<perldebug/"Debugging regular expressions"> for additional info.
+See L<perldebug/"Debugging Regular Expressions"> for additional info.
As of 5.9.5 the directive C<use re 'debug'> and its equivalents are
lexically scoped, as the other directives are. However they have both
@@ -307,7 +426,7 @@ Turns on all "extra" debugging options.
=item BUFFERS
-Enable debugging the capture buffer storage during match. Warning,
+Enable debugging the capture group storage during match. Warning,
this can potentially produce extremely large output.
=item TRIEM
@@ -397,7 +516,7 @@ by C<qr//>, false if it is not.
This function will not be confused by overloading or blessing. In
internals terms, this extracts the regexp pointer out of the
-PERL_MAGIC_qr structure so it it cannot be fooled.
+PERL_MAGIC_qr structure so it cannot be fooled.
=item regexp_pattern($ref)
@@ -415,7 +534,7 @@ C<qr//> with the same pattern inside. If the argument is not a compiled
reference then this routine returns false but defined in scalar context,
and the empty list in list context. Thus the following
- if (regexp_pattern($ref) eq '(?i-xsm:foo)')
+ if (regexp_pattern($ref) eq '(?^i:foo)')
will be warning free regardless of what $ref actually is.