File Coverage

blib/lib/Regexp/Parser/Objects.pm

Criterion	Covered	Total	%
statement	455	678	67.1
branch	103	218	47.2
condition	39	69	56.5
subroutine	137	189	72.4
pod			n/a
total	734	1154	63.6

use NEXT;

{
  package Regexp::Parser::__object__;

  sub class {
    my $self = shift;
    Carp::carp("class() deprecated; use family() instead");
    $self->family(@_);
  }

  sub flags {
    my $self = shift;
    $self->{flags};
  }

  sub family {
    my $self = shift;
    $self->{family};
  }

  sub type {
    my $self = shift;
    $self->{type};
  }

  sub qr {
    my $self = shift;
    $self->visual(@_);
  }

  sub visual {
    my $self = shift;
    exists $self->{vis} ? $self->{vis} : '';
  }

  sub raw {
    my $self = shift;
    exists $self->{raw} ? $self->{raw} : $self->visual(@_);
  }

  sub data {
    my $self = shift;
    return $self->{data};
  }

  sub ender {
    my $self = shift;
    unless ($self->{down}) {
      Carp::carp("ender() ignored for ", $self->family, "/", $self->type);
      return;
    }
    [ 'tail' ];
  }

  sub walk {
    my $self = shift;
    return;
  }

  sub omit {
    my $self = shift;
    $self->{omit} = shift if @_;
    $self->{omit};
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};
    my $merged = 0;
    return if $self->omit;
    push @$tree, $self;
    $self->merge;
  }

  sub merge {
    my ($self) = @_;
    return;
  }
}


{
  # \A ^ \B \b \G \Z \z $
  package Regexp::Parser::anchor;
  our @ISA = qw( Regexp::Parser::__object__ );
  push @Regexp::Parser::bol::ISA, __PACKAGE__;
  push @Regexp::Parser::bound::ISA, __PACKAGE__;
  push @Regexp::Parser::gpos::ISA, __PACKAGE__;
  push @Regexp::Parser::eol::ISA, __PACKAGE__;

  sub new {
    my ($class, $rx, $type, $vis) = @_;
    Carp::croak("anchor is an abstract class") if $class =~ /::anchor$/;

    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'anchor',
      type => $type,
      vis => $vis,
      zerolen => 1,
    }, $class;
    return $self;
  }
}


{
  # . \C
  package Regexp::Parser::reg_any;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $type, $vis) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'reg_any',
      type => $type,
      vis => $vis,
    }, $class;
    return $self;
  }
}


{
  # \w \W
  package Regexp::Parser::alnum;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $neg) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      neg => $neg,
    }, $class;
    return $self;
  }

  sub neg {
    my $self = shift;
    $self->{neg} = shift if @_;
    $self->{neg};
  }

  sub family { 'alnum' }

  sub type {
    my $self = shift;
    ($self->{neg} ? 'n' : '') . $self->family;
  }

  sub visual {
    my $self = shift;
    $self->{neg} ? '\W' : '\w';
  }
}


{
  # \s \S
  package Regexp::Parser::space;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $neg) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      neg => $neg,
    }, $class;
    return $self;
  }

  sub neg {
    my $self = shift;
    $self->{neg} = shift if @_;
    $self->{neg};
  }

  sub type {
    my $self = shift;
    ($self->{neg} ? 'n' : '') . $self->family;
  }

  sub family { 'space' }

  sub visual {
    my $self = shift;
    $self->{neg} ? '\S' : '\s';
  }
}


{
  # \d \D
  package Regexp::Parser::digit;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $neg) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      neg => $neg,
    }, $class;
    return $self;
  }

  sub neg {
    my $self = shift;
    $self->{neg} = shift if @_;
    $self->{neg};
  }

  sub type {
    my $self = shift;
    ($self->{neg} ? 'n' : '') . $self->family;
  }

  sub family { 'digit' }

  sub visual {
    my $self = shift;
    $self->{neg} ? '\D' : '\d';
  }
}


