File Coverage

blib/lib/FLAT/Regex/WithExtraOps.pm

Criterion	Covered	Total	%
statement	33	63	52.3
branch	0	4	0.0
condition			n/a
subroutine	14	28	50.0
pod	1	2	50.0
total	48	97	49.4

package FLAT::Regex::WithExtraOps;
use parent 'FLAT::Regex';

use strict;
use Carp;

#### Precedence
# 30 ::star
# 20 ::concat
# 15 ::negate   <---<< WithExtraOps
# 12 ::shuffle  <---<< WithExtraOps
# 10 ::alt
# 0  ::atomic

my $PARSER = FLAT::Regex::Parser->new(qw[ alt concat star negate shuffle ]);
sub _parser {$PARSER}

sub negate {
    my $self = $_[0];
    my $op = FLAT::Regex::Op::negate->new(map {$_->as_regex->op} @_);
    $self->_from_op($op);
}

###############################
sub shuffle {
    my $self = $_[0];
    my $op = FLAT::Regex::Op::shuffle->new(map {$_->as_regex->op} @_);
    $self->_from_op($op);
}

package FLAT::Regex::Op::negate;
use parent "FLAT::Regex::Op";
use Carp;

sub parse_spec {"'~' %s";}
sub precedence {15}          # between concat and alternation

sub as_string {
    my ($self, $prec) = @_;
    my $result = "~" . $self->members->as_string($self->precedence);
    return $prec > $self->precedence ? "($result)" : $result;
}

sub from_parse {
    my ($pkg, @item) = @_;
    $pkg->new($item[2]);
}

## note: "reverse" conflicts with perl builtin
sub reverse {
    my $self = shift;
    my $op   = $self->members->reverse;
    __PACKAGE__->new($op);
}

sub is_empty {
    croak "Not implemented for negated regexes";
}

sub has_nonempty_string {
    croak "Not implemented for negated regexes";
}

sub is_finite {
    croak "Not implemented for negated regexes";
}

###############################
package FLAT::Regex::Op::shuffle;
use parent 'FLAT::Regex::Op';
use Carp;

sub parse_spec {"%s(2.. /[&]/)"}
sub precedence {12}

sub as_string {
    my ($self, $prec) = @_;
    my $result = join "&", map {$_->as_string($self->precedence)} $self->members;
    return $prec > $self->precedence ? "($result)" : $result;
}

sub as_perl_regex {
    my $self = shift;
    croak "Not implemented for shuffled regexes";
}

sub from_parse {
    my ($pkg, @item) = @_;
    $pkg->new(@{$item[1]});
}

sub as_pfa {
    my $self = shift;
    my @parts = map {$_->as_pfa} $self->members;
    $parts[0]->shuffle(@parts[1 .. $#parts]);
}

# Implement?
sub reverse {
    my $self = shift;
    croak "Not implemented for shuffled regexes";
}

sub is_empty {
    croak "Not implemented for shuffled regexes";
}

sub has_nonempty_string {
    croak "Not implemented for shuffled regexes";
}

sub is_finite {
    croak "Not implemented for shuffled regexes";
}