File Coverage

blib/lib/Regexp/Parser/Handlers.pm

Criterion	Covered	Total	%
statement	706	843	83.7
branch	253	368	68.7
condition	26	36	72.2
subroutine	86	110	78.1
pod	0	1	0.0
total	1071	1358	78.8

package Regexp::Parser;

my ($nest_eval, $nest_logical);
$nest_eval    = qr[ (?> [^\\{}]+ | \\. | { (??{ $nest_eval    }) } )* ]x;
$nest_logical = qr[ (?> [^\\{}]+ | \\. | { (??{ $nest_logical }) } )* ]x;

sub init {
  my ($self) = @_;

  # /m, /s, /i, /x flags
  $self->add_flag('m' => sub { 0x1 });
  $self->add_flag('s' => sub { 0x2 });
  $self->add_flag('i' => sub { 0x4 });
  $self->add_flag('x' => sub { 0x8 });

  # /a, /d, /l, /u charset flags (Perl 5.14+)
  # These are mutually exclusive; the last one set wins.
  $self->add_flag('a' => sub { 0x10 });
  $self->add_flag('d' => sub { 0x20 });
  $self->add_flag('l' => sub { 0x40 });
  $self->add_flag('u' => sub { 0x80 });

  # /n (no-capture) flag (Perl 5.22+)
  $self->add_flag('n' => sub { 0x100 });

  # (useless) /g, /c, /o flags
  $self->add_flag('g' => sub {
    my ($S, $plus) = @_;
    $S->warn($S->RPe_BADFLG, $plus ? "" : "-", "g", $plus ? "" : "don't ", "g");
    return 0x0;
  });
  $self->add_flag('c' => sub {
    my ($S, $plus) = @_;
    $S->warn($S->RPe_BADFLG, $plus ? "" : "-", "c", $plus ? "" : "don't ", "gc");
    return 0x0;
  });
  $self->add_flag('o' => sub {
    my ($S, $plus) = @_;
    $S->warn($S->RPe_BADFLG, $plus ? "" : "-", "o", $plus ? "" : "don't ", "o");
    return 0x0;
  });

  $self->add_handler('\a' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\a", '\a') if $cc;
    return $S->object(exact => "\a", '\a');
  });

  $self->add_handler('\e' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\e", '\e') if $cc;
    return $S->object(exact => "\e", '\e');
  });

  $self->add_handler('\f' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\f", '\f') if $cc;
    return $S->object(exact => "\f", '\f');
  });

  $self->add_handler('\n' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\n", '\n') if $cc;
    return $S->object(exact => "\n", '\n');
  });

  $self->add_handler('\r' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\r", '\r') if $cc;
    return $S->object(exact => "\r", '\r');
  });

  $self->add_handler('\t' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\t", '\t') if $cc;
    return $S->object(exact => "\t", '\t');
  });

  # \Q (quotemeta) — enter literal quoting mode until \E
  $self->add_handler('\Q' => sub {
    my ($S, $cc) = @_;
    $S->{quotemeta} = 1;
    return;
  });

  # \E — exit quotemeta mode (no-op if not in quotemeta)
  $self->add_handler('\E' => sub {
    my ($S, $cc) = @_;
    $S->{quotemeta} = 0;
    return;
  });

  # bol, mbol, sbol
  $self->add_handler('^' => sub {
    my ($S) = @_;
    my $type =
      &Rf & $S->FLAG_m ? 'mbol' :
      &Rf & $S->FLAG_s ? 'sbol' :
      'bol';
    return $S->object(bol => $type, '^');
  });

  # sbol (beginning of line in single-line mode)
  $self->add_handler('\A' => sub {
    my ($S, $cc) = @_;
    $S->warn($S->RPe_BADESC, "A", " in character class") if $cc;
    return $S->force_object(anyof_char => 'A') if $cc;
    return $S->object(bol => 'sbol' => '\A');
  });

  # nbound (not a word boundary)
  $self->add_handler('\B' => sub {
    my ($S, $cc) = @_;
    $S->warn($S->RPe_BADESC, "B", " in character class") if $cc;
    return $S->force_object(anyof_char => 'B') if $cc;
    # extended boundary types: \B{gcb}, \B{g}, \B{wb}, \B{sb}, \B{lb}
    if (${&Rx} =~ m{ \G \{ (gcb|g|wb|sb|lb) \} }xgc) {
      my $btype = $1;
      return $S->object(bound => nbound => "\\B{$btype}", $btype);
    }
    return $S->object(bound => nbound => '\B');
  });

  # bound (word boundary)
  $self->add_handler('\b' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\b", '\b') if $cc;
    # extended boundary types: \b{gcb}, \b{g}, \b{wb}, \b{sb}, \b{lb}
    if (${&Rx} =~ m{ \G \{ (gcb|g|wb|sb|lb) \} }xgc) {
      my $btype = $1;
      return $S->object(bound => bound => "\\b{$btype}", $btype);
    }
    return $S->object(bound => bound => '\b');
  });

  # cany (any byte)
  $self->add_handler('\C' => sub {
    my ($S, $cc) = @_;
    $S->warn($S->RPe_BADESC, "C", " in character class") if $cc;
    return $S->force_object(anyof_char => 'C') if $cc;
    return $S->object(reg_any => c_any => '\C');
  });

  # control character
  $self->add_handler('\c' => sub {
    my ($S, $cc) = @_;
    ${&Rx} =~ m{ \G (.?) }xgc;
    my $c = $1;
    return $S->force_object(anyof_char => chr(64 ^ ord $c), "\\c$c") if $cc;
    return $S->object(exact => chr(64 ^ ord $c), "\\c$c");
  });

  # ndigit (not a digit)
  $self->add_handler('\D' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(digit => 1)) if $cc;
    return $S->object(digit => 1);
  });

  # digit (a digit)
  $self->add_handler('\d' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(digit => 0)) if $cc;
    return $S->object(digit => 0);
  });

  # gpos (last global match end)
  $self->add_handler('\G' => sub {
    my ($S, $cc) = @_;
    $S->warn($S->RPe_BADESC, "G", " in character class") if $cc;
    return $S->force_object(anyof_char => 'G') if $cc;
    return $S->object(gpos => gpos => '\G');
  });

  # \g{N}, \g{-N}, \gN backreferences (Perl 5.10+)
  $self->add_handler('\g' => sub {
    my ($S, $cc) = @_;
    if ($cc) {
      $S->warn($S->RPe_BADESC, "g", " in character class");
      return $S->force_object(anyof_char => 'g');
    }

    # \g{...} form
    if (${&Rx} =~ m{ \G \{ }xgc) {
      # \g{name} — named backref
      if (${&Rx} =~ m{ \G ([a-zA-Z_]\w*) \} }xgc) {
        my $name = $1;
        return $S->object(gref => $name, "\\g{$name}");
      }
      # \g{N} or \g{-N} — numeric (possibly relative)
      if (${&Rx} =~ m{ \G (-?\d+) \} }xgc) {
        my $num = $1;
        my $abs;
        if ($num < 0) {
          $abs = (&SIZE_ONLY ? $S->{maxpar} : $S->{nparen}) + $num + 1;
          $S->error($S->RPe_BGROUP) if !&SIZE_ONLY and $abs < 1;
        }
        else {
          $abs = $num;
          $S->error($S->RPe_BGROUP) if !&SIZE_ONLY and $abs > $S->{maxpar};
        }
        return $S->object(ref => $abs, "\\g{$num}");
      }
      $S->error($S->RPe_RBRACE, 'g');
    }

    # \gN form (no braces, positive only)
    if (${&Rx} =~ m{ \G (\d+) }xgc) {
      my $num = $1;
      $S->error($S->RPe_BGROUP) if !&SIZE_ONLY and $num > $S->{maxpar};
      return $S->object(ref => $num, "\\g$num");
    }

    $S->error($S->RPe_BRACES, 'g');
  });

  # named (named character)
  $self->add_handler('\N' => sub {
    my ($S, $cc) = @_;
    $S->error($S->RPe_BRACES, 'N') if ${&Rx} !~ m{ \G \{ }xgc;
    $S->error($S->RPe_RBRACE, 'N') if ${&Rx} !~ m{ \G ([^\}]*) \} }xgc;

    my $name = $1;
    return $S->force_object(anyof_char => $S->nchar($name), "\\N{$name}") if $cc;
    return $S->object(exact => $S->nchar($name), "\\N{$name}");
  });

  # \o{NNN} octal escape (Perl 5.14+)
  $self->add_handler('\o' => sub {
    my ($S, $cc) = @_;
    $S->error($S->RPe_BRACES, 'o') if ${&Rx} !~ m{ \G \{ }xgc;
    $S->error($S->RPe_RBRACE, 'o') if ${&Rx} !~ m{ \G ([0-7]+) \} }xgc;

    my $num = $1;
    my $rep = "\\o{$num}";
    return $S->force_object(anyof_char => chr(oct $num), $rep) if $cc;
    return $S->object(exact => chr(oct $num), $rep);
  });

  # nprop (not a unicode property)
  $self->add_handler('\P' => sub {
    my ($S, $cc) = @_;
    $S->error($S->RPe_EMPTYB, 'P') if ${&Rx} !~ m{ \G (.) }xgcs;

    my $name = $1;
    if ($name eq '{') {
      $S->error($S->RPe_RBRACE, 'P') if ${&Rx} !~ m{ \G ([^\}]*) \} }xgc;
      $name = $1;
    }

    return $S->force_object(anyof_class => $S->force_object(prop => $name, 1)) if $cc;
    return $S->object(prop => $name, 1);
  });

  # prop (a unicode property)
  $self->add_handler('\p' => sub {
    my ($S, $cc) = @_;
    $S->error($S->RPe_EMPTYB, 'p') if ${&Rx} !~ m{ \G (.) }xgcs;

    my $name = $1;
    if ($name eq '{') {
      $S->error($S->RPe_RBRACE, 'p') if ${&Rx} !~ m{ \G ([^\}]*) \} }xgc;
      $name = $1;
    }

    return $S->force_object(anyof_class => $S->force_object(prop => $name, 0)) if $cc;
    return $S->object(prop => $name, 0);
  });

  # nspace (not a space)
  $self->add_handler('\S' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(space => 1)) if $cc;
    return $S->object(space => 1);
  });

  # space (a space)
  $self->add_handler('\s' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(space => 0)) if $cc;
    return $S->object(space => 0);
  });

  # nalnum (not a word character)
  $self->add_handler('\W' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(alnum => 1)) if $cc;
    return $S->object(alnum => 1);
  });

  # alnum (a word character)
  $self->add_handler('\w' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(alnum => 0)) if $cc;
    return $S->object(alnum => 0);
  });

  # clump (a unicode clump)
  $self->add_handler('\X' => sub {
    my ($S, $cc) = @_;
    $S->warn($S->RPe_BADESC, 'X', ' in character class') if $cc;
    return $S->force_object(anyof_char => 'X') if $cc;
    return $S->object(clump => '\X');
  });

  # hex character
  $self->add_handler('\x' => sub {
    my ($S, $cc) = @_;
    ${&Rx} =~ m{ \G ( \{ | .{0,2} ) }sxgc;
    my $brace = 0;
    my $num = $1;

    if ($num eq '{') {
      $S->error($S->RPe_RBRACE, 'x') if ${&Rx} !~ m{ \G ( [^\}]* ) \} }xgc;
      $num = $1;
      $brace = 1;
    }
    else {
      my $good = ($num =~ s/^([a-fA-F0-9]*)// and $1);
      &RxPOS -= length $num;
      $num = $good;
    }

    my $rep = $brace ? "\\x{$num}" : sprintf("\\x%02s", $num);
    return $S->force_object(anyof_char => chr hex $num, $rep) if $cc;
    return $S->object(exact => chr hex $num, $rep);
  });

  # eol, seol, meol
  $self->add_handler('$' => sub {
    my ($S) = @_;
    my $type =
      &Rf & $S->FLAG_m ? 'meol' :
      &Rf & $S->FLAG_s ? 'seol' :
      'eol';
    return $S->object(eol => $type, '$');
  });

  # seol (end of line, in single-line mode)
  $self->add_handler('\Z' => sub {
    my ($S, $cc) = @_;
    $S->warn($S->RPe_BADESC, "Z", " in character class") if $cc;
    return $S->force_object(anyof_char => 'Z') if $cc;
    return $S->object(eol => seol => '\Z');
  });

  # eos (end of string)
  $self->add_handler('\z' => sub {
    my ($S, $cc) = @_;
    $S->warn($S->RPe_BADESC, "z", " in character class") if $cc;
    return $S->force_object(anyof_char => 'z') if $cc;
    return $S->object(eol => eos => '\z');
  });

  # alpha POSIX class
  $self->add_handler('POSIX_alpha' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => alpha => $neg, \$how);
  });

  # alnum POSIX class
  $self->add_handler('POSIX_alnum' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => alnum => $neg, \$how);
  });

  # ascii POSIX class
  $self->add_handler('POSIX_ascii' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => ascii => $neg, \$how);
  });

  # cntrl POSIX class
  $self->add_handler('POSIX_cntrl' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => cntrl => $neg, \$how);
  });

  # digit POSIX class
  $self->add_handler('POSIX_digit' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => digit => $neg, \$how);
  });

  # graph POSIX class
  $self->add_handler('POSIX_graph' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => graph => $neg, \$how);
  });

  # lower POSIX class
  $self->add_handler('POSIX_lower' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => lower => $neg, \$how);
  });

  # print POSIX class
  $self->add_handler('POSIX_print' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => print => $neg, \$how);
  });

  # punct POSIX class
  $self->add_handler('POSIX_punct' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => punct => $neg, \$how);
  });

  # space POSIX class
  $self->add_handler('POSIX_space' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => space => $neg, \$how);
  });

  # upper POSIX class
  $self->add_handler('POSIX_upper' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => upper => $neg, \$how);
  });

  # word POSIX class
  $self->add_handler('POSIX_word' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => word => $neg, \$how);
  });

  # xdigit POSIX class
  $self->add_handler('POSIX_xdigit' => sub {
    my ($S, $neg, $how) = @_;
    return $S->force_object(anyof_class => xdigit => $neg, \$how);
  });

  $self->add_handler('atom' => sub {
    my ($S) = @_;

    # \Q quotemeta mode: treat everything as literal until \E
    if ($S->{quotemeta}) {
      ${&Rx} =~ m{ \G (.) }xgcs or return;
      my $c = $1;
      push @{ $S->{next} }, qw< atom >;

      # \E exits quotemeta mode
      if ($c eq '\\') {
        if (${&Rx} =~ m{ \G E }xgc) {
          $S->{quotemeta} = 0;
          return;
        }
        # literal backslash
        return $S->object(exact => '\\', '\\\\');
      }

      # metacharacters get escaped visual, but match literally
      my $vis = $c =~ /[\.\+\*\?\^\$\|\(\)\{\}\[\]\\]/ ? "\\$c" : $c;
      return $S->object(exact => $c, $vis);
    }

    $S->nextchar;

    ${&Rx} =~ m{ \G (.) }xgcs or return;
    my $c = $1;

    push @{ $S->{next} }, qw< atom >;
    return $S->$c if $S->can($c);
    return $S->object(exact => $c);
  });

  $self->add_handler('*' => sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< minmod >;
    return $S->object(quant => 0, '');
  });

  $self->add_handler('+' => sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< minmod >;
    return $S->object(quant => 1, '');
  });

  $self->add_handler('?' => sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< minmod >;
    return $S->object(quant => 0, 1);
  });

  $self->add_handler('{' => sub {
    my ($S) = @_;
    if (${&Rx} =~ m{ \G (\d+) (,?) (\d*) \} }xgc) {
      my ($min, $range, $max) = ($1, $2, $3);
      $max = $min unless $range;
      push @{ $S->{next} }, qw< minmod >;
      $S->error($S->RPe_BCURLY) if length($max) and $min > $max;
      return $S->object(quant => $min, $max);
    }
    return $S->object(exact => '{');
  });

  $self->add_handler('minmod' => sub {
    my ($S) = @_;
    $S->nextchar;
    return $S->object(minmod =>) if ${&Rx} =~ m{ \G \? }xgc;
    return $S->object(possessive =>) if ${&Rx} =~ m{ \G \+ }xgc;
    return;
  });

  # alternation branch
  $self->add_handler('|' => sub {
    my ($S) = @_;
    return $S->object(branch =>);
  });

  # opening parenthesis (maybe capturing paren)
  $self->add_handler('(' => sub {
    my ($S) = @_;
    my $c = '(';
    $S->nextchar;

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      my $n = "$c$1";
      return $S->$n if $S->can($n);
      &RxPOS--;
    }

    push @{ $S->{next} }, qw< c) atom >;
    &SIZE_ONLY ? ++$S->{maxpar} : ++$S->{nparen};
    push @{ $S->{flags} }, &Rf;
    return $S->object(open => $S->{nparen});
  });

  # any character
  $self->add_handler('.' => sub {
    my ($S) = @_;
    my $family =
      &Rf & $S->FLAG_s ? 'sany' :
      'reg_any';
    return $S->object(reg_any => $family, '.');
  });

  # backslash
  $self->add_handler('\\' => sub {
    my ($S, $cc) = @_;
    my $c = '\\';

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      $c .= (my $n = $1);

      return $S->$c($cc) if $S->can($c);

      if ($n =~ /\d/) {
        --&RxPOS;
        my $v = "";

        # outside of char class, \nnn might be backref
        if (!&SIZE_ONLY and !$cc and $n != 0) {
          $v .= $1 while ${&Rx} =~ m{ \G (\d) }xgc;
          if ($v > 9 and $v > $S->{maxpar}) {
            &RxPOS -= length $v;
            $v = "";
          }
          elsif ($v > $S->{maxpar}) { $S->error($S->RPe_BGROUP) }
          else { return $S->object(ref => $v, "\\$v") }
        }

        $v .= $1 while ${&Rx} =~ m{ \G ([0-7]) }xgc;
        return $S->object(exact => chr oct $v, sprintf("\\%03s", $v));
      }

      $S->warn($S->RPe_BADESC, $c = $n, "") if $n =~ /[a-zA-Z]/;

      return $S->object(exact => $n, $c);
    }

    $S->error($S->RPe_ESLASH);
  });

  # start of char class (and possible negation)
  $self->add_handler('[' => sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< cce] cc cc] >;
    my $neg = ${&Rx} =~ m{ \G \^ }xgc;

    my $pos = &RxPOS;
    if (${&Rx} =~ m{ \G ([:.=]) .*? \1 ] }xgc) {
      $S->warn($S->RPe_OUTPOS, $1, $1);
      &RxPOS = $pos;
    }

    return $S->object(anyof => $neg);
  });

  # char class ] at beginning
  $self->add_handler('cc]' => sub {
    my ($S) = @_;
    return unless ${&Rx} =~ m{ \G ] }xgc;
    return $S->object(anyof_char => "]");
  });

  # start of char class range (or maybe just char)
  $self->add_handler('cc' => sub {
    my ($S) = @_;
    return if ${&Rx} =~ m{ \G (?= ] | \z ) }xgc;
    push @{ $S->{next} }, qw< cc >;
    my ($lhs, $rhs, $before_range);
    my $ret = \$lhs;

    {
      if ($S->{quotemeta}) {
        # quotemeta mode: \E exits, everything else is literal
        if (${&Rx} =~ m{ \G \\ E }xgc) {
          $S->{quotemeta} = 0;
          $ret = undef;
          last;
        }
        elsif (${&Rx} =~ m{ \G (.) }xgcs) {
          # escape char class metacharacters for correct visual
          my $c = $1;
          my $vis = $c =~ /[\-\]\\^]/ ? "\\$c" : $c;
          $$ret = $S->force_object(anyof_char => $c, $vis);
        }
      }
      elsif (${&Rx} =~ m{ \G ( \\ ) }xgcs) {
        my $c = $1;
        my $qm_before = $S->{quotemeta};
        $$ret = $S->$c(1);
        # \Q/\E change quotemeta state and return undef — redo to continue
        if (!defined $$ret && $S->{quotemeta} != $qm_before) { redo }
      }
      elsif (${&Rx} =~ m{ \G \[ ([.=:]) (\^?) (.*?) \1 \] }xgcs) {
        my ($how, $neg, $name) = ($1, $2, $3);
        my $posix = "POSIX_$name";
        if ($S->can($posix)) { $$ret = $S->$posix($neg, $how) }
        else { $S->error($S->RPe_BADPOS, "$how$neg$name$how") }
      }
      elsif (${&Rx} =~ m{ \G (.) }xgcs) {
        $$ret = $S->force_object(anyof_char => $1);
      }

      if ($ret == \$lhs) {
        if (!$S->{quotemeta} && ${&Rx} =~ m{ \G (?= - (?! ] | \z ) ) }xgc) {
          if ($lhs->visual =~ /^(?:\[[:.=]|\\[dDsSwWpP])/) {
            $S->warn($S->RPe_FRANGE, $lhs->visual, "");
            $ret = $lhs;
            last;
          }
          $before_range = &RxPOS++;
          $ret = \$rhs;
          redo;
        }
        $ret = $lhs;
      }
      elsif ($ret == \$rhs) {
        if ($rhs->visual =~ /^(?:\[[:.=]|\\[dDsSwWpP])/) {
          $S->warn($S->RPe_FRANGE, $lhs->visual, $rhs->visual);
          &RxPOS = $before_range;
          $ret = $lhs;
        }
        elsif (ord($lhs->data) > ord($rhs->data)) {
          $S->error($S->RPe_IRANGE, $lhs->visual, $rhs->visual);
        }
        else {
          $ret = $S->object(anyof_range => $lhs, $rhs);
        }
      }
    }

    return if &SIZE_ONLY;
    return $ret;
  });

  # end of char class
  $self->add_handler('cce]' => sub {
    my ($S) = @_;
    $S->error($S->RPe_LBRACK) if ${&Rx} !~ m{ \G ] }xgc;
    return $S->object(anyof_close => "]");
  });

  # closing paren coming from 'atom'
  $self->add_handler(')' => sub {
    my ($S) = @_;
    pop @{ $S->{next} };
    &RxPOS--;
    return;
  });

  # closing paren coming from an opening paren
  $self->add_handler('c)' => sub {
    my ($S) = @_;
    $S->error($S->RPe_LPAREN) if ${&Rx} !~ m{ \G \) }xgc;
    pop @{ $S->{flags} };
    return $S->object(close =>);
  });

  # some kind of assertion...
  $self->add_handler('(?' => sub {
    my ($S) = @_;
    my $c = '(?';

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      my $n = "$c$1";
      return $S->$n if $S->can($n);
      &RxPOS--;
    }
    else {
      $S->error($S->RPe_SEQINC);
    }

    # (?0) is equivalent to (?R) -- whole-pattern recursion
    # (?1), (?2), ... -- numbered group recursion
    # (?+1), (?-1) -- relative group recursion
    if (${&Rx} =~ m{ \G ( [+-]? [0-9]+ ) \) }xgc) {
      my $num = $1;
      my $vis = "(?$num)";
      return $S->object(recurse => $num, $vis);
    }

    # Perl 5.14+ flag reset: (?^...) means default flags
    my $caret = 0;
    if (${&Rx} =~ m{ \G \^ }xgc) {
      $caret = 1;
    }

    # flag assertion or non-capturing group
    ${&Rx} =~ m{ \G ([a-zA-Z]*) (-? [a-zA-Z]*) }xgc;
    my ($on, $off) = ($1, $2);
    my ($r_on, $r_off) = ("", "");
    my ($f_on, $f_off) = (0,0);

    &RxPOS -= length($on.$off);
    my $old = &RxPOS;

    for (split //, $on) {
      &RxPOS++;
      if (my $f = $S->can("FLAG_$_")) {
        my $v = $S->$f(1) and $r_on .= $_;
        # /xx: if x is already on, set the xx bit (Perl 5.26+)
        if ($_ eq 'x' && ($f_on & $v)) {
          $f_on |= 0x200;  # FLAG_xx
        }
        $f_on |= $v;
        next;
      }
      my $bad = substr ${&Rx}, $old;
      $S->error($S->RPe_NOTREC, &RxPOS - $old, $bad);
    }

    if (!$caret) {
      &RxPOS++ if $off =~ s/^-//;

      for (split //, $off) {
        &RxPOS++;
        if (my $f = $S->can("FLAG_$_")) {
          my $v = $S->$f(0) and $r_off .= $_;
          # -xx: also turn off the xx bit (Perl 5.26+)
          if ($_ eq 'x' && ($f_off & $v)) {
            $f_off |= 0x200;  # FLAG_xx
          }
          $f_off |= $v;
          next;
        }
        my $bad = substr ${&Rx}, $old;
        $S->error($S->RPe_NOTREC, &RxPOS - $old, $bad);
      }
    }

    if (${&Rx} =~ m{ \G ([:)]) }xgc) {
      my $type = $1 eq ':' ? 'group' : 'flags';
      if ($type eq 'group') {
        push @{ $S->{flags} }, &Rf;
        push @{ $S->{next} }, qw< c) atom >;
      }
      if ($caret) {
        &Rf = 0;  # reset all flags to default
      }
      &Rf |= $f_on;
      &Rf &= ~$f_off;
      my $vis_on = $caret ? "^$r_on" : $r_on;
      return $S->object($type => $vis_on, $r_off);
    }

    &RxPOS++;
    my $l = length($on.$off) + 2;
    $S->error($S->RPe_NOTREC, $l, substr(${&Rx}, $old));
  });

  # comment
  $self->add_handler('(?#' => sub {
    my ($S) = @_;
    ${&Rx} =~ m{ \G [^)]* }xgc;
    $S->error($S->RPe_NOTERM) unless ${&Rx} =~ m{ \G \) }xgc;
    return;
  });

  # not implemented (?$...)
  $self->add_handler('(?$' => sub {
    my ($S) = @_;
    $S->error($S->RPe_NOTREC, 1, substr(${&Rx}, &RxPOS - 1));
  });

  # not implemented (?@...)
  $self->add_handler('(?@' => sub {
    my ($S) = @_;
    $S->error($S->RPe_NOTREC, 1, substr(${&Rx}, &RxPOS - 1));
  });

  # look-ahead
  $self->add_handler('(?=' => sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< c) atom >;
    push @{ $S->{flags} }, &Rf;
    return $S->object(ifmatch => 1);
  });

  # look-ahead (neg)
  $self->add_handler('(?!' => sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< c) atom >;
    push @{ $S->{flags} }, &Rf;
    return $S->object(unlessm => 1);
  });

  # look-behind prefix
  $self->add_handler('(?<' => sub {
    my ($S) = @_;
    my $c = '(?<';

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      my $n = "$c$1";
      return $S->$n if $S->can($n);
    }

    $S->error($S->RPe_NOTREC, 2, substr(${&Rx}, &RxPOS - 2));
  });

  # look-behind
  $self->add_handler('(?<=' => sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< c) atom >;
    push @{ $S->{flags} }, &Rf;
    return $S->object(ifmatch => -1);
  });

  # look-behind (neg)
  $self->add_handler('(? sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< c) atom >;
    push @{ $S->{flags} }, &Rf;
    return $S->object(unlessm => -1);
  });

  # suspend
  $self->add_handler('(?>' => sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< c) atom >;
    push @{ $S->{flags} }, &Rf;
    return $S->object(suspend =>);
  });

  # eval
  $self->add_handler('(?{' => sub {
    my ($S) = @_;
    if (${&Rx} =~ m{ \G ($nest_eval) \} \) }xgc) {
      push @{ $S->{flags} }, &Rf;
      return $S->object(eval => $1);
    }
    $S->error($S->RPe_NOTBAL);
  });

  # logical prefix
  $self->add_handler('(??' => sub {
    my ($S) = @_;
    my $c = '(??';

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      my $n = "$c$1";
      return $S->$n if $S->can($n);
    }

    $S->error($S->RPe_NOTREC, 2, substr(${&Rx}, &RxPOS - 2));
  });

  # logical
  $self->add_handler('(??{' => sub {
    my ($S) = @_;
    if (${&Rx} =~ m{ \G ($nest_logical) \} \) }xgc) {
      push @{ $S->{flags} }, &Rf;
      return $S->object(logical => $1);
    }
    $S->error($S->RPe_NOTBAL);
  });

  # logical prefix
  $self->add_handler('(?p' => sub {
    my ($S) = @_;
    my $c = '(?p';

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      my $n = "$c$1";
      return $S->$n if $S->can($n);
    }

    $S->error($S->RPe_NOTREC, 2, substr(${&Rx}, &RxPOS - 2));
  });

  # logical
  $self->add_handler('(?p{' => sub {
    my ($S) = @_;
    $S->warn($S->RPe_LOGDEP);
    my $c = "(??{";
    return $S->$c;
  });

  $self->add_handler('(?(' => sub {
    my ($S) = @_;
    my $c = '(?(';

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      my $n = "$c$1";
      return $S->$n if $S->can($n);
      &RxPOS--;
    }

    push @{ $S->{next} }, qw< ifthen( >;
    push @{ $S->{flags} }, &Rf;
    return $S->object(ifthen =>);
  });

  # (?(...)t|f) condition
  $self->add_handler('ifthen(' => sub {
    my ($S) = @_;
    my $c = 'ifthen(';

    push @{ $S->{next} }, qw< c) atom >;

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      my $n = "$c$1";
      return $S->$n if $S->can($n);
      &RxPOS--;
    }

    if (${&Rx} =~ m{ \G ( [1-9]\d* ) }xgc) {
      my $n = $1;
      $S->error($S->RPe_SWNREC) if ${&Rx} !~ m{ \G \) }xgc;
      push @{ $S->{next} }, qw< ifthen|2 ifthen| ifthen_atom >;
      return $S->object(groupp => $n);
    }

    $S->error($S->RPe_SWUNKN, &RxCUR);
  });

  # atom inside an ifthen
  $self->add_handler('ifthen_atom' => sub {
    my ($S) = @_;
    $S->nextchar;
    ${&Rx} =~ m{ \G ([^|]) }xgcs or return;
    my $c = $1;

    push @{ $S->{next} }, qw< ifthen_atom >;
    return $S->$c if $S->can($c);
    return $S->object(exact => $c);
  });

  # alternation branch inside ifthen
  $self->add_handler('ifthen|' => sub {
    my ($S) = @_;
    return if ${&Rx} !~ m{ \G \| }xgc;
    push @{ $S->{next} }, qw< ifthen_atom >;
    return $S->object(branch =>);
  });

  # illegal 2nd alternation branch inside ifthen
  $self->add_handler('ifthen|2' => sub {
    my ($S) = @_;
    return if ${&Rx} !~ m{ \G \| }xgc;
    $S->error($S->RPe_SWBRAN);
  });

  $self->add_handler('ifthen(?' => sub {
    my ($S) = @_;
    my $c = '(?';

    push @{ $S->{next} }, qw< ifthen|2 ifthen| ifthen_atom >;

    if (${&Rx} =~ m{ \G ( (?:
      my $n = "$c$1";
      return $S->$n if $S->can($n);
      &RxPOS -= length $1;
    }

    $S->error($S->RPe_SEQINC);
  });

  ##
  ## Perl 5.10+ constructs
  ##

  # \K (keep, reset match start)
  $self->add_handler('\K' => sub {
    my ($S, $cc) = @_;
    $S->warn($S->RPe_BADESC, "K", " in character class") if $cc;
    return $S->force_object(anyof_char => 'K') if $cc;
    return $S->object(keep =>);
  });

  # \R (generic linebreak)
  $self->add_handler('\R' => sub {
    my ($S, $cc) = @_;
    $S->warn($S->RPe_BADESC, "R", " in character class") if $cc;
    return $S->force_object(anyof_char => 'R') if $cc;
    return $S->object(lnbreak =>);
  });

  # \h (horizontal whitespace)
  $self->add_handler('\h' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(hspace => 0)) if $cc;
    return $S->object(hspace => 0);
  });

  # \H (not horizontal whitespace)
  $self->add_handler('\H' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(hspace => 1)) if $cc;
    return $S->object(hspace => 1);
  });

  # \v (vertical whitespace)
  $self->add_handler('\v' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(vspace => 0)) if $cc;
    return $S->object(vspace => 0);
  });

  # \V (not vertical whitespace)
  $self->add_handler('\V' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_class => $S->force_object(vspace => 1)) if $cc;
    return $S->object(vspace => 1);
  });

  # \k or \k'name' (named backreference)
  $self->add_handler('\k' => sub {
    my ($S, $cc) = @_;

    if ($cc) {
      $S->warn($S->RPe_BADESC, "k", " in character class");
      return $S->force_object(anyof_char => 'k');
    }

    if (${&Rx} =~ m{ \G < ([^>]+) > }xgc) {
      return $S->object(named_ref => $1, "\\k<$1>");
    }
    elsif (${&Rx} =~ m{ \G ' ([^']+) ' }xgc) {
      return $S->object(named_ref => $1, "\\k'$1'");
    }

    $S->error($S->RPe_BADESC, "k", "");
  });

  # (?...) named capture group
  # We override the existing '(?<' handler to also support named captures
  $self->add_handler('(?<' => sub {
    my ($S) = @_;
    my $c = '(?<';

    # Check for lookbehind first: (?<= and (?
    if (${&Rx} =~ m{ \G ([!=]) }xgcs) {
      my $n = "$c$1";
      return $S->$n if $S->can($n);
    }

    # Named capture: (?...)
    if (${&Rx} =~ m{ \G ([A-Za-z_]\w*) > }xgc) {
      my $name = $1;
      push @{ $S->{next} }, qw< c) atom >;
      &SIZE_ONLY ? ++$S->{maxpar} : ++$S->{nparen};
      push @{ $S->{flags} }, &Rf;
      $S->{named_captures}{$name} = $S->{nparen} unless &SIZE_ONLY;
      return $S->object(named_open => $S->{nparen}, $name);
    }

    $S->error($S->RPe_NOTREC, 2, substr(${&Rx}, &RxPOS - 2));
  });

  # (?'name'...) alternate named capture syntax
  $self->add_handler("(?\'" => sub {
    my ($S) = @_;

    if (${&Rx} =~ m{ \G ([A-Za-z_]\w*) ' }xgc) {
      my $name = $1;
      push @{ $S->{next} }, qw< c) atom >;
      &SIZE_ONLY ? ++$S->{maxpar} : ++$S->{nparen};
      push @{ $S->{flags} }, &Rf;
      $S->{named_captures}{$name} = $S->{nparen} unless &SIZE_ONLY;
      return $S->object(named_open => $S->{nparen}, $name);
    }

    $S->error($S->RPe_NOTREC, 1, substr(${&Rx}, &RxPOS - 1));
  });

  # (?R) -- whole-pattern recursion (Perl 5.10+)
  $self->add_handler('(?R' => sub {
    my ($S) = @_;

    $S->error($S->RPe_NOTREC, 3, "(?R" . substr(${&Rx}, &RxPOS, 1))
      unless ${&Rx} =~ m{ \G \) }xgc;

    return $S->object(recurse => 0, '(?R)');
  });

  # (?&name) -- named subpattern recursion (Perl 5.10+)
  $self->add_handler('(?&' => sub {
    my ($S) = @_;

    if (${&Rx} =~ m{ \G ([A-Za-z_]\w*) \) }xgc) {
      my $name = $1;
      return $S->object(named_recurse => $name, "(?&$name)");
    }

    $S->error($S->RPe_NOTREC, 3, "(?&" . substr(${&Rx}, &RxPOS, 5));
  });

  # (?P...) -- Python-compatible named capture (Perl 5.10+)
  # (?P=name) -- Python-compatible named backreference (Perl 5.10+)
  # (?P>name) -- Python-compatible named recursion (Perl 5.10+)
  $self->add_handler('(?P' => sub {
    my ($S) = @_;

    # (?P...) named capture
    if (${&Rx} =~ m{ \G < ([A-Za-z_]\w*) > }xgc) {
      my $name = $1;
      push @{ $S->{next} }, qw< c) atom >;
      &SIZE_ONLY ? ++$S->{maxpar} : ++$S->{nparen};
      push @{ $S->{flags} }, &Rf;
      $S->{named_captures}{$name} = $S->{nparen} unless &SIZE_ONLY;
      return $S->object(named_open => $S->{nparen}, $name);
    }

    # (?P=name) named backreference
    if (${&Rx} =~ m{ \G = ([A-Za-z_]\w*) \) }xgc) {
      my $name = $1;
      return $S->object(named_ref => $name, "(?P=$name)");
    }

    # (?P>name) named recursion
    if (${&Rx} =~ m{ \G > ([A-Za-z_]\w*) \) }xgc) {
      my $name = $1;
      return $S->object(named_recurse => $name, "(?P>$name)");
    }

    $S->error($S->RPe_NOTREC, 3, "(?P" . substr(${&Rx}, &RxPOS, 5));
  });

  # possessive quantifier modifier (a++, a*+, a?+, a{n,m}+)
  $self->add_handler('posmod' => sub {
    my ($S) = @_;
    $S->nextchar;
    return $S->object(possessive =>) if ${&Rx} =~ m{ \G \+ }xgc;
    return;
  });

  ##
  ## Perl 5.10+ branch reset group: (?|...)
  ##
  $self->add_handler('(?|' => sub {
    my ($S) = @_;
    push @{ $S->{next} }, qw< c) atom >;
    push @{ $S->{flags} }, &Rf;
    return $S->object(branch_reset =>);
  });

  ##
  ## Perl 5.10+ backtracking control verbs: (*VERB) and (*VERB:arg)
  ## Also Perl 5.28+ alphabetic assertions: (*positive_lookahead:...) etc.
  ##
  $self->add_handler('(*' => sub {
    my ($S) = @_;

    # Match the verb/keyword name
    if (${&Rx} =~ m{ \G ([A-Za-z_]\w*) }xgc) {
      my $name = $1;

      # Alphabetic assertion forms (Perl 5.28+)
      # These are grouping constructs: (*name:pattern)
      my %alpha_assert = (
        positive_lookahead  => ['ifmatch',  1],
        pla                 => ['ifmatch',  1],
        negative_lookahead  => ['unlessm',  1],
        nla                 => ['unlessm',  1],
        positive_lookbehind => ['ifmatch',  -1],
        plb                 => ['ifmatch',  -1],
        negative_lookbehind => ['unlessm',  -1],
        nlb                 => ['unlessm',  -1],
        atomic              => ['suspend',  undef],
        script_run          => ['script_run', undef],
        sr                  => ['script_run', undef],
        atomic_script_run   => ['asr',      undef],
        asr                 => ['asr',      undef],
      );

      if (my $spec = $alpha_assert{$name}) {
        $S->error($S->RPe_NOTREC, length($name) + 1, "*$name")
          if ${&Rx} !~ m{ \G : }xgc;
        push @{ $S->{next} }, qw< c) atom >;
        push @{ $S->{flags} }, &Rf;
        my ($type, $dir) = @$spec;
        return $S->object($type => $dir) if defined $dir;
        return $S->object($type =>);
      }

      # Backtracking control verbs (Perl 5.10+)
      my $arg;
      if (${&Rx} =~ m{ \G : ([^)]*) }xgc) {
        $arg = $1;
      }
      $S->error($S->RPe_LPAREN) if ${&Rx} !~ m{ \G \) }xgc;

      # Validate known verbs
      my %known_verb = map { $_ => 1 }
        qw(ACCEPT FAIL F MARK SKIP PRUNE COMMIT THEN);
      if (!$known_verb{$name}) {
        $S->error($S->RPe_NOTREC, length($name) + 1, "*$name");
      }
      return $S->object(verb => $name, $arg);
    }

    $S->error($S->RPe_NOTREC, 1, substr(${&Rx}, &RxPOS - 1));
  });
}


1;

__END__