{
  package Regexp::Parser::anyof;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $neg, @data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'anyof',
      type => 'anyof',
      neg => $neg,
      data => \@data,
      down => 1,
    }, $class;
    return $self;
  }

  sub qr {
    my $self = shift;
    join "", $self->raw, map($_->qr, @{ $self->{data} }), "]";
  }

  sub visual {
    my $self = shift;
    join "", $self->raw, map($_->visual, @{ $self->{data} }), "]";
  }

  sub raw {
    my $self = shift;
    join "", "[", $self->{neg} ? "^" : "";
  }

  sub neg {
    my $self = shift;
    $self->{neg} = shift if @_;
    $self->{neg};
  }

  sub ender {
    my $self = shift;
    [ 'anyof_close' ];
  }

  sub data {
    my $self = shift;
    if (@_) {
      my $how = shift;
      if ($how eq '=') { $self->{data} = \@_ }
      elsif ($how eq '+') { push @{ $self->{data} }, @_ }
      else {
        my $t = $self->type;
        Carp::croak("\$$t->data([+=], \@data)");
      }
    }
    $self->{data};
  }

  sub walk {
    my ($self, $ws, $d) = @_;
    unshift @$ws, $self->{rx}->object(@{ $self->ender });
    unshift @$ws, sub { -1 }, @{ $self->{data} }, sub { +1 } if $d;
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};
    push @$tree, $self;
    push @{ $rx->{stack} }, $tree;
    $rx->{tree} = $self->{data};
  }
}


{
  package Regexp::Parser::anyof_char;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $data, $vis) = @_;
    $vis = $data if not defined $vis;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'anyof_char',
      type => 'anyof_char',
      data => $data,
      vis => $vis,
    }, $class;
  }
}


{
  package Regexp::Parser::anyof_range;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $lhs, $rhs) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'anyof_range',
      type => 'anyof_range',
      data => [$lhs, $rhs],
    }, $class;
  }

  sub qr {
    my $self = shift;
    join "-", $self->{data}[0]->qr, $self->{data}[1]->qr;
  }

  sub visual {
    my $self = shift;
    join "-", $self->{data}[0]->visual, $self->{data}[1]->visual;
  }
}


{
  package Regexp::Parser::anyof_class;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $type, $neg, $how) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'anyof_class',
    }, $class;

    if (ref $type) {
      $self->{data} = $type;
    }
    else {
      $self->{type} = $type;
      $self->{data} = 'POSIX';
      $self->{neg} = $neg;
      $self->{how} = $how;
    }

    return $self;
  }

  sub type {
    my $self = shift;
    if (ref $self->{data}) {
      $self->{data}->type;
    }
    else {
      my $how = ref $self->{how} eq 'SCALAR' ?
	  ${ $self->{how} } :
	  $self->{how};
      join "", $how, ($self->{neg} ? '^' : ''),
               $self->{type}, $how;
    }
  }

  sub neg {
    my $self = shift;
    if (ref $self->{data}) {
      $self->{data}->neg = shift if @_;
      $self->{data}->neg;
    }
    else {
      $self->{neg} = shift if @_;
      $self->{neg};
    }
  }

  sub visual {
    my $self = shift;
    if (ref $self->{data}) {
      $self->{data}->visual;
    }
    else {
      my $how = ref $self->{how} eq 'SCALAR' ?
	  ${ $self->{how} } :
	  $self->{how};
      join "", "[", $how, ($self->{neg} ? '^' : ''),
           $self->{type}, $how, "]";
    }
  }
}


{
  package Regexp::Parser::anyof_close;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'close',
      type => 'anyof_close',
      raw => ']',
      omit => 1,
      up => 1,
    }, $class;
    return $self;
  }

  sub insert {
    my $self = shift;
    my $rx = $self->{rx};
    $rx->{tree} = pop @{ $rx->{stack} };
    return $self;
  }
}


{
  package Regexp::Parser::prop;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $type, $neg) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'prop',
      type => $type,
      data => '',
      neg => ($neg ? 1 : 0),
    }, $class;
    return $self;
  }

  sub type {
    my $self = shift;
    $self->{type};
  }

  sub neg {
    my $self = shift;
    $self->{neg} = shift if @_;
    $self->{neg};
  }

  sub visual {
    my $self = shift;
    sprintf "\\%s{%s}", $self->{neg} ? 'P' : 'p', $self->type;
  }
}


