package Regexp::ClassCompact;

our $VERSION = 0.02;

use re qw(eval);

require Exporter;
our @ISA    = qw(Exporter);
our @EXPORT = qw(compact_regex_classes);

my $open_delim  = '[';
my $close_delim = ']';

my $paren_rx;

$paren_rx = qr{
  \Q$open_delim\E
  (
      (??{ $paren_rx })                                 # either match another paren-set (requires re 'eval')
    | (?> [^\\\Q$open_delim$close_delim\E]+ | \\. )+    # or match non-parens (or escaped parens)
  )*
  \Q$close_delim\E
}xs;

my $posix_re = qr/(\[:.+?:\])/s;

caller || @ARGV && print compact_regex_classes(shift),"\n";

sub compact_regex_classes {
    my ($re) = @_;
    my $output = $re;

    while ($re =~ /($paren_rx)/go) {
        my $class = $1;

        my $negate = '';
        my (@posix_classes,@perl_classes);
        my @offset = ($-[0], length $class);

        while ($class =~ /($paren_rx)/go) {
            my $class2 = $1;

            while ($class2 =~ /$posix_re/go) {
                my $posix_class = $1;
                push @posix_classes, substr($class2, $-[0], length($posix_class), '');
            }

            push @perl_classes, $1 while $class2 =~ s/(?<!\\)(?:\\\\)*\K(\\[a-zA-Z])//;

            my $subclass = '';
            while ($class2 =~ /$paren_rx/go) {
                my $total_class = $1;
                $negate = '^' if $total_class =~ s/\A\^//;
                $subclass .= $total_class;
            }
            next unless length $subclass;

            $subclass =~ s{(?<!\\)(?:\\\\)*\K(?:\\)?(.)-(?:\\)?(.)}{
                ord($1) < ord($2)? join('', map{chr}ord($1) .. ord($2)) : "$1-$2"
            }egs;

            my %table;
            @table{split(//, $subclass)} = ();
            my @chars = sort { $a <=> $b } map { ord } keys %table;

            my %alike;
            my $i     = 0;
            my $group = 0;
            foreach my $char (@chars) {
                if (defined($chars[$i + 1]) and ($char + 1) == $chars[$i + 1]) {
                    push @{$alike{$group}}, $char;
                }
                else {
                    push @{$alike{$group}}, $char;
                    ++$group;
                }
                ++$i;
            }

            my $plain_class;
            foreach my $group_ref (sort { $a <=> $b } keys %alike) {

                @{$alike{$group_ref}} = map {
                    chr($_) ~~ ['[', ']', '\\', '-', '$', '@', '%', '^'] ? quotemeta(chr($_)) : chr($_)
                } @{$alike{$group_ref}};

            if(@{$alike{$group_ref}} > 3){
                $plain_class .= (${$alike{$group_ref}}[0]) . '-' . (${$alike{$group_ref}}[-1]);
            }else{
                $plain_class .= join('', @{$alike{$group_ref}});
            }
        }
        if(@offset == 2){
                my $replace_class = substr($re, $offset[0], $offset[1]);
                $output =~ s{\Q$replace_class\E}{
                    '['.$negate. join('', @perl_classes) . join('',@posix_classes) .  $plain_class.']'
                }e;
            }
        }
    }
    return $output;
}

1;

__END__

=head1 NAME

Regexp::ClassCompact - Compact a regexp's classes.

=head1 SYNOPSIS

    use Regexp::ClassCompact qw(compact_regex_classes);
    compact_regex_classes(qr/[my regex with classes]/);
              # returns: (?^:[ aceg-ilmr-tw-y])

=head1 DESCRIPTION

This module is used for compacting regexp classes,
making them smaller and hopefully, easier to read.

=head1 Examples

=item
    compact_regex_classes(qr/[^\[-\]\\\d\sabcdef1234\1567890\\G[:^alpha:]]
                            -- (?:[test\W[:digit:]z\-ce-r])?/x);
=over

returns:
=item
(?^x:[^\d\s[:^alpha:]0-9G\[-\]a-f]
                            -- (?:[\W[:digit:]\\-ce-tz])?)
=over

=head1 AUTHOR

Trizen <trizenx[@]gmail{*}com>

http://trizen.googlecode.com

=cut