File Coverage

blib/lib/Regexp/Common/balanced.pm

Criterion	Covered	Total	%
statement	44	44	100.0
branch	8	8	100.0
condition			n/a
subroutine	6	6	100.0
pod	0	1	0.0
total	58	59	98.3

package Regexp::Common::balanced; {

use 5.10.0;

use strict;
use warnings;
no  warnings 'syntax';

use Regexp::Common qw /pattern clean no_defaults/;

our $VERSION = '2016060801';

my %closer = ( '{'=>'}', '('=>')', '['=>']', '<'=>'>' );
my %cache;

sub nested {
    my ($start, $finish) = @_;

    return $cache {$start} {$finish} if exists $cache {$start} {$finish};

    my @starts   = map {s/\\(.)/$1/g; $_} grep {length}
                        $start  =~ /([^|\\]+|\\.)+/gs;
    my @finishes = map {s/\\(.)/$1/g; $_} grep {length}
                        $finish =~ /([^|\\]+|\\.)+/gs;

    push @finishes => ($finishes [-1]) x (@starts - @finishes);

    my @re;
    local $" = "|";
    foreach my $begin (@starts) {
        my $end = shift @finishes;

        my $qb  = quotemeta $begin;
        my $qe  = quotemeta $end;
        my $fb  = quotemeta substr $begin => 0, 1;
        my $fe  = quotemeta substr $end   => 0, 1;

        my $tb  = quotemeta substr $begin => 1;
        my $te  = quotemeta substr $end   => 1;

        my $add;
        if ($fb eq $fe) {
            push @re =>
                   qq /(?:$qb(?:(?>[^$fb]+)|$fb(?!$tb)(?!$te)|(?-1))*$qe)/;
        }
        else {
            my   @clauses =  "(?>[^$fb$fe]+)";
            push @clauses => "$fb(?!$tb)" if length $tb;
            push @clauses => "$fe(?!$te)" if length $te;
            push @clauses => "(?-1)";
            push @re      =>  qq /(?:$qb(?:@clauses)*$qe)/;
        }
    }

    $cache {$start} {$finish} = qr /(@re)/;
}


pattern name    => [qw /balanced -parens=() -begin= -end=/],
        create  => sub {
            my $flag = $_[1];
            unless (defined $flag -> {-begin} && length $flag -> {-begin} &&
                    defined $flag -> {-end}   && length $flag -> {-end}) {
                my @open  = grep {index ($flag->{-parens}, $_) >= 0}
                             ('[','(','{','<');
                my @close = map {$closer {$_}} @open;
                $flag -> {-begin} = join "|" => @open;
                $flag -> {-end}   = join "|" => @close;
            }
            return nested @$flag {qw /-begin -end/};
        },
        ;

}

1;

__END__