{
  package Regexp::Parser::clump;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $vis) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'clump',
      type => 'clump',
      vis => $vis,
    }, $class;
  }
}


{
  package Regexp::Parser::branch;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      data => [[]],
      family => 'branch',
      type => 'branch',
      raw => '|',
      branch => 1,
    }, $class;
  }

  sub qr {
    my $self = shift;
    join $self->raw, map join("", map $_->qr, @$_), @{ $self->{data} };
  }

  sub visual {
    my $self = shift;
    join $self->raw, map join("", map $_->visual, @$_), @{ $self->{data} };
  }

  sub merge {
    my ($self) = @_;
    my $tree = $self->{rx}{tree};
    return unless @$tree;

    push @$tree, $self unless $tree->[-1] == $self;
    return unless @$tree > 1;
    my $prev = $tree->[-2];
    return unless $prev->type eq $self->type;
    push @{ $prev->{data} }, @{ $self->{data} };
    pop @$tree;
    return 1;
  }

  sub walk {
    my ($self, $ws, $d) = @_;
    if ($d) {
      my $br = $self->{rx}->object($self->type);
      $br->omit(1);
      for (reverse @{ $self->data }) {
        unshift @$ws, $br, sub { -1 }, @$_, sub { +1 };
      }
      shift @$ws;
    }
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};
    my $st = $rx->{stack};

    # this is a branch inside an IFTHEN
    if (@$st and @{ $st->[-1] } and $st->[-1][-1]->type eq 'ifthen') {
      my $ifthen = $st->[-1][-1];
      my $cond = shift @{ $ifthen->{data} };
      $ifthen->{data} = [ [ @{ $ifthen->{data} } ], $cond ];
      $rx->{tree} = $ifthen->{data};
    }

    # if this is the 2nd or 3rd (etc) branch...
    elsif (@$st and @{ $st->[-1] } and $st->[-1][-1]->family eq $self->family) {
      my $br = $st->[-1][-1];
      $br->{data}[-1] = [ @$tree ];
      for (@{ $br->{data}[-1] }) {
        last unless $br->{zerolen} &&= $_->{zerolen};
      }
      push @{ $br->{data} }, [];
      $rx->{tree} = $br->{data}[-1];
    }

    # if this is the first branch
    else {
      $self->{data}[-1] = [ @$tree ];
      push @{ $self->{data} }, [];
      @$tree = $self;
      $tree->[-1]{zerolen} = 1;
      for (@{ $tree->[-1]{data}[0] }) {
        last unless $tree->[-1]{zerolen} &&= $_->{zerolen};
      }
      push @$st, $tree;
      $rx->{tree} = $self->{data}[-1];
    }
  }
}


{
  package Regexp::Parser::exact;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $data, $vis) = @_;
    $vis = $data if not defined $vis;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'exact',
      data => [$data],
      vis => [$vis],
    }, $class;
    return $self;
  }

  sub visual {
    my $self = shift;
    join "", @{ $self->{vis} };
  }

  sub type {
    my $self = shift;
    $self->{flags} & $self->{rx}->FLAG_i ? "exactf" : "exact";
  }

  sub data {
    my $self = shift;
    join "", @{ $self->{data} };
  }

  sub merge {
    my ($self) = @_;
    my $tree = $self->{rx}{tree};
    return unless @$tree;

    push @$tree, $self unless $tree->[-1] == $self;
    return unless @$tree > 1;
    my $prev = $tree->[-2];
    return unless $prev->type eq $self->type;

    push @{ $prev->{data} }, @{ $self->{data} };
    push @{ $prev->{vis} }, @{ $self->{vis} };
    pop @$tree;
    return 1;
  }
}


