File Coverage

lib/Comment/Spell/Check.pm
Criterion Covered Total %
statement 38 117 32.4
branch 2 24 8.3
condition 0 2 0.0
subroutine 13 21 61.9
pod n/a
total 53 164 32.3


line stmt bran cond sub pod time code
1 2     2   15573 use 5.006;
  2         5  
  2         66  
2 2     2   9 use strict;
  2         2  
  2         53  
3 2     2   18 use warnings;
  2         2  
  2         169  
4              
5             package Comment::Spell::Check;
6              
7             our $VERSION = '0.002000';
8              
9             # ABSTRACT: Check words from Comment::Spell vs a system spell checker.
10              
11             our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
12              
13 2     2   972 use Moo qw( has extends around );
  2         22289  
  2         8  
14 2     2   2414 use Carp qw( croak carp );
  2         2  
  2         104  
15 2     2   2206 use Devel::CheckBin qw( can_run );
  2         160235  
  2         123  
16 2     2   1801 use IPC::Run qw( run timeout );
  2         68860  
  2         123  
17 2     2   3578 use Text::Wrap qw( wrap );
  2         4381  
  2         103  
18 2     2   13 use File::Spec;
  2         11  
  2         22  
19              
20             extends 'Comment::Spell';
21              
22             has 'spell_command' => ( is => 'ro', lazy => 1, builder => '_build_spell_command' );
23             has 'spell_command_exec' => ( is => 'ro', lazy => 1, builder => '_build_spell_command_exec' );
24             has 'spell_command_args' => ( is => 'ro', lazy => 1, default => sub { [] } );
25             has '_spell_command_base_args' => ( is => 'ro', lazy => 1, builder => '_build_spell_command_base_args' );
26             has '_spell_command_all_args' => ( is => 'ro', lazy => 1, builder => '_build_spell_command_all_args' );
27              
28             my $arg_defaults = {
29             'spell' => [],
30             'aspell' => [ 'list', '-l', 'en', '-p', File::Spec->devnull, ],
31             'ispell' => [ '-l', ],
32             'hunspell' => [ '-l', ],
33             };
34              
35             sub _run_spell {
36 0     0   0 my ( $command, $words ) = @_;
37 0         0 my @badwords;
38 0         0 local $@ = undef;
39 0         0 my $ok = eval {
40 0         0 my ( $results, $errors );
41 0         0 run $command, \$words, \$results, \$errors, timeout(10);
42 0         0 @badwords = split /\n/msx, $results;
43 0 0       0 croak 'spellchecker had errors: ' . $errors if length $errors;
44 0         0 1;
45             };
46 0         0 chomp for @badwords;
47 0         0 return ( $ok, \@badwords, $@ );
48             }
49              
50             sub _can_spell {
51 4     4   6 my ($name) = @_;
52 4 50       12 return unless my $bin = can_run($name);
53 0 0       0 my ( $ok, $words, ) = _run_spell( [ $bin, @{ $arg_defaults->{$name} || [] } ], 'iamnotaword' );
  0         0  
54 0 0       0 return unless $ok;
55 0 0       0 return unless @{$words};
  0         0  
56 0 0       0 return unless 'iamnotaword' eq $words->[0];
57 0         0 return $bin;
58             }
59              
60             sub _build_spell_command_exec {
61 1     1   337 my @candidates = (qw( spell aspell ispell hunspell ));
62 1         4 for my $candidate (@candidates) {
63 4 50       617 return $candidate if _can_spell($candidate);
64             }
65 1         411 return croak <<"EOF";
66             Cant determine a spell checker automatically. Make sure one of: @candidates are installed or configure manually.
67             EOF
68             }
69              
70             sub _build_spell_command_base_args {
71 0     0   0 my ($self) = @_;
72 0         0 my $cmd = $self->spell_command_exec;
73 0   0     0 return ( $arg_defaults->{$cmd} || [] );
74             }
75              
76             sub _build_spell_command_all_args {
77 0     0   0 my ($self) = @_;
78 0         0 return [ @{ $self->_spell_command_base_args }, @{ $self->spell_command_args } ];
  0         0  
  0         0  
79             }
80              
81             sub _build_spell_command {
82 1     1   1975 my ($self) = @_;
83 1         6 return [ can_run( $self->spell_command_exec ), @{ $self->_spell_command_all_args } ];
  0            
84             }
85              
86             sub _spell_text {
87 0     0     my ( $self, $text ) = @_;
88 0           my @command = @{ $self->spell_command };
  0            
89 0           my ( $ok, $words, $err ) = _run_spell( \@command, $text );
90 0 0         if ( not $ok ) {
91 0           carp $err;
92             }
93 0           return @{$words};
  0            
94             }
95              
96             around 'parse_from_document' => sub {
97             my ( $orig, $self, $document, @rest ) = @_;
98             local $self->{fails} = []; ## no critic (Variables::ProhibitLocalVars)
99             my %counts;
100             local $self->{counts} = \%counts; ## no critic (Variables::ProhibitLocalVars)
101             local $self->{line_cache} = []; ## no critic (Variables::ProhibitLocalVars)
102              
103             $document->index_locations;
104             $self->$orig( $document, @rest );
105             $self->_process_line_cache() if @{ $self->{line_cache} };
106              
107             if ( keys %counts ) {
108              
109             # Invert k => v to v => [ k ]
110             my %values;
111             push @{ $values{ $counts{$_} } }, $_ for keys %counts;
112              
113             my $labelformat = q[%6s: ];
114             my $indent = q[ ] x 10;
115              
116             $self->_print_output( qq[\nAll incorrect words, by number of occurrences:\n] . join qq[\n],
117             map { wrap( ( sprintf $labelformat, $_ ), $indent, join q[, ], sort @{ $values{$_} } ) }
118             sort { $a <=> $b } keys %values );
119             $self->_flush_output;
120             }
121             return { fails => $self->{fails}, counts => $self->{counts} };
122             };
123              
124             sub _report_badwords {
125 0     0     my ( $self, $start_line, $stop_line, @badwords ) = @_; ## no critic (Variables::ProhibitUnusedVarsStricter)
126 0           my %counts;
127 0           $counts{$_}++ for @badwords;
128 0           $self->{counts}->{$_}++ for @badwords;
129 0           my $fail = {
130             line => $start_line,
131             counts => \%counts,
132             };
133 0           push @{ $self->{fails} }, $fail;
  0            
134 0           my $label = sprintf q[line %6s: ], q[#] . $start_line;
135 0           my $indent = q[ ] x 13;
136 0           local $Text::Wrap::huge = 'overflow'; ## no critic (Variables::ProhibitPackageVars)
137 0           my @printwords;
138              
139 0           for my $key ( sort keys %counts ) {
140 0 0         if ( $counts{$key} > 1 ) {
141 0           push @printwords, $key . '(x' . $counts{$key} . ')';
142 0           next;
143             }
144 0           push @printwords, $key;
145             }
146 0           $self->_print_output( wrap( $label, $indent, join q[ ], @printwords ) );
147 0           $self->_print_output(qq[\n]);
148 0           return;
149             }
150              
151             sub _process_line_cache {
152 0     0     my ($self) = @_;
153 0           my $text = join qq[\n], map { $_->[1] } @{ $self->{line_cache} };
  0            
  0            
154 0           my (@badwords) = split /[ ]/sxm, $self->stopwords->strip_stopwords( join q[ ], $self->_spell_text($text) );
155 0           my $start = $self->{line_cache}->[0]->[0];
156 0           my $stop = $self->{line_cache}->[-1]->[0];
157              
158 0           @{ $self->{line_cache} } = ();
  0            
159              
160 0 0         return unless @badwords;
161 0           $self->_report_badwords( $start, $stop, @badwords );
162 0           return;
163             }
164              
165             sub _push_line_cache {
166 0     0     my ( $self, $line, $text ) = @_;
167 0 0         if ( not @{ $self->{line_cache} } ) {
  0            
168 0           push @{ $self->{line_cache} }, [ $line, $text ];
  0            
169 0           return;
170             }
171              
172             # If there is any gap between lines, consider it a new paragraph.
173 0 0         if ( ( $line - $self->{line_cache}->[-1]->[0] ) > 1 ) {
174 0           $self->_process_line_cache;
175             }
176 0           push @{ $self->{line_cache} }, [ $line, $text ];
  0            
177 0           return;
178             }
179              
180             sub _handle_comment {
181 0     0     my ( $self, $comment ) = @_;
182 0           $self->_push_line_cache( $comment->line_number, $self->_comment_text($comment) );
183 0           return;
184             }
185              
186 2     2   2205 no Moo;
  2         4  
  2         14  
187              
188             1;
189              
190             __END__