File Coverage

blib/lib/Tstregex.pm

Criterion	Covered	Total	%
statement	168	298	56.3
branch	37	102	36.2
condition	36	80	45.0
subroutine	28	40	70.0
pod	9	11	81.8
total	278	531	52.3

#!/usr/bin/env perl

###############################################
# Author:        Olivier Delouya - 2026
# File:          Tstregex.pm (Hybrid Modulino)
# Content:       Regex longest match diagnostic
# indent:        Whitesmith (perltidy -bl -bli)
###############################################

use strict;
use warnings;

=head1 NAME

Tstregex - A Diagnostic Tool that quickly shows the longest Regular Expression string match, highlighting the rejected part. The terminal command
tstregex '/^[a-z]*\d{3}$/' 'abc12a' shows: abcB<12a> (^[a-z]*B<\d{3}$>)

 # Above, the normal parts are the longuest matching substring when bold parts highlights the rejected substring
 #(idem with regexp lexical groups between parenthesis)
 # A Hybrid Regex Diagnostic Tool (single file Library module with API and command tool)

=cut

=head1 SYNOPSIS

C<$tstregex 'regex' string1 string2 ...   stringN>

=head1 OPTIONS (CLI)

=head2 -h --help

show that help..

=head2 -v --verbose

shows key info on (un)matching..

=head2 -d --diag

=over

=item Triggers the Enriched Diagnostic View. It displays:

=item - The string with the failing part highlighted.

=item - The exact token in the regex that caused the break.

=item - A visual pointer (C<^--- HERE>) aligned with the regex syntax.

=item - Execution time (useful for spotting ReDoS/Exponential backtracking).

=back

=head2 -a --assert

Misc: performs a huge test suite various a large collection of regexp tests with Tstregex..

=head1 Perl Module SYNOPSIS

  use Tstregex;
  my $ctx = tstregex_init_desc('/^\d{3}/');
  tstregex($ctx, '12a');
  if (!tstregex_is_full_match($res))
      {
      my $token = tstregex_get_fail_token($res);
      my $pos   = tstregex_get_match_len($res);
      print "Failure on token '$token' at column $pos\n";
      }
  Note that if your purpose is just to display the result as the command would do, you can call directly
  the main with the appropriate (argc, argv) style parameters to avoid to spawn another perl process.
  See the tstregex file stub for details..

=head1 API

=head2 tstregex_init_desc($raw_re)