{
  package Regexp::Parser::quant;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $min, $max, $data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'quant',
      data => $data,
      min => $min,
      max => $max,
    }, $class;
    return $self;
  }

  sub min {
    my $self = shift;
    $self->{min};
  }

  sub max {
    my $self = shift;
    $self->{max};
  }

  sub type {
    my $self = shift;
    my ($min, $max) = ($self->min, $self->max);
    if ($min == 0 and $max eq '') { 'star' }
    elsif ($min == 1 and $max eq '') { 'plus' }
    else { 'curly' }
  }

  sub raw {
    my $self = shift;
    my ($min, $max) = ($self->min, $self->max);
    if ($min == 0 and $max eq '') { '*' }
    elsif ($min == 1 and $max eq '') { '+' }
    elsif ($min == 0 and $max == 1) { '?' }
    elsif ($max ne '' and $min == $max) { "{$min}" }
    else { "{$min,$max}" }
  }

  sub qr {
    my $self = shift;
    join "", $self->{data}->qr, $self->raw;
  }

  sub visual {
    my $self = shift;
    join "", $self->{data}->visual, $self->raw;
  }

  sub data {
    my $self = shift;
    if (@_) {
      my $how = shift;
      if ($how eq '=') { $self->{data} = \@_ }
      elsif ($how eq '+') { push @{ $self->{data} }, @_ }
      else {
        my $t = $self->type;
        Carp::croak("\$$t->data([+=], \@data)");
      }
    }
    $self->{data};
  }

  sub walk {
    my ($self, $ws, $d) = @_;
    unshift @$ws, sub { -1 }, $self->{data}, sub { +1 } if $d;
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};

    # quantifiers must follow something
    $rx->error($rx->RPe_EQUANT)
      if @$tree == 0 or $tree->[-1]->family eq "flags";

    # quantifiers must NOT follow quantifiers
    $rx->error($rx->RPe_NESTED)
      if $tree->[-1]->family eq "quant";

    # on /abc+/, we extract the 'c' from the 'exact' node
    if ($tree->[-1]->family eq "exact" and @{ $tree->[-1]->{data} } > 1) {
      my $d = pop @{ $tree->[-1]->{data} };
      my $v = pop @{ $tree->[-1]->{vis} };
      my $q = $rx->object(exact => $d, $v);
      $q->{flags} = $tree->[-1]->{flags};
      $self->{data} = $q;
      push @$tree, $self;
    }
    else {
      # quantifier on (?{ ... }) is pointless;
      # bounded quantifier (but not ?) on a
      # zero-width assertion is unexpected
      if (
        ($tree->[-1]->family eq "assertion" and $tree->[-1]->type eq "eval") or
        ($tree->[-1]->{zerolen} and !($self->{min} == 0 and $self->{max} == 1))
      ) {
        $rx->awarn($rx->RPe_ZQUANT);
      }

      # unbounded quantifier on a zero-width
      # assertion can match a null string a lot
      elsif ($tree->[-1]->{zerolen} and $self->{max} eq '') {
        $rx->awarn($rx->RPe_NULNUL, $tree->[-1]->visual . $self->raw);
      }

      $self->{data} = $tree->[-1];
      $tree->[-1] = $self;
    }
  }
}


{
  # ( non-capturing
  package Regexp::Parser::group;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $on, $off, @data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'group',
      type => 'group',
      data => \@data,
      on => $on,
      off => $off,
      down => 1,
    }, $class;
  }

  sub on {
    my $self = shift;
    $self->{on};
  }

  sub off {
    my $self = shift;
    $self->{off};
  }

  sub raw {
    my $self = shift;
    if ($self->{on} =~ /^\^/) {
      return join "", "(?", $self->{on}, ":";
    }
    join "", "(?", $self->{on},
      (length $self->{off} ? "-" : ""), $self->{off}, ":";
  }

  sub qr {
    my $self = shift;
    join "", $self->raw, map($_->qr, @{ $self->{data} }), ")";
  }

  sub visual {
    my $self = shift;
    join "", $self->raw, map($_->visual, @{ $self->{data} }), ")";
  }

  sub data {
    my $self = shift;
    if (@_) {
      my $how = shift;
      if ($how eq '=') { $self->{data} = \@_ }
      elsif ($how eq '+') { push @{ $self->{data} }, @_ }
      else {
        my $t = $self->type;
        Carp::croak("\$$t->data([+=], \@data)");
      }
    }
    $self->{data};
  }

  sub walk {
    my ($self, $ws, $d) = @_;
    unshift @$ws, $self->{rx}->object(@{ $self->ender });
    unshift @$ws, sub { -1 }, @{ $self->{data} }, sub { +1 } if $d;
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};
    push @$tree, $self;
    push @{ $rx->{stack} }, $tree;
    $rx->{tree} = $self->{data};
  }
}


