File Coverage

blib/lib/List/Prefixed.pm

Criterion	Covered	Total	%
statement	120	121	99.1
branch	60	66	90.9
condition	14	15	93.3
subroutine	14	14	100.0
pod	4	4	100.0
total	212	220	96.3

package List::Prefixed;
use 5.004;
use strict;
use warnings;
use Carp;

# -- globals --

our $VERSION = '0.03';

# Public global variables.
our (
    $UC_ESCAPE_STYLE,   # "PCRE" | "Java" | undef
    $REGEX_ESCAPE,      # CODE: Str -> Str
    $REGEX_UNESCAPE     # CODE: Str -> Str
  );

# The default unicode escape format is the PCRE style \x{FF}.
# - To output regular expressions in \uFFFF (Java, etc.) style, set $UC_ESCAPE_STYLE to 'Java'.
# - To avoid replacement of non-ASCII characters at all, set $UC_ESCAPE_STYLE to undef.
$UC_ESCAPE_STYLE = 'PCRE';

# Unicode escape styles
my %UC_escape = (
  PCRE => [ '\\x{%X}' => qr/\\x\{([0-9A-F]{2,6})}/i ],
  Java => [ '\\u%04X' => qr/\\u([0-9A-F]{4,6})/i ],
);

# Get the escape form (0) / unescape regex (1) depending on $UC_ESCAPE_STYLE.
my $UC_ESCAPE = sub {
  return undef unless defined $UC_ESCAPE_STYLE;
  return $UC_escape{$UC_ESCAPE_STYLE}[$_[0]] if exists $UC_escape{$UC_ESCAPE_STYLE};
  croak "Unsupported UC_ESCAPE_STYLE: '$UC_ESCAPE_STYLE'"; # RTFM
};

# The default escape procedure.
$REGEX_ESCAPE = sub {

  # quotemeta EXPR
  #   Returns the value of EXPR with all non-"word" characters backslashed.
  #   (That is, all characters not matching "/[A-Za-z_0-9]/" will be preceded by
  #   a backslash in the returned string, regardless of any locale settings.)
  local $_ = quotemeta $_[0];

  # additionally apply $UC_ESCAPE_STYLE
  if ( defined(my $uc_form = &$UC_ESCAPE(0)) ) {
    s/\\?(\P{ASCII})/ sprintf $uc_form => ord $1 /eg;
  }

  $_;
};

# The default unescape procedure.
$REGEX_UNESCAPE = sub {
  local $_ = $_[0];

  # apply $UC_ESCAPE_STYLE first
  if ( defined(my $uc_re = &$UC_ESCAPE(1)) ) {
    s/$uc_re/ chr hex $1 /eg;
  }

  # replace backslash escapes as inserted by quotemeta
  s/\\([^A-Z0-9_])/$1/gi;

  $_;
};

# Globals may passed as module arguments, e.g.:
#
#   use List::Prefixed uc_escape_style => 'Java';
#
sub import {
  shift; # __PACKAGE__;
  my %args = @_;

  $UC_ESCAPE_STYLE = $args{uc_escape_style} if exists $args{uc_escape_style};
  $REGEX_ESCAPE = $args{regex_escape} if exists $args{regex_escape};
  $REGEX_UNESCAPE = $args{regex_unescape} if exists $args{regex_unescape};
}

# -- public --