Pre-parses the regex, handles delimiters (m!!, //, etc.), extracts modifiers (i, s, m, x), and prepares the nibbling steps. Returns a context hash.

=head2 tstregex($ctx, $string)

Executes the diagnostic. Updates the context.

=head2 tstregex_is_full_match

Returns match status of input string (BOOL 0 OR 1)

=head2 tstregex_get_match_portion

Returns the matching portion in case of full match
(might be smaller than input string, depending on anchors..)

=head2 tstregex_get_match_len

Returns the matching substring length

=head2 tstregex_get_fail_token

Returns the failing token in the regexp

=head2 tstregex_get_re_clean

Returns the matching regexp subpart

=head2 tstregex_get_re_raw

Returns the internal representation of the regexp

=head2 tstregex_get_prefix_offset

Returns the offset of the original regexp in the raw regexp

=head1 DESCRIPTION

=over

=item B is designed to solve the "Black Box" problem of Regular Expressions.

=item When a complex regex fails, Perl usually just says "No Match".

=item This tool identifies exactly B and B it failed by finding the longest possible partial match.

=back

=head1 EXAMPLE

=over

=item $ perl lib/Tstregex.pm '/^[a-z]*\d{3}$/' 'abc123' 'abc12a'

=item abc123

=item abcB<12a> (^[a-z]*B<\d{3}$>)

=back

I

=head2 The "Nibbling" Engine

The diagnostic logic uses a "Nibbling" (grignotage) strategy:

=over 4

=item 1. Decomposition

The engine breaks down your regex into a hierarchy of valid sub-patterns (lexical groups, atoms, and quantifiers) from longest to shortest.

=item 2. Longest Match Search

=back

=over 4

It iteratively tests these sub-patterns against the input string.

It's not just checking if the start matches, but what is the I sequence of instructions the engine could follow before hitting a wall.

=back

=over 4

=item 3. Failure Point Identification

Once the longest matching sub-pattern is found, the tool identifies the very next token in your regex syntax. This is your "Point of Failure".

=back

=head1 AUTHOR

Olivier Delouya - 2026

=head1 LICENSE

Artistic Version 2

=cut


package main;
    {
    use strict;
    use warnings;
    use Carp qw(confess);
    $SIG{__WARN__} = 'confess';
    $SIG{__DIE__ } = 'confess';

    use IO::Handle;
    use Term::ANSIColor qw(:constants);
    use Time::HiRes qw(gettimeofday tv_interval);
    use utf8;

    # --- Constants & ASCII Codes ---
    use constant
        {
        C_m      => 109, C_g      => 103, C_i      => 105, C_s      => 115,
        C_x      => 120, C_SLASH  => 47,  C_SPACE  => 32,  C_ZERO   => 48,
        C_NINE   => 57,  C_UP_A   => 65,  C_UP_Z   => 90,  C_LOW_A  => 97,
        C_LOW_Z  => 122, C_UNDSC  => 95,
        OP_PAR   => 40,  CL_PAR   => 41,  OP_BRK   => 91,  CL_BRK   => 93,
        OP_BRC   => 123, CL_BRC   => 125, OP_ANG   => 60,  CL_ANG   => 62,
        ESC      => "\e",
        CUU      => "\e[A", # Cursor Up
        UI_OFFSET=> 11,     # Alignment offset for "  Syntax: "
        };

# --- ENCAPSULATED DEBUG ALIAS ---
    BEGIN
        {
        if ($INC{'perl5db.pl'})
            {
            require Data::Dumper;
            require Term::ANSIColor;
            no strict 'refs';
            no warnings 'once';

            my $debug_sub = sub
                {
                my @args = @_;

                # Automatically detect flattened hashes:
                # If even number of arguments and the first one isn't a reference
                if (scalar @args > 1 && scalar @args % 2 == 0 && !ref($args[0]))
                    {
                    # Wrap the flattened list into a temporary hashref
                    my %tmp_hash = @args;
                    @args = (\%tmp_hash);
                    }

                print "\n", Term::ANSIColor::BOLD(), Term::ANSIColor::BLUE(),
                      'DEBUG (tstregex): ', Term::ANSIColor::RESET(),
                      Data::Dumper::Dumper(@args);
                };

            # Force injection into all relevant namespaces
            foreach my $pkg ('main', 'Tstregex', 'DB')
                {
                *{"${pkg}::d"} = $debug_sub;
                }

            my $cuu = defined &main::CUU ? main::CUU() : "\e[A";
            print $cuu, Term::ANSIColor::BOLD(), Term::ANSIColor::CYAN(),
                  'INFO: ', Term::ANSIColor::RESET(),
                  "Alias 'd' ready (Auto-hash detection enabled)\n\n";
            }
        }

    exit(main(scalar(@ARGV), \@ARGV)) if(!caller);

    sub main
        {
        my ($argc, $argv) = @_;
        if(!$argc || ($argc && $$argv[0] =~ /^-h|--help$/)) { help(); exit(0); }

        binmode STDOUT, ':utf8';
        my ($mode_diag, $verbose, $assert) = (0)x2;
        for(my $i=0; $i<$argc; $i++)
            {
            do { $mode_diag = 1; undef $$argv[$i]; next } if (!$mode_diag && $$argv[$i] =~ /^-d|--diag$/);
            do { $verbose   = 1; undef $$argv[$i]; next } if (!$verbose   && $$argv[$i] =~ /^-v|--verbose$/);
            do { $assert    = 1; undef $$argv[$i]; next } if (!$assert    && $$argv[$i] =~ /^-a|--assert$/);
            }

        if ($assert)
            {
            print BOLD, BLUE, "--- Internal Test Suite (DATA Section) ---\n", RESET;
            _run_internal_tests($mode_diag, $verbose);
            exit(0);
            }

        my @new_argv;
        foreach(@$argv)
            {
            push @new_argv, $_ if(defined($_));
            }
        $argv = \@new_argv;
        $argc = scalar @$argv;

        my $re_raw = shift @{$argv};
        my $ctx = Tstregex::tstregex_init_desc($re_raw);
        my $global_result = 0; # success! BE POSITIVE !!
        foreach my $pattern (@{$argv})
            {
            my $t0 = [gettimeofday] if $mode_diag;
            my $result = Tstregex::tstregex($ctx, $pattern);
            $global_result = 1 if($result);
            $mode_diag ? _display_enriched($pattern, $ctx, tv_interval($t0))
                       : _display_standard($pattern, $ctx);
            if($verbose)
                {
                print $result?  'Match':'UNmatch', '! Match length: ', Tstregex::tstregex_get_match_len($ctx), '; ';
                print $result? ('Match portion: ', Term::ANSIColor::UNDERLINE(), Tstregex::tstregex_get_match_portion($ctx))
                             : ('Fail token: ', Tstregex::tstregex_get_fail_token($ctx));
                print Term::ANSIColor::RESET(), "\n";
                print $ctx->{warning} if($verbose && $ctx->{warning} ne '');
                }
            }
        return $global_result;
        }

    sub _run_internal_tests
        {
        my ($mode_diag, $verbose) = @_;
        my $fh = \*main::DATA;
        seek($fh, 0, 0);

        my $found_data_token = 0;

        while (<$fh>)
            {
            chomp;
            # PHASE 1: Skip everything until we hit the __DATA__ or __END__ marker
            # This prevents the script from parsing its own source code
            if (!$found_data_token)
                {
                $found_data_token = 1 if /^__(DATA|END)__/;
                next;
                }
            else
                {
                last if /^__(DATA|END)__/;
                }
            next if /^\s*$/ || /^#/;
            my ($re, @rest) = split(/\s+|:::\s*/, $_);
            next unless $re;
            my @strings = grep { $_ ne '0' && $_ ne '1' } @rest;

            print BOLD, YELLOW, 'Testing Regex: ', RESET, "$re\n";
            my $ctx = Tstregex::tstregex_init_desc($re);
            print 'Warning ', $ctx->{warning}, "\n" if($verbose && $ctx->{warning} ne '');
            foreach my $s (@strings)
                {
                my $t0;
                $t0 = [gettimeofday] if $mode_diag;
                Tstregex::tstregex($ctx, $s);
                $mode_diag ? _display_enriched($s, $ctx, tv_interval($t0))
                           : _display_standard($s, $ctx);
                }
            print '-' x 40, "\n";
            }
        }

    sub _get_re_val
        {
        return (
                Tstregex::tstregex_get_match_len ($_[0]),
                Tstregex::tstregex_get_fail_token($_[0]),
                Tstregex::tstregex_get_re_clean  ($_[0])
               );
        }

    sub _display_standard
        {
        my ($pattern, $ctx) = @_;
        if (Tstregex::tstregex_is_full_match($ctx))
            {
            print "$pattern\n";
            return undef;
            }
        my ($match_len, $fail_token, $re_clean ) = _get_re_val($ctx);
        print substr($pattern, 0, $match_len); STDOUT->flush(); print STDERR BOLD, substr($pattern, $match_len), RESET;
        my $off = length($re_clean) - length($fail_token);
        print STDERR ' (', substr($re_clean, 0, $off), BOLD, $fail_token, RESET, ")\n";
        undef;
        }

    sub _display_enriched
        {
        my ($pattern, $ctx, $elapsed) = @_;
        print BOLD, MAGENTA, '--- Diagnostic View ---', RESET, "\n";

        if (Tstregex::tstregex_is_full_match($ctx))
            {
            print GREEN, '  Result: ', RESET, "$pattern (FULL MATCH)\n";
            return undef;
            }
        my ($match_len, $fail_token, $re_clean ) = _get_re_val($ctx);
        my $prefix_off = Tstregex::tstregex_get_prefix_offset($ctx);
        my $re_raw     = Tstregex::tstregex_get_re_raw        ($ctx);

        print YELLOW, '  Result: ', RESET, substr($pattern, 0, $match_len),
              BOLD, WHITE, substr($pattern, $match_len), RESET;
        print ' (at ', CYAN, $fail_token, RESET, ")\n";

        my $err_pos_in_clean = length($re_clean) - length($fail_token);
        my $final_pointer_pos = $prefix_off + $err_pos_in_clean;

        print '  Syntax: ', WHITE, $re_raw, RESET, "\n";
        print '            ', ' ' x $final_pointer_pos, BOLD, RED, '^--- HERE', RESET, "\n";
        printf "  Time:    %.4fs\n\n", $elapsed;
        undef;
        }

    sub help
        {
        print BOLD, WHITE, "Tstregex.pm - Longest match Regular Expression Diagnostic Tool (2026 - PerlOD)\n", RESET;
        print "Usage:\n";
        print "  perl Tstregex.pm [options] 'regex' 'string1' ['string2' ...]\n\n";
        print "Examples:\n";
        print "  perl Tstregex.pm '([0-3][0-9])/[0-1][0-9]/\\d{4}' '21/72/1985'\n";
        print '  21/', BOLD, '72/1985', RESET, ' ([0-3][0-9]/', BOLD, '[0-1][0-9]/\d{4}', RESET, ")\n\n";
        print BOLD, 'DELIMITERS ', RESET, "are optional\n";
        print "  Supported: /.../, m!...!, m{...}. Modifiers (/i, /x, /s...) and captures are supported.\n\n";
        print "Options:\n";
        print "-h --help            Shows that help\n";
        print "-v --verbose         Shows keys info on match/unmatch\n";
        print "-d --diag            Enriched diagnostic with timing and syntax pointers\n";
        print "-a --assert          Misc: shows a large test of regexp against tstregex..\n";
        }

    }

1;

package Tstregex;
    {
    our $VERSION = '1.12';
    use Exporter qw(import);

    our @EXPORT  = qw(
        tstregex
        tstregex_init_desc
        tstregex_get_match_len
        tstregex_get_fail_token
        tstregex_is_full_match
        tstregex_get_re_clean
        tstregex_get_prefix_offset
        tstregex_get_re_raw
        tstregex_get_match_portion
        tstregex_get_info
    );

    # --- PUBLIC API (The Getters) ---

    sub tstregex_get_match_len     { return $_[0]->{match_len};     }
    sub tstregex_get_fail_token    { return $_[0]->{fail_token};    }
    sub tstregex_is_full_match     { return $_[0]->{full_match};    }
    sub tstregex_get_re_clean      { return $_[0]->{re_clean};      }
    sub tstregex_get_prefix_offset { return $_[0]->{prefix_offset}; }
    sub tstregex_get_re_raw        { return $_[0]->{re_raw};        }
    sub tstregex_get_captures      { return $_[0]->{captures} // [];}
    sub tstregex_get_match_portion { return $_[0]->{match_portion}; }
    sub tstregex_get_info          { return $_[0]->{warning};       }

    # Main diagnostic function
    use constant;
    use constant
        {
        C_EMPTY      =>       '',
        RE_EMPTY     =>   qr/\0/,
        ASCII_LPAREN => ord('('),  # 40
        ASCII_RPAREN => ord(')'),  # 41
        ASCII_LBRACE => ord('{'),  # 123
        ASCII_RBRACE => ord('}'),  # 125
        ASCII_LBRACK => ord('['),  # 91
        ASCII_RBRACK => ord(']'),  # 93
        ASCII_LT     => ord('<'),  # 60
        ASCII_GT     => ord('>'),  # 62
        };

    sub tstregex
        {
        my ($ctx, $pattern) = @_;
        # FIX: re init start-state fields in case of multiple test patterns
        $ctx -> {'fail_token'}      = Tstregex::C_EMPTY;
        $ctx -> {'match_portion'}   = undef;
        $ctx -> {'right_unmatch'}   = undef;
        $ctx -> {'match_len'}       = 0;
        $ctx -> {'full_match'}      = 0;
        $ctx -> {'left_unmatch'}    = undef;
        my $re_raw  = $ctx->{re_raw};
        my $org_pat = $pattern;
        my $internal_offset = 0;

        # Handle prefix offset if pattern is wrapped like the RE
        if ($ctx->{prefix_offset} > 0 && length($pattern) >= $ctx->{prefix_offset} + 1)
            {
            my $re_delim_char  = _stringat($re_raw, $ctx->{prefix_offset} - 1);
            my $pat_first_char = _stringat($pattern, 0);
            if ($pat_first_char == $re_delim_char)
                {
                $pattern = substr($org_pat, $ctx->{prefix_offset});
                chop $pattern;
                $internal_offset = $ctx->{prefix_offset};
                }
            }

        # Fast track: check if it matches globally first
        if ($pattern =~ $ctx->{re_compiled})
            {
            $ctx->{full_match}    = 1;
            $ctx->{match_len}     = length($org_pat);
            $ctx->{match_portion} = $&; # the exact sub portion that matched
            $ctx->{left_unmatch}  = $`; # the left  part of matching sub part
            $ctx->{right_unmatch} = $'; # the right part of matching sub part

            # --- Capture Groups Extraction ---
            # We populate the captures array only on a successful global match
            my @caps;

            # The special variable $#- contains the number of capture groups
            # We start at 1 because $0 is the whole match
            for my $i (1 .. $#-)
                {
                if (defined $-[$i])
                    {
                    # Extracting the substring using offsets from @- and @+
                    push @caps, substr($pattern, $-[$i], $+[$i] - $-[$i]);
                    }
                else
                    {
                    # Optional group that participated but didn't catch text
                    push @caps, undef;
                    }
                }
            $ctx->{captures} = \@caps;

            return 1;
            }

        # Nibbling phase: find the longest matching lexical group
        my $match_reg = Tstregex::C_EMPTY;
        foreach my $step (@{$ctx->{steps}})
            {
            if ($pattern =~ qr/$step/)
                {
                $match_reg = $step;
                last;
                }
            }

        # ** SENSITIVE **
        # Fine-tune the match length character by character
        # Append a \z to avoid Perl to skip final \n
        # if Nibbling failed ($match_reg empty), get the full regex for fine-tuning.
        my $target_re = ($match_reg ne Tstregex::C_EMPTY) ? $match_reg : $ctx->{re_clean};
        # critical! add starting anchor (\A) to force coherency check from the first char..
        my ($match_work, $warn) = _safe_qr("\\A$target_re\\z"); # (qr/\A$target_re\z/, undef); #;
        for (my $i = length($pattern); $i >= 0; $i--)
            {
            # check if current prefix is valid according to the target
            last if ($pattern =~ $match_work);
            chop $pattern;
            }
        $ctx->{match_len}  = length($pattern) + $internal_offset;

        # Identify the failing token for display
        my $tail_re = (scalar @{$ctx->{steps}}) ? $ctx->{steps}->[0] : $ctx->{re_clean};
        my $remaining_re = substr($tail_re, length($match_reg));

        if ($remaining_re ne Tstregex::C_EMPTY)
            {
            # get the first token for analyse
            my $next_tokens = _get_lex_groups($remaining_re);
            my $first_token = $next_tokens->[0] // Tstregex::C_EMPTY;
            $ctx->{fail_token} = $remaining_re;
            $ctx->{fail_token} = $first_token if ($first_token =~ /^(\\b|\^|\$)$/); # Anchor case (0 width): want detail (just \b, ^ or $)
            }
        else
            {
            $ctx->{fail_token} = Tstregex::C_EMPTY;
            }

        # Ensure captures is empty/undef on failure
        $ctx->{captures} = [];
        return $ctx->{match_undef}? undef:0;
        }

    # Context initialization and RE peeling
    sub tstregex_init_desc
        {
        my ($re_raw) = @_;
        # The Shield: Catching the 5.28 deprecation warnings and fatal errors
        # We use a localized __WARN__ handler to catch the "Unescaped left brace"
        # even if it's not a fatal error yet in 5.28

        my ($re_compiled, $re_clean, $prefix_off, $last_warning) = _unwrap_regex($re_raw);
        my $match_undef = $re_compiled eq RE_EMPTY ? 1:0;

        my $steps = _parse_lex_groups($re_clean);
#            {
#             no warnings 'experimental::re_strict';
#             use re 'strict';
#            $steps = _parse_lex_groups($re_clean);
#            };
        return
            {
            re_raw => $re_raw, re_compiled => $re_compiled, re_clean => $re_clean,
            steps => $steps, prefix_offset => $prefix_off, match_len => 0,
            fail_token => Tstregex::C_EMPTY, full_match => 0,match_portion => undef,
            match_undef => $match_undef, left_unmatch => undef, right_unmatch => undef,
            warning => $last_warning,
            };
        }

    # Helper: get char code at position
    sub _stringat($$) { return vec($_[0], $_[1], 8); }

    sub _unwrap_regex
        {
        my ($raw) = @_;
        return (qr//, Tstregex::C_EMPTY, 0) if !defined $raw || $raw eq Tstregex::C_EMPTY;

        my $raw_org = $raw;
        my $options = Tstregex::C_EMPTY;

        # 1. Extract trailing options (ismxg)
        while ($raw =~ s/([ismxg])$//)
            {
            $options = $1 . $options;
            }

        # 2. Delegate peeling to _strop
        my $clean = _strop($raw);

        # 3. Automatic offset calculation (locate the "juice" within the original string)
        my $off = index($raw_org, $clean);
        $off = 0 if $off < 0;

        # 4. Secure Forge (Remove 'g' as it is irrelevant for qr//)
        $options =~ tr/g//d;
        my $re_str = $options ? "(?$options)$clean" : $clean;

        my ($re_ret, $warn) = _safe_qr($re_str);

        return ($re_ret, $clean, $off, $warn);
        }

    sub _safe_qr
        {
        my ($re_str) = @_;
        my ($re, $err);
            {
            local $@;
            local $SIG{__DIE__}  = local $SIG{__WARN__}  = sub { };
            # dont catch the warning there, let the eval fail instead and get the message back in $@
            $re = eval { qr/$re_str/ };
            $err = $@ // '';
            }
        return ($re // RE_EMPTY, $err);
        }

    # _strop: strip operators
    # Peels Perl operators (m!!, m{}, //) by checking extremities.
    # It ensures only the core regex juice is returned.
    sub _strop
        {
        my ($raw) = @_;
        return $raw if !defined $raw || $raw eq Tstregex::C_EMPTY;

        # Remove leading/trailing whitespace
        $raw =~ s/^\s+|\s+$//g;

        # Identify opening delimiter (after an optional 'm')
        if ($raw =~ /^((?:m\s*)?)([^\w\s])(.*)$/s)
            {
            my $prefix = $1;
            my $open   = $2;
            my $body   = $3;

            # Map symmetric pairs using ASCII constants
            my %sym_or_eq =
                (
                chr(ASCII_LBRACE) => chr(ASCII_RBRACE),
                chr(ASCII_LBRACK) => chr(ASCII_RBRACK),
                chr(ASCII_LPAREN) => chr(ASCII_RPAREN),
                chr(ASCII_LT)     => chr(ASCII_GT),
                );

            # Expected close is either the matching pair or the same character (e.g., m!!)
            my $expected_close = $sym_or_eq{$open} || $open;

            # PROTECT CAPTURE GROUPS:
            # If the delimiter is a parenthesis but there is no 'm' prefix,
            # it is a capturing group, NOT an operator. Do not peel!
            if ($open eq chr(ASCII_LPAREN) && !$prefix)
                {
                return $raw;
                }

            # Check if the very last character matches our expected closing delimiter
            if (substr($body, -1) eq $expected_close)
                {
                return substr($body, 0, -1);
                }

            # If 'm' was present but closing failed, return body (best effort)
            return $body if $prefix;
            }

        return $raw;
        }

    sub _parse_lex_groups
        {
        my ($regex) = @_;
        my $tokens = _get_lex_groups($regex);
        my @results;
        my $current = join(Tstregex::C_EMPTY, @$tokens);

        while (@$tokens)
            {
            my $opens  = () = $current =~ /(?
            my $closes = () = $current =~ /(?
            if ($opens >= $closes)
                {
                my $v = $current . (')' x ($opens - $closes));
                $v =~ s/(?
                if (eval { qr/$v/ }) { push @results, $v; }
                }
            my $last = pop @$tokens;
            substr($current, -length($last)) = Tstregex::C_EMPTY if defined $last;
            }
        return \@results;
        }

    # Lexical tokenizer for Perl Regex
    sub _get_lex_groups
        {
        my ($regex) = @_;
        my @groups;

        # --- START: class mismatch support (Added [.*?] to tokenizer) ---
#       my $re = qr/(\(\?\#.*?\))|(\(\?[:=!<>]+)|(\{\d+,?\d*\})|(\[.*?\])|(\\.)|([\(\)\|^\$\+\*\?])|(.)/x;
        # --- ENHANCED: Atomic Lookaround & Recursive Group Support ---
        # Group 1: Comments (?#...)
        # Group 2: Assertions and Groups (?=, (?:, (?<, etc. including nested parens
        # Group 3: Quantifiers {n,m}
        # Group 4: Character classes [...]
        # Group 5: Escaped characters \.
        # Group 6: Metacharacters ( ) | ^ $ + * ?
        # Group 7: Any other character
        # --- END: class mismatch support ---
        my $re = qr/
              (\(\?\#.*?\))
            | (                       # START GROUP 2
                \(\?[:=!<>]+          # Assertion header
                (?:                   # Content
                    (?> [^()]+ )      # Non-paren characters (atomic)
                    |
                    (?2)              # Recursive call to Group 2
                )*
                \)                    # Matching closing paren
              )                       # END GROUP 2
            | (\{\d+,?\d*\})
            | (\[.*?\])
            | (\\.)
            | ([\(\)\|^\$\+\*\?])
            | (.)
        /x;

        while ($regex =~ /$re/g)
            {
            my $t = $1 // $2 // $3 // $4 // $5 // $6 // $7;
            if (defined $t && $t =~ /^[\+\*\?]$|^\{\d/ && @groups && $groups[-1] !~ /^[\(\)\|]$/)
                {
                $groups[-1] .= $t;
                }
            else { push @groups, $t; }
            }

#         TODO: test that optimized code fragment instead; Much time spent here, but sensitive part..
#         my $quantifiers = '+*?{';
#         while ($regex =~ /$re/g)
#             {
#             my $t = $1 // $2 // $3 // $4 // $5 // $6 // $7;
#             if (defined $t && @groups)
#                 {
#                 my $char = substr($t, 0, 1);
#                 if (index($quantifiers, $char) != -1 && $groups[-1] !~ /^[\(\)\|]$/)
#                     {
#                     $groups[-1] .= $t;
#                     next;
#                     }
#                 }
#             push @groups, $t;
#             }

        return \@groups;
        }

    }

1;

package main;

__DATA__