{
  # ( capturing
  package Regexp::Parser::open;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $nparen, @data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'open',
      nparen => $nparen,
      data => \@data,
      raw => '(',
      down => 1,
    }, $class;
    $self->{rx}{captures}[$nparen - 1] = $self;
    return $self;
  }

  sub type {
    my $self = shift;
    $self->family . $self->nparen;
  }

  sub nparen {
    my $self = shift;
    $self->{nparen};
  }

  sub qr {
    my $self = shift;
    join "", $self->raw, map($_->qr, @{ $self->{data} }), ")";
  }

  sub visual {
    my $self = shift;
    join "", $self->raw, map($_->visual, @{ $self->{data} }), ")";
  }

  sub ender {
    my $self = shift;
    [ close => $self->nparen ];
  }

  sub data {
    my $self = shift;
    if (@_) {
      my $how = shift;
      if ($how eq '=') { $self->{data} = \@_ }
      elsif ($how eq '+') { push @{ $self->{data} }, @_ }
      else {
        my $t = $self->type;
        Carp::croak("\$$t->data([+=], \@data)");
      }
    }
    $self->{data};
  }

  sub walk {
    my ($self, $ws, $d) = @_;
    unshift @$ws, $self->{rx}->object(@{ $self->ender });
    unshift @$ws, sub { -1 }, @{ $self->{data} }, sub { +1 } if $d;
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};
    push @$tree, $self;
    push @{ $rx->{stack} }, $tree;
    $rx->{tree} = $self->{data};
  }
}


{
  # ) closing
  package Regexp::Parser::close;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $nparen) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'close',
      nparen => $nparen,
      raw => ')',
      omit => 1,
      up => 1,
    }, $class;
    return $self;
  }

  sub type {
    my $self = shift;
    $self->family . $self->nparen;
  }

  sub nparen {
    my $self = shift;
    $self->{nparen};
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};

    do {
      $tree = pop @{ $rx->{stack} }
        or $rx->error($rx->RPe_RPAREN)
    } until $tree->[-1]->{down};

    $rx->{tree} = $tree;

    $self->{nparen} = $tree->[-1]->nparen
      if $self->family eq 'close' and $tree->[-1]->can('nparen');

    if ($tree->[-1]->{ifthen}) {
      my $ifthen = $tree->[-1];
      my $br = $rx->object(branch =>);
      my $cond;

      if (ref $ifthen->{data}[0] eq "ARRAY") {
        (my($true), $cond) = splice @{ $ifthen->{data} }, 0, 2;
        $br->{data} = [ $true, $ifthen->{data} ];
      }
      else {
        $cond = shift @{ $ifthen->{data} };
        $br->{data} = [ $ifthen->{data} ];
      }

      $ifthen->{data} = [ $cond, $br ];
      $ifthen->{zerolen} =
        !grep !(grep $_->{zerolen}, @$_), @{ $ifthen->{data}[1]{data} };
    }
    else {
      $tree->[-1]->{zerolen} ||=
        !grep !$_->{zerolen}, @{ $tree->[-1]->{data} };
    }

    push @$tree, $self unless $self->omit;
  }
}


{
  # ) for non-captures
  package Regexp::Parser::tail;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'close',
      type => 'tail',
      raw => ')',
      omit => 1,
      up => 1,
    }, $class;
    return $self;
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};

    do {
      $rx->{tree} = pop @{ $rx->{stack} }
        or $rx->error($rx->RPe_RPAREN)
    } until $tree->[-1]->{down};

    $self->{nparen} = $tree->[-1]->nparen
      if $self->family eq 'close' and $tree->[-1]->can('nparen');

    if ($tree->[-1]->{ifthen}) {
      my $ifthen = $tree->[-1];
      my $br = $rx->object(branch =>);
      my $cond;

      if (ref $ifthen->{data}[0] eq "ARRAY") {
        (my($true), $cond) = splice @{ $ifthen->{data} }, 0, 2;
        $br->{data} = [ $true, $ifthen->{data} ];
      }
      else {
        $cond = shift @{ $ifthen->{data} };
        $br->{data} = [ $ifthen->{data} ];
      }

      $ifthen->{data} = [ $cond, $br ];
      $ifthen->{zerolen} =
        !grep !(grep $_->{zerolen}, @$_), @{ $ifthen->{data}[1]{data} };
    }
    else {
      $tree->[-1]->{zerolen} ||=
        !grep !$_->{zerolen}, @{ $tree->[-1]->{data} };
    }

    push @$tree, $self unless $self->omit;
  }
}


