File Coverage

blib/lib/Tstregex.pm

Criterion	Covered	Total	%
statement	165	293	56.3
branch	37	102	36.2
condition	36	80	45.0
subroutine	27	38	71.0
pod	9	11	81.8
total	274	524	52.2

#!/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 Hybrid Regex Diagnostic Tool (single file Library module and command tool)
shows the longest Regular Expression match / highlight the rejected part
Example:
$ perl lib/Tstregex.pm '/^[a-z]*\d{3}$/' 'abc123' 'abc12a'
abc123
abcB<12a> (B<^[a-z]*>\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)

=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

Triggers the Enriched Diagnostic View. It displays:
- The string with the failing part highlighted.
- The exact token in the regex that caused the break.
- A visual pointer (C<^--- HERE>) aligned with the regex syntax.
- Execution time (useful for spotting ReDoS/Exponential backtracking).

=head2 -a --assert

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

=head2

=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";
      }

=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

C is designed to solve the "Black Box" problem of Regular Expressions.
When a complex regex fails, Perl usually just says "No Match". This tool
identifies exactly B and B it failed by finding the longest possible
partial match.

=head1 EXAMPLE

  $ perl lib/Tstregex.pm '/^[a-z]*\d{3}$/' 'abc123' 'abc12a'
  abc123
  abcB<12a> (B<^[a-z]*>\d{3}$)

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

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.

=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 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 _display_standard
        {
        my ($pattern, $ctx) = @_;
        if (Tstregex::tstregex_is_full_match($ctx))
            {
            print "$pattern";
            print "\n";
            }
        else
            {
            my $match_len  = Tstregex::tstregex_get_match_len ($ctx);
            my $fail_token = Tstregex::tstregex_get_fail_token($ctx);
            my $re_clean   = Tstregex::tstregex_get_re_clean  ($ctx);
            print substr($pattern, 0, $match_len), BOLD, substr($pattern, $match_len), RESET;
            my $off = length($re_clean) - length($fail_token);
            print ' (', substr($re_clean, 0, $off), BOLD, $fail_token, RESET, ")\n";
            }
        }

    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";
            }
        else
            {
            my $match_len  = Tstregex::tstregex_get_match_len    ($ctx);
            my $fail_token = Tstregex::tstregex_get_fail_token   ($ctx);
            my $re_clean   = Tstregex::tstregex_get_re_clean     ($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;
        }

    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.03';
    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__