File Coverage

blib/lib/String/BlackWhiteList.pm

Criterion	Covered	Total	%
statement	42	43	97.6
branch	17	18	94.4
condition	6	6	100.0
subroutine	7	7	100.0
pod	3	3	100.0
total	75	77	97.4

use 5.008;
use strict;
use warnings;

package String::BlackWhiteList;
our $VERSION = '1.100860';
# ABSTRACT: Match a string against a blacklist and a whitelist
use parent 'Class::Accessor::Complex';
__PACKAGE__
    ->mk_new
    ->mk_scalar_accessors(qw(black_re white_re))
    ->mk_array_accessors(qw(blacklist whitelist))
    ->mk_boolean_accessors(qw(is_literal_text));

sub update {
    my $self      = shift;
    my @blacklist = $self->blacklist;
    my @whitelist = $self->whitelist;
    my %seen;
    $seen{$_} = 1 for @blacklist;
    for (@whitelist) {
        next unless $seen{$_};
        warn "[$_] is both blacklisted and whitelisted\n";
    }
    my $is_literal_text = $self->is_literal_text;    # caching
    my $black_re =
      join '|',
      map { $is_literal_text ? '\b' . quotemeta($_) . '(\b|\s|$)' : $_ }
      $self->blacklist;
    $self->black_re(qr/$black_re/i);
    my $white_re =
      join '|',
      map { $is_literal_text ? '\b' . quotemeta($_) . '(\b|\s|$)' : $_ }
      $self->whitelist;
    $self->white_re(qr/$white_re/i);
    $self;
}

sub valid {
    my ($self, $s) = @_;
    return 1 unless defined $s && length $s;
    my $white_re = $self->white_re;
    my $black_re = $self->black_re;
    if ($s =~ s/$white_re//gi) {

        # If part of the string matches the whitelist, but another part of it
        # matches the blacklist, it is still considered invalid. So we deleted
        # the part that matched the whitelist and examine the remainder.
        #
        # This is necessary because the blacklist can be more general than the
        # whitelist. For example, you are testing whether a street address
        # string is a pobox, and you put 'Post' and 'P.O. BOX' in the
        # blacklist, but put 'Post Street' in the blacklist. Now it's clear
        # why we had to delete the part that matched the whitelist. Also
        # consider the case of 'P.O. BOX 37, Post Street 9'.
        return $s !~ qr/$black_re/i;
    } elsif ($s =~ qr/$black_re/i) {
        return 0;
    } else {
        return 1;
    }
}

sub valid_relaxed {
    my ($self, $s) = @_;
    return 1 unless defined $s && length $s;
    my $white_re = $self->white_re;
    my $black_re = $self->black_re;
    return 1 if $s =~ qr/$white_re/i;
    return 0 if $s =~ qr/$black_re/i;
    return 1;
}
1;


__END__