{
  # \1 (backrefs)
  package Regexp::Parser::ref;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $nparen, $vis) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'ref',
      nparen => $nparen,
      ($vis ? (vis => $vis) : ()),
    }, $class;
    return $self;
  }

  sub type {
    my $self = shift;
    ($self->{flags} & $self->{rx}->FLAG_i ? 'reff' : 'ref') . $self->nparen;
  }

  sub nparen {
    my $self = shift;
    $self->{nparen};
  }

  sub visual {
    my $self = shift;
    exists $self->{vis} ? $self->{vis} : "\\$self->{nparen}";
  }

  sub qr {
    my $self = shift;
    # Always emit \N format for qr() regardless of visual form
    "\\$self->{nparen}";
  }
}


{
  # \g{name} named backreference (Perl 5.10+)
  package Regexp::Parser::gref;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $name, $vis) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'ref',
      type => 'gref',
      name => $name,
      vis => $vis,
    }, $class;
    return $self;
  }

  sub name {
    my $self = shift;
    $self->{name};
  }

  sub visual {
    my $self = shift;
    $self->{vis};
  }

  sub qr {
    my $self = shift;
    "\\g{$self->{name}}";
  }
}


{
  package Regexp::Parser::assertion;
  our @ISA = qw( Regexp::Parser::__object__ );

  push @Regexp::Parser::ifmatch::ISA, __PACKAGE__;
  push @Regexp::Parser::unlessm::ISA, __PACKAGE__;
  push @Regexp::Parser::suspend::ISA, __PACKAGE__;
  push @Regexp::Parser::ifthen::ISA, __PACKAGE__;
  push @Regexp::Parser::eval::ISA, __PACKAGE__;
  push @Regexp::Parser::logical::ISA, __PACKAGE__;

  sub qr {
    my $self = shift;
    join "", $self->raw, map($_->qr, @{ $self->{data} }), ")";
  }

  sub visual {
    my $self = shift;
    join "", $self->raw, map($_->visual, @{ $self->{data} }), ")";
  }

  sub data {
    my $self = shift;
    if (@_) {
      my $how = shift;
      if ($how eq '=') { $self->{data} = \@_ }
      elsif ($how eq '+') { push @{ $self->{data} }, @_ }
      else {
        my $t = $self->type;
        Carp::croak("\$$t->data([+=], \@data)");
      }
    }
    $self->{data};
  }

  sub walk {
    my ($self, $ws, $d) = @_;
    unshift @$ws, $self->{rx}->object(@{ $self->ender });
    unshift @$ws, sub { -1 }, @{ $self->{data} }, sub { +1 } if $d;
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};
    push @$tree, $self;
    push @{ $rx->{stack} }, $tree;
    $rx->{tree} = $self->{data};
  }
}


{
  # (?=) (?<=)
  package Regexp::Parser::ifmatch;

  sub new {
    my ($class, $rx, $dir, @data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'assertion',
      type => 'ifmatch',
      dir => $dir,
      data => \@data,
      down => 1,
      zerolen => 1,
    }, $class;
    return $self;
  }

  sub dir {
    my $self = shift;
    $self->{dir};
  }

  sub raw {
    my $self = shift;
    join "", "(?", ($self->{dir} < 0 ? '<' : ''), "=";
  }
}


{
  # (?!) (?
  package Regexp::Parser::unlessm;

  sub new {
    my ($class, $rx, $dir, @data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'assertion',
      type => 'unlessm',
      dir => $dir,
      data => \@data,
      down => 1,
      zerolen => 1,
    }, $class;
    return $self;
  }

  sub dir {
    my $self = shift;
    $self->{dir};
  }

  sub raw {
    my $self = shift;
    join "", "(?", ($self->{dir} < 0 ? '<' : ''), "!";
  }
}


