File Coverage

blib/lib/Regexp/Assemble/Compressed.pm

Criterion	Covered	Total	%
statement	60	61	98.3
branch	28	32	87.5
condition	25	30	83.3
subroutine	5	5	100.0
pod	1	1	100.0
total	119	129	92.2

package Regexp::Assemble::Compressed;

use strict;
use warnings;
our $VERSION = '0.02';
use base qw(Regexp::Assemble);

# Note: maybe handle \U,\L more smartly
our $char = qr/
    (?:\\u|\\l|)                                 # \u, \l acts on one char or char group
    (?:
          \\Q.+?\\E                              # capture \Q..\E completely
        | \[:[^:]+:\]                            # posix char class
        | \\[UL].+?(?:\\E|\Z)                    # capture \U..\E and \L..\E completely
        | \\x(?:\{[\dA-Fa-f]+\}|[\dA-Fa-f]{1,2}) # \x.. or \x{...}
        | \\\d{1,3}                              # \000 - octal
        | \\N\{[^{]+\}                           # unicode char
        | \\[pP]\{[^{]+\}                        # unicode character class
        | \\c.                                   # control char \cX
        | \\.                                    # \t \n \s ...
        | .                                      # any char
     )
/xo;

sub as_string {
    my $self = shift;
    my $string = $self->SUPER::as_string;
    $string =~ s{(?
    return $string;
}

sub _compress {
    my $string = shift;
    my @characters = sort $string =~ m{ ( $char\-$char | $char ) }sgx;
    #warn "[ ".join('|', @characters)." ]";
    my @stack = ();
    my @skipped = ();
    my $last;
    for my $char (@characters) {
        if ( length($char) == 1 ) {
            my $num = ord $char;
            if (defined $last and $num - $last == 0) { next }
            if (defined $last and @skipped and $num >= ord $skipped[0] and $num <= ord $skipped[-1]) { next }
            if (defined $last and $num - $last == 1) {
                push @skipped, $char;
                $last = $num;
                next;
            }
            elsif (@skipped) {
                push @stack, @skipped < 2 ? @skipped : ('-', $skipped[-1]);
                @skipped = ();
            }
            push @stack, $char;
            $last = $num;
        }
        elsif (length $char == 3 and $char =~ /^([^\\])-([^\\])$/) {
            my ($beg,$end) = ($1,$2);
            my $num = ord $beg;
            my $enn = ord $end;
            if (defined $last and @skipped and $num + 1 >= ord $skipped[0] and $num <= ord $skipped[-1]) {
                if ($enn <= ord $skipped[-1]) { next }
                else {
                    my $next = $skipped[-1];
                    ++$next;
                    push @skipped, $next..$end;
                    $last = $enn;
                    next;
                }
            }
            if (defined $last and $num - $last == 1) {
                push @skipped, $beg..$end;
                $last = $enn;
                next;
            }
            elsif (@skipped) {
                push @stack, @skipped < 2 ? @skipped : ('-', $skipped[-1]);
                @skipped = ();
            }
            push @stack, $beg;
            push @skipped, ++$beg..$end;
            $last = $enn;
        }
        else {
            if (@skipped) {
                push @stack, @skipped < 2 ? @skipped : ('-', $skipped[-1]);
                @skipped = ();
            }
            push @stack, $char;
        }
    }
    if (@skipped) {
        push @stack, @skipped < 2 ? @skipped : ('-', $skipped[-1]);
    }
    return join '', @stack;
}

1;
__END__