our $VERSION = 'v0.5.0';
const my $DEFAULT => '_';
has 'ignore_classes' => (
is => 'rw',
isa => ArrayRef[Str],
default => sub { [qw( no-spellcheck )] },
);
has 'check_attributes' => (
is => 'rw',
isa => ArrayRef[Str],
default => sub { [qw( title alt )] },
);
has '_empty_elements' => (
is => 'rw',
isa => HashRef[Bool],
default => sub {
return {
map { $_ => 1 } (
qw( area base basefont br col frame hr img input isindex link meta param )
)
};
},
);
has 'ignore_words' => (
is => 'rw',
isa => HashRef,
default => sub { {} },
);
has 'tester' => (
is => 'ro',
lazy => 1,
default => sub {
my $self = shift;
return $self->builder;
},
);
has 'tokenizer' => (
is => 'rw',
lazy => 1,
default => sub {
my ($self) = @_;
return Search::Tokenizer->new(
regex => qr/\p{Word}+(?:[-'.]\p{Word}+)*/,
lower => 0,
stopwords => $self->ignore_words,
);
},
);
has 'parser' => (
is => 'ro',
lazy => 1,
default => sub {
my ($self) = @_;
return HTML::Parser->new(
api_version => 3,
ignore_elements => [qw( script style )],
empty_element_tags => 1,
start_document_h => [ $self->curry::_start_document ],
start_h =>
[ $self->curry::_start_element, "tagname,attr,line,column" ],
end_h => [ $self->curry::_end_element, "tagname,line" ],
text_h => [ $self->curry::_text, "dtext,line,column" ],
);
},
);
has '_spellers' => (
is => 'ro',
isa => HashRef,
lazy => 1,
default => sub {
my $speller = Text::Aspell->new();
my $self = { $DEFAULT => $speller, };
return $self;
},
);
sub speller {
my ( $self, $lang ) = @_;
$lang =~ tr/-/_/ if ( defined $lang );
if ( my $speller = $self->_spellers->{ $lang // $DEFAULT } ) {
return $speller;
}
elsif ( $lang eq $self->_spellers->{$DEFAULT}->get_option('lang') ) {
$speller = $self->_spellers->{$DEFAULT};
if ( $lang =~ /^([a-z]{2})[_-]/ ) {
if ( defined $self->_spellers->{$1} ) {
$speller = $self->_spellers->{$1};
}
else {
$self->_spellers->{$1} = $speller;
}
}
$self->_spellers->{$lang} = $speller;
return $speller;
}
else {
$speller = Text::Aspell->new();
$speller->set_option( "lang", $lang );
if ( $lang =~ /^([a-z]{2})[_-]/ ) {
if ( defined $self->_spellers->{$1} ) {
$speller = $self->_spellers->{$1};
}
else {
$self->_spellers->{$1} = $speller;
}
}
$self->_spellers->{$lang} = $speller;
return $speller;
}
}
sub langs {
my ($self) = @_;
my @langs = grep { !/[_]/ } ( keys %{ $self->_spellers } );
return @langs;
}
has '_errors' => (
is => 'rw',
isa => Int,
default => 0,
);
has '_context' => (
is => 'rw',
isa => ArrayRef[HashRef],
default => sub { [] },
);
sub _context_depth {
my ($self) = @_;
return scalar( @{ $self->_context } );
}
sub _context_top {
my ($self) = @_;
return $self->_context->[0];
}
sub _is_ignored_context {
my ($self) = @_;
if ( $self->_context_depth ) {
return $self->_context_top->{ignore};
}
else {
return 0;
}
}
sub _context_lang {
my ($self) = @_;
if ( $self->_context_top ) {
return $self->_context_top->{lang};
}
else {
return $self->speller->get_option("lang");
}
}
sub _push_context {
my ( $self, $element, $lang, $ignore, $line ) = @_;
if ( $self->_empty_elements->{$element} ) {
return;
}
unshift @{ $self->_context },
{
element => $element,
lang => $lang,
ignore => $ignore || $self->_is_ignored_context,
line => $line,
};
}
sub _pop_context {
my ( $self, $element, $line ) = @_;
if ( $self->_empty_elements->{$element} ) {
return;
}
my $context = shift @{ $self->_context };
return $context;
}
sub _start_document {
my ($self) = @_;
$self->_context( [] );
$self->_errors(0);
}
sub _start_element {
my ( $self, $tag, $attr, $line ) = @_;
$attr //= {};
my %classes = map { $_ => 1 } split /\s+/, ( $attr->{class} // "" );
my $state = $self->_is_ignored_context;
my $ignore = reduce {
no warnings 'once';
$a || $b;
}
( $state, map { $classes{$_} // 0 } @{ $self->ignore_classes } );
my $lang = $attr->{lang} // $self->_context_lang;
$self->_push_context( $tag, $lang, $ignore, $line );
unless ($ignore) {
foreach my $name ( @{ $self->check_attributes } ) {
$self->_text( $attr->{$name}, $line ) if ( exists $attr->{$name} );
}
}
}
sub _end_element {
my ( $self, $tag, $line ) = @_;
if ( my $context = $self->_pop_context( $tag, $line ) ) {
if ( $tag ne $context->{element} ) {
$self->tester->croak(
sprintf(
"Expected element '%s' near input line %d",
$context->{element}, $line // 0
)
);
}
my $lang = $context->{lang};
}
}
sub _text {
my ( $self, $text, $line ) = @_;
unless ( $self->_is_ignored_context ) {
my $speller = $self->speller( $self->_context_lang );
my $encoding = $speller->get_option('encoding');
my $iterator = $self->tokenizer->($text);
while ( my $u_word = $iterator->() ) {
my $word = encode( $encoding, $u_word );
my $check =
$speller->check($word)
|| looks_like_number($word)
|| $word =~ /^\d+(?:[-'._]\d+)*/;
unless ($check) {
$self->_errors( 1 + $self->_errors );
$self->tester->diag(
"Unrecognized word: '${word}' at line ${line}");
}
}
}
}
sub check_spelling {
my ( $self, $text ) = @_;
$self->_errors(0);
$self->parser->parse($text);
$self->parser->eof;
if ( $self->_errors ) {
$self->tester->diag(
sprintf(
"Found %d spelling %s",
$self->_errors, ( $self->_errors == 1 ) ? "error" : "errors"
)
);
}
return ( $self->_errors == 0 );
}
sub spelling_ok {
my ( $self, $text, $message ) = @_;
$self->tester->ok( $self->check_spelling($text), $message );
}
1;