{
  # (?>)
  package Regexp::Parser::suspend;

  sub new {
    my ($class, $rx, @data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'assertion',
      type => 'suspend',
      data => \@data,
      down => 1,
    }, $class;
    return $self;
  }

  sub raw {
    my $self = shift;
    "(?>";
  }
}

{
  # (?(n)t|f)
  package Regexp::Parser::ifthen;

  sub new {
    my ($class, $rx, @data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'assertion',
      type => 'ifthen',
      data => [],
      down => 1,
      ifthen => 1,
    }, $class;
    return $self;
  }

  sub raw {
    my $self = shift;
    "(?";
  }

  sub qr {
    my $self = shift;
    join "", $self->raw, $self->{data}[0]->qr, $self->{data}[1]->qr, ")";
  }

  sub visual {
    my $self = shift;
    join "", $self->raw, $self->{data}[0]->visual, $self->{data}[1]->visual, ")";
  }
}


{
  # the N in (?(N)t|f) when N is a number
  package Regexp::Parser::groupp;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $nparen) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'groupp',
      nparen => $nparen,
    }, $class;
    return $self;
  }

  sub type {
    my $self = shift;
    $self->family . $self->nparen;
  }

  sub nparen {
    my $self = shift;
    $self->{nparen};
  }

  sub visual {
    my $self = shift;
    "($self->{nparen})";
  }
}


{
  # (?{ ... })
  package Regexp::Parser::eval;

  sub new {
    my ($class, $rx, $code) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'assertion',
      type => 'eval',
      data => $code,
      zerolen => 1,
    }, $class;
    return $self;
  }

  sub visual {
    my $self = shift;
    "(?{$self->{data}})";
  }

  sub qr {
    my $self = shift;
    $self->visual;
  }

  sub insert {
    my ($self, $tree) = @_;
    push @$tree, $self;
  }

  sub walk {
    my $self = shift;
    return;
  }
}


{
  # (??{ ... })
  package Regexp::Parser::logical;

  sub new {
    my ($class, $rx, $code) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'assertion',
      type => 'logical',
      data => $code,
      zerolen => 1,
    }, $class;
    return $self;
  }

  sub visual {
    my $self = shift;
    "(??{$self->{data}})";
  }

  sub qr {
    my $self = shift;
    $self->visual;
  }

  sub insert {
    my ($self, $tree) = @_;
    push @$tree, $self;
  }

  sub walk {
    my $self = shift;
    return;
  }
}


{
  package Regexp::Parser::flags;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $on, $off) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'flags',
      type => 'flags',
      on => $on,
      off => $off,
      zerolen => 1,
    }, $class;
    return $self;
  }

  sub on {
    my $self = shift;
    $self->{on};
  }

  sub off {
    my $self = shift;
    $self->{off};
  }

  sub visual {
    my $self = shift;
    if ($self->{on} =~ /^\^/) {
      return join "", "(?", $self->{on}, ")";
    }
    join "", "(?", $self->{on},
      (length $self->{off} ? "-" : ""), $self->{off}, ")";
  }
}


{
  package Regexp::Parser::minmod;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'minmod',
      type => 'minmod',
      raw => '?',
      data => $data,
    }, $class;
    return $self;
  }

  sub qr {
    my $self = shift;
    join "", $self->{data}->qr, $self->raw;
  }

  sub visual {
    my $self = shift;
    join "", $self->{data}->visual, $self->raw;
  }

  sub walk {
    my ($self, $ws, $d) = @_;
    unshift @$ws, sub { -1 }, $self->{data}, sub { +1 } if $d;
  }

  sub insert {
    my ($self, $tree) = @_;
    $self->{data} = $tree->[-1];
    $tree->[-1] = $self;
  }
}


{
  # \K (keep, zero-width assertion added in Perl 5.10)
  package Regexp::Parser::keep;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'anchor',
      type => 'keep',
      vis => '\K',
      zerolen => 1,
    }, $class;
    return $self;
  }
}


{
  # \h \H (horizontal whitespace, added in Perl 5.10)
  package Regexp::Parser::hspace;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $neg) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      neg => $neg,
    }, $class;
    return $self;
  }

  sub neg {
    my $self = shift;
    $self->{neg} = shift if @_;
    $self->{neg};
  }

  sub type {
    my $self = shift;
    ($self->{neg} ? 'n' : '') . $self->family;
  }

  sub family { 'hspace' }

  sub visual {
    my $self = shift;
    $self->{neg} ? '\H' : '\h';
  }
}