# Construct a Prefixed object from a string list
sub fold {

  local *reduce = sub {
    # Large lists may cause a 'Deep recursion on anonymous subroutine' warning,
    # see http://perldoc.perl.org/perldiag.html
    no warnings 'recursion';

    my ($prefix, $nlist, $opt) = @{$_[0]};

    return $_[0] unless ref $nlist && @$nlist > 1;

    # 1st char of the prefix of 1st node in list
    my ($c);

    # check whether 2nd prefix starts with same letter as the 1st
    if ( length $nlist->[0][0] ) {
      $c = substr $nlist->[0][0], 0, 1; # first char
      undef $c unless $c eq substr $nlist->[1][0], 0, 1;
    }

    unless ( defined $c )
    {
      return $_[0] unless @$nlist > 2;

      # try to reduce next list part
      my $first = shift @$nlist;
      my $next = reduce(bless ['', $nlist, 0]);
      return bless [ $prefix, [ $first, $next ], $opt] if length $next->[0];

      # couldn't be reduced
      return bless [ $prefix, [ $first, @{$next->[1]} ], $opt ];
    }

    # reduce any ensuing node whose prefix starts with $c
    my @new;
    my $newopt = undef;
    my $qc = quotemeta $c;
    while ( @$nlist )
    {
      last unless $nlist->[0][0] =~ s/^$qc//;

      # reduce node or detect new optional node
      my $n = shift @$nlist;
      if ( length $n->[0] )
      {
        push @new, $n;
        next;
      }
      $newopt = 1;
    }

    if ( @$nlist || $opt )
    {
      my $new = reduce(bless [ $c, [ @new ], $newopt ]);
      if ( @$nlist )
      {
        # reduce remaining nlist
        my $next = reduce(bless ['', $nlist, 0]);
        return bless [ $prefix, [ $new, $next ], $opt] if length $next->[0];

        # couldn't be reduced
        return bless [ $prefix, [ $new, @{$next->[1]} ], $opt ];
      }

      # current node is optional
      return bless [ $prefix, [ $new, @$nlist ], $opt ];
    }

    # nothing left to reduce
    reduce(bless [ $prefix.$c, [ @new ], $newopt ]);
  };

  shift; # __PACKAGE__
  my @s = sort keys %{ { map{ $_ => 1 } @_ } }; # unique sorted
  return bless [$_[0],[],undef] if @s == 1; # singleton
  reduce(bless [ '', [( map { [$_] } @s )],undef]);
};

my $RE_PREFIX = qr/(?:\\(?:.|\n)|[^\|\(\)])+/;

# Construct a Prefixed object from a regular expression.
#
# Solution based on basic regular expression evaluation.
sub unfold {
  shift; # __PACKAGE__
  my ($regex) = @_;
  my ($nn,$cn,@st);
  while ( length $regex ) {

    # prefix string
    if ( $regex =~ s/^\|?($RE_PREFIX)// ) {
      my $p = &$REGEX_UNESCAPE($1);
      if ( $cn ) {
        $cn->[1] = [] unless ref $cn->[1];
        push @{$cn->[1]}, ($nn = bless [$p]);
      }
      else {
        $cn = $nn = bless [$p];
      }
      next;
    }

    # node start
    if ( $regex =~ s/^\(\?:// ) {
      if ( $nn ) {
        $cn = $nn;
      }
      else {
        $cn = $nn = bless [''];
      }
      push @st, $nn;
      next;
    }

    # node end
    if ( $regex =~ s/^\)(\?)?// ) {
      $cn = pop @st;
      $cn->[2] = defined $1 ? 1 : undef;
      $cn = $st[$#st] if @st;
      next;
    }

    die "invalid: '$regex'";
  }
  $cn;
};


sub regex {

  local *to_regex_rec = sub {
    my ($prefix, $nlist, $opt) = @{$_[0]};
    my $rv = &$REGEX_ESCAPE($prefix);
    if ( $nlist && @$nlist )
    {
      $rv .= '(?:'.(join '|', map { to_regex_rec($_) } @$nlist).')';
      $rv .= '?' if $opt;
    }
    $rv;
  };

  my $node = shift;
  to_regex_rec($node);
}

sub list {
  my $node = shift;
  my ($s) = @_;
  $s = '' unless defined $s;
  my $qs = quotemeta $s;

  local *list_rec = sub {
    my ($p,$n,$list) = @_;
    my ($prefix, $nlist, $opt) = @$n;
    my $p2 = $p.$prefix;
    my $qp2 = quotemeta $p2;
    my ($push,$continue);
    if ( $p2 =~ m/^$qs/ ) {
      # current prefix starts with search string
      $push = $continue = 1;
    }
    elsif ( $s =~ m/^$qp2/ ) {
      # search string starts with current prefix
      $continue = 1;
    }

    if ($nlist && @$nlist) {
      push @$list, $p2 if $push && $opt;
      if ( $continue ) {
        list_rec($p2,$_,$list) foreach @$nlist;
      }
    }
    elsif ( $push ) {
      push @$list, $p2;
    }
  };

  my @list;
  list_rec('',$node,\@list);
  wantarray ? @list : \@list;
}


# Standard new constructor is an alias for fold.
*new = \&fold;

1;
__END__