Something went wrong. Try again.
Perl game server for TLE Community
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117package Lacuna::Verify;
use Moose;use utf8;no warnings qw(uninitialized);use Regexp::Common;use Email::Valid;
has content => ( is => 'ro', required => 1,);
has throws => ( is => 'ro', required => 1, writer => '_throws',);
sub ok { my ($self, $test) = @_; unless ($test) { confess $self->throws; } return $self;}
sub not_ok { my ($self, $test) = @_; return $self->ok(!$test);}
sub eq { my ($self, $val) = @_; return $self->ok(${$self->content} eq $val);}
sub ne { my ($self, $val) = @_; return $self->ok(${$self->content} ne $val);}
sub empty { my $self = shift; return $self->ok(${$self->content} eq '');}
sub not_empty { my $self = shift; return $self->ok(${$self->content} ne '' && ${$self->content} =~ m/\S+/xms);}
sub no_profanity { my $self = shift; my @bad_words = lc(${$self->content}) =~ /$RE{profanity}{-keep}/g; if (@bad_words) { my %word_count; $word_count{$_}++ for @bad_words; my $throws = $self->throws; # Real callers pass an arrayref [code, message, field]; only rewrite the # message to list the offending words when that's the shape we got. A # scalar throws falls through to `confess $self->throws` unchanged. if (ref $throws eq 'ARRAY') { my $msg = $throws->[1] . ' ('; $msg .= join ', ', map { my $s = $_; $s .= " (x$word_count{$_})" if $word_count{$_} != 1; $s; } sort keys %word_count; $msg .= ')'; $throws->[1] = $msg; } } return $self->ok(@bad_words == 0);}
sub no_restricted_chars { my $self = shift; return $self->ok(${$self->content} !~ m/[@&<>;\{\}\(\)]/);}
sub no_match { my $self = shift; my $re = shift; return $self->ok(${$self->content} !~ $re);}
sub no_padding { my $self = shift; return $self->ok(${$self->content} !~ m/^\s/ && ${$self->content} !~ m/\s\s/ && ${$self->content} !~ m/\s$/);}
sub no_tags { my $self = shift; return $self->ok(${$self->content} !~ m/[<>]/);}
sub length_gt { my ($self, $length) = @_; return $self->ok(length(${$self->content}) > $length);}
sub length_lt { my ($self, $length) = @_; return $self->ok(length(${$self->content}) < $length);}
sub is_email { my ($self) = @_; return $self->ok(Email::Valid->address(${$self->content}));}
no Moose;__PACKAGE__->meta->make_immutable;