{
  # \v \V (vertical whitespace, added in Perl 5.10)
  package Regexp::Parser::vspace;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $neg) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      neg => $neg,
    }, $class;
    return $self;
  }

  sub neg {
    my $self = shift;
    $self->{neg} = shift if @_;
    $self->{neg};
  }

  sub type {
    my $self = shift;
    ($self->{neg} ? 'n' : '') . $self->family;
  }

  sub family { 'vspace' }

  sub visual {
    my $self = shift;
    $self->{neg} ? '\V' : '\v';
  }
}


{
  # \R (generic linebreak, added in Perl 5.10)
  package Regexp::Parser::lnbreak;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'lnbreak',
      type => 'lnbreak',
      vis => '\R',
    }, $class;
    return $self;
  }
}


{
  # (?...) named capture group (added in Perl 5.10)
  package Regexp::Parser::named_open;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $nparen, $name, @data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'open',
      nparen => $nparen,
      name => $name,
      data => \@data,
      raw => "(?<$name>",
      down => 1,
    }, $class;
    $self->{rx}{captures}[$nparen - 1] = $self;
    return $self;
  }

  sub type {
    my $self = shift;
    'open' . $self->nparen;
  }

  sub nparen {
    my $self = shift;
    $self->{nparen};
  }

  sub name {
    my $self = shift;
    $self->{name};
  }

  sub qr {
    my $self = shift;
    join "", $self->raw, map($_->qr, @{ $self->{data} }), ")";
  }

  sub visual {
    my $self = shift;
    join "", $self->raw, map($_->visual, @{ $self->{data} }), ")";
  }

  sub ender {
    my $self = shift;
    [ close => $self->nparen ];
  }

  sub data {
    my $self = shift;
    if (@_) {
      my $how = shift;
      if ($how eq '=') { $self->{data} = \@_ }
      elsif ($how eq '+') { push @{ $self->{data} }, @_ }
      else {
        my $t = $self->type;
        Carp::croak("\$$t->data([+=], \@data)");
      }
    }
    $self->{data};
  }

  sub walk {
    my ($self, $ws, $d) = @_;
    unshift @$ws, $self->{rx}->object(@{ $self->ender });
    unshift @$ws, sub { -1 }, @{ $self->{data} }, sub { +1 } if $d;
  }

  sub insert {
    my ($self, $tree) = @_;
    my $rx = $self->{rx};
    push @$tree, $self;
    push @{ $rx->{stack} }, $tree;
    $rx->{tree} = $self->{data};
  }
}


{
  # \k named backreference (added in Perl 5.10)
  package Regexp::Parser::named_ref;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $name, $vis) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'ref',
      name => $name,
      vis => $vis,
    }, $class;
    return $self;
  }

  sub type {
    my $self = shift;
    ($self->{flags} & $self->{rx}->FLAG_i ? 'named_reff' : 'named_ref');
  }

  sub name {
    my $self = shift;
    $self->{name};
  }

  sub visual {
    my $self = shift;
    $self->{vis};
  }
}


{
  # possessive quantifier modifier (added in Perl 5.10)
  package Regexp::Parser::possessive;
  our @ISA = qw( Regexp::Parser::__object__ );

  sub new {
    my ($class, $rx, $data) = @_;
    my $self = bless {
      rx => $rx,
      flags => $rx->{flags}[-1],
      family => 'possessive',
      type => 'possessive',
      raw => '+',
      data => $data,
    }, $class;
    return $self;
  }

  sub qr {
    my $self = shift;
    join "", $self->{data}->qr, $self->raw;
  }

  sub visual {
    my $self = shift;
    join "", $self->{data}->visual, $self->raw;
  }

  sub walk {
    my ($self, $ws, $d) = @_;
    unshift @$ws, sub { -1 }, $self->{data}, sub { +1 } if $d;
  }

  sub insert {
    my ($self, $tree) = @_;
    $self->{data} = $tree->[-1];
    $tree->[-1] = $self;
  }
}


1;

__END__