File Coverage

blib/lib/Regexp/Parser.pm

Criterion	Covered	Total	%
statement	201	225	89.3
branch	59	78	75.6
condition	14	20	70.0
subroutine	45	53	84.9
pod	2	32	6.2
total	321	408	78.6

package Regexp::Parser;

use strict;
use warnings;

our $VERSION = '0.26';

use 5.006;
use Carp qw( carp croak );
use base 'Exporter';
use strict;
use warnings;
use charnames ();

our %loaded;
our @EXPORT = qw( Rx RxPOS RxCUR RxLEN Rf SIZE_ONLY LATEST );

sub Rx :lvalue		{ $_[0]{regex} }
sub RxPOS :lvalue	{ pos ${&Rx} }
sub RxCUR		{ substr ${&Rx}, &RxPOS }
sub RxLEN		{ $_[0]{len} }

sub Rf :lvalue		{ $_[0]{flags}[-1] }

sub SIZE_ONLY		{ ! $_[0]{tree} }
sub LATEST :lvalue	{ $_[0]{tree}[-1] }

use Regexp::Parser::Diagnostics;
use Regexp::Parser::Objects;
use Regexp::Parser::Handlers;


# this handles 'use base "Regexp::Parser"'
# which wouldn't call 'import'
{
  my ($level, $prev, $pkg);
  while (my ($curr) = caller $level++) {
    $pkg = $curr, last if $prev and $prev eq "base" and $curr ne "base";
    $prev = $curr;
  }
  Regexp::Parser->export_to_level($level, $pkg, @EXPORT) if $pkg;
}


sub new {
  my ($class, $rx) = @_;
  my $self = bless {}, $class;
  $self->init;
  $self->regex($rx) if defined $rx;
  return $self;
}


sub regex {
  my ($self, $rx, $flags) = @_;
  my $init_flags = 0;
  if (defined $flags) {
    for my $ch (split //, $flags) {
      my $method = "FLAG_$ch";
      if ($self->can($method)) {
        my $v = $self->$method;
        # /xx: if x is already on, set the xx bit (Perl 5.26+)
        if ($ch eq 'x' && ($init_flags & $v)) {
          $init_flags |= 0x200;
        }
        $init_flags |= $v;
      }
    }
  }
  %$self = (
    regex => \"$rx",
    len => length $rx,
    tree => undef,
    stack => [],
    maxpar => 0,
    nparen => 0,
    captures => [],
    named_captures => {},
    flags => [$init_flags],
    next => ['atom'],
    quotemeta => 0,
  );

  # do the initial scan (populates maxpar)
  # because tree is undef, nothing gets built
  &RxPOS = 0;
  eval { $self->parse };
  $self->{errmsg} = $@, return if $@;

  # reset things, define tree as []
  &RxPOS = 0;
  $self->{tree} = [];
  $self->{flags} = [$init_flags];
  $self->{next} = ['atom'];
  $self->{quotemeta} = 0;

  return 1;
}


sub parse {
  my ($self, $rx) = @_;
  $self->regex($rx) or return if defined $rx;
  croak "no regex defined" unless &RxLEN;
  1 while $self->next;
  return 1;
}


sub root {
  my ($self) = @_;
  $self->parse if $self->{stack};
  return $self->{tree};
}


sub nparen {
  my ($self) = @_;
  $self->parse if $self->{stack};
  return $self->{nparen};
}


sub captures {
  my ($self, $n) = @_;
  $self->parse if $self->{stack};
  return $self->{captures}[--$n] if $n;
  return $self->{captures};
}


sub named_captures {
  my ($self, $name) = @_;
  $self->parse if $self->{stack};
  return $self->{named_captures}{$name} if $name;
  return $self->{named_captures};
}


sub nchar {
  my $self = shift;
  return map chr(/^\^(\S)/ ? (64 ^ ord $1) : charnames::vianame($_)), @_;
}


sub error_is {
  my ($self, $enum) = @_;
  return $self->{errnum} && $self->{errnum} == $enum;
}


sub errmsg {
  my ($self) = @_;
  return $self->{errmsg};
}


sub errnum {
  my ($self) = @_;
  return $self->{errnum};
}


sub error {
  my ($self, $enum, $err, @args) = @_;
  $err .= "; marked by <-- HERE in m/%s <-- HERE %s/";
  push @args, substr(${&Rx}, 0, &RxPOS), &RxCUR;
  $self->{errnum} = $enum;
  $self->{errmsg} = sprintf $err, @args;
  croak $self->{errmsg};
}


sub warn {
  my ($self, $enum, $err, @args) = @_;
  $err .= "; marked by <-- HERE in m/%s <-- HERE %s/";
  push @args, substr(${&Rx}, 0, &RxPOS), &RxCUR;
  carp sprintf $err, @args if &SIZE_ONLY;
}


sub awarn {
  my ($self, $enum, $err, @args) = @_;
  local $self->{tree};
  $self->warn($enum, $err, @args);
}


sub next {
  my ($self) = @_;
  croak "no regex defined" unless &RxLEN;

  while (my $try = pop @{ $self->{next} }) {
    if (defined(my $r = $self->$try)) {
      $r->insert($self->{tree});
      return $r;
    }
  }

  $self->error(RPe_RPAREN) if ${&Rx} =~ m{ \G \) }xgc;
  $self->error(0, "PANIC! %d %s", &RxPOS, &RxCUR) if &RxPOS != &RxLEN;

  if (! &SIZE_ONLY) {
    $self->{tree} = pop @{ $self->{stack} } while @{ $self->{stack} };
    delete $self->{stack};
  }

  return;
}


sub walker {
  my ($self, $depth) = @_;
  croak "no regex defined" unless &RxLEN;
  $self->parse if $self->{stack};

  $depth = -1 unless defined $depth;
  my $d = $depth;
  my @stack = @{ $self->{tree} };
  my $next;

  return sub {
    return $depth if @_ and $_[0] eq -depth;
    carp "unexpected argument ($_[0]) to iterator" if @_;

    {
      $next = shift @stack;
      $d += $next->(), redo if ref($next) eq "CODE";
    }

    @stack = @{ $self->{tree} }, return unless $next;
    $next->walk(\@stack, $d);
    return wantarray ? ($next, $depth-$d) : $next;
  }
}


sub visual {
  my ($self) = @_;
  $self->parse if $self->{stack};
  my $vis = join "", map($_->visual, @{ $self->{tree} });
  return $vis;
}


sub qr {
  my ($self) = @_;
  $self->parse if $self->{stack};
  my $rx = $self->{tree};
  no warnings 'regexp';
  use re 'eval';

  if (@$rx == 1 and $rx->[0]->family eq 'group') {
    my $vis = join "", map $_->qr, @{ $rx->[0]->{data} };
    my $flags = $rx->[0]->on;
    $flags =~ s/^\^//;  # strip caret prefix for qr// modifier
    return eval('qr/$vis/' . $flags);
  }

  $rx = join "", map($_->qr, @$rx);
  return qr/$rx/;
}


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

  {
    if (${&Rx} =~ m{ \G \(\?\# [^)]* }xgc) {
      ${&Rx} =~ m{ \G \) }xgc and redo;
      $self->error(RPe_NOTERM);
    }
    &Rf & $self->FLAG_x and ${&Rx} =~ m{ \G (?: \s+ | \# .* )+ }xgc and redo;
  }
}


sub object {
  return if &SIZE_ONLY;
  my $self = shift;
  $self->force_object(@_);
}


sub force_object {
  Carp::croak("class name passed where object required") unless ref $_[0];
  my $type = splice @_, 1, 1;
  my $ref = ref $_[0];
  my $class = "${ref}::$type";

  if ($ref ne __PACKAGE__ and !$loaded{$class}++) {
    no strict 'refs';
    my $orig_base = $Regexp::Parser::{$type . '::'};
    my $user_base = ${"${ref}::"}{'__object__::'};

    push @{ "${class}::ISA" }, $ref . "::__object__" if $user_base;
    push @{ "${class}::ISA" }, __PACKAGE__ . "::$type" if $orig_base;
  }

  return $class->new(@_);
}


sub add_flag {
  my ($self, $seq, $func) = @_;
  no strict 'refs';
  no warnings 'redefine';
  *{ ref($self) . "::FLAG_$seq" } = $func;
}


sub del_flag {
  my ($self, @flags) = @_;
  no strict 'refs';
  my $stash = \%{ ref($self) . "::" };
  undef $stash->{"FLAG_$_"} for @flags;
}


sub add_handler {
  my ($self, $seq, $func) = @_;
  no strict 'refs';
  no warnings 'redefine';
  *{ ref($self) . "::$seq" } = $func;
}


sub del_handler {
  my ($self, @handles) = @_;
  no strict 'refs';
  my $stash = \%{ ref($self) . "::" };
  undef $stash->{$_} for @handles;
}


1;

__END__