File Coverage

blib/lib/Regexp/Parser/Handlers.pm

Criterion	Covered	Total	%
statement	582	710	81.9
branch	200	304	65.7
condition	16	24	66.6
subroutine	77	101	76.2
pod	0	1	0.0
total	875	1140	76.7

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');
  });

  # 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;
    return $S->object(bound => nbound => '\B');
  });

  # bound (not a word boundary)
  $self->add_handler('\b' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\b", '\b') if $cc;
    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}");
  });

  # 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) = @_;
    $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 (${&Rx} =~ m{ \G ( \\ ) }xgcs) {
        my $c = $1;
        $$ret = $S->$c(1);
      }
      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 (${&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);
    }

    # 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 .= $_;
        $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 .= $_;
          $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));
  });

  # 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;
  });
}


1;

__END__