#!/usr/bin/perl -w
use strict;
use locale;
use Getopt::Long;
use Config::General;
use File::Copy;
use File::Spec::Functions;
use IO::File;
use Term::ReadLine;
use Term::ANSIColor;
use Term::Size;
use Data::Dumper;
use ACheck::Common;
use ACheck::Parser;
use ACheck::FileType;
# Constants setting
#
use constant VERSION => "0.4"; # script version number
use constant CONFFILE => ".acheck"; # Config file name
# Global variables
#
my $Rules; # rules structure
my @Rules_stack = (-1); # rules stack
my @Rules_success = ( 0); # number of success test per stack level
my @Rules_loop = ( 0); # loop counter
my @Lines_orig; # original file
my @Lines_current = (""); # current line and added comments
my @Lines_fixed = (""); # fixed file and comments
my $Lines_whole; # whole current line
eval "use Text::Aspell;";
my $Aspell = not $@; # true if Aspell module found
my $Speller;
$Speller = Text::Aspell->new if $Aspell; # spell checker
my $Term = new Term::ReadLine (''); # terminal
my $Comment_in = 0; # next line is comments
my $Comment_skip = 0; # small comment found
# Configuration
#
my %conf = (
bak_ext => 'bak',
comment => '>> ',
check_spelling => 1,
word_letters => '\w',
review_mode => 0,
display_menu => 1,
debug => 0,
rules_set => '',
comment_color => 'cyan',
error_color => 'bold on_red',
fix_color => 'bold on_green',
error_head_color => 'bold red',
fix_head_color => 'bold green'
);
if (-e catfile($ENV{HOME}, CONFFILE)) {
my $config = new Config::General (
-ConfigFile => catfile($ENV{HOME}, CONFFILE),
-AllowMultiOptions => 'no',
-LowerCaseNames => 'yes',
-UseApacheInclude => 'no',
-MergeDuplicateOptions => 'yes',
-AutoTrue => 'yes',
-DefaultConfig => \%conf
);
%conf = $config -> getall;
}
my $Bak_e = $conf{'bak_ext'}; # backup files extension
my $Comment = $conf{'comment'}; # comment string
my $Check_spelling = $conf{'check_spelling'}; # use ispell if "yes"
my $Dictionary = $conf{'dictionary'}; # aspell dictionary
my $Word_letters = $conf{'word_letters'}; # letters regex
my $Review_mode = $conf{'review_mode'}; # review mode if "yes"
my $Display_menu = $conf{'display_menu'}; # display menu if "yes"
my $Rules_set = $conf{'rules_set'}; # rules set
my $NC = color( 'clear' ); # color for normal text
my $CC = $NC.color($conf{ 'comment_color'}); # comment text color
my $EC = $NC.color($conf{ 'error_color'}); # highlighted error text color
my $FC = $NC.color($conf{ 'fix_color'}); # highlighted fix text color
my $EL = $NC.color($conf{'error_head_color'}); # error letter color
my $FL = $NC.color($conf{ 'fix_head_color'}); # fix letter color
set_debug($conf{'debug'}); # debug level
# get_offset
#
# split a string at the given offset
#
# input:
# string
# offset
# output:
# part before the offset
# part after
sub get_offset($$) {
my $string = shift;
my $offset = shift;
my $len = length $string;
if ($offset =~ /^s$/i) {
$len = 0;
} elsif ($offset =~ /^s\+(\d+)$/i) {
$len = $1 < $len ? $1 : $len;
} elsif ($offset =~ /^e$/i) {
} elsif ($offset =~ /^e\-(\d+)$/i) {
$len = $1 < $len ? -$1 : -$len;
} else {
suicide __("`%s': unknow offset\n"), $offset;
}
return substr($string, 0, $len),
substr($string, $len );
}
# line_next
#
# save fixed line and get next one
#
# output:
# false if end of file
sub line_next() {
debug 1;
my $stop;
my $first;
my $offset;
if ($Comment_skip) {
$Lines_fixed[-1] .= (defined $Lines_current[0]) ? shift @Lines_current : "";
$Lines_fixed[-1] .= (defined $Lines_orig [0]) ? shift @Lines_orig : ""; # skipped part
unshift @Lines_current, (defined $Lines_orig [0]) ? shift @Lines_orig : ""; # rest of the line
$Comment_skip--;
return 1;
}
if ($Comment_in) {
$stop = (defined $Lines_orig[0]) ? shift @Lines_orig : suicide __("comment: no stop regex\n");
$offset = (defined $Lines_orig[0]) ? shift @Lines_orig : "e";
$Lines_fixed[-1] .= (defined $Lines_current[0]) ? shift @Lines_current : "";
unshift @Lines_current, (defined $Lines_orig [0]) ? shift @Lines_orig : "";
$first = 1;
}
while ($Comment_in) {
if ($Lines_current[0] =~ /$stop/) {
my $a;
my $b;
$Lines_fixed [-1] .= (defined $`) ? $` : "";
$Lines_current[ 0] = (defined $') ? $' : "";
($a, $b) = get_offset($&, $offset);
$Lines_fixed [-1] .= $a;
$Lines_current[ 0] = $b.$Lines_current[0];
$Comment_in--;
return 1;
} else {
if ($first) {
$Lines_fixed[-1] .= (defined $Lines_current[0]) ? shift @Lines_current : "";
push @Lines_fixed, map { $_ = $Comment.$_ } @Lines_current if $Review_mode;
$first = 0;
} else {
$Lines_fixed[-1] .= (defined $Lines_current[0]) ? shift @Lines_current : "";
}
debug 0, $Lines_fixed[-1]."\n";
@Lines_current = (shift @Lines_orig);
push @Lines_fixed, "";
}
}
$Lines_fixed[-1] .= (defined $Lines_current[0]) ? shift @Lines_current : "";
push @Lines_fixed, map { $_ = $Comment.$_ } @Lines_current if $Review_mode;
push @Lines_fixed, "";
$Lines_whole = shift @Lines_orig ;
@Lines_current = ($Lines_whole);
debug 0, ($Lines_current[0] || "")."\n";
return defined $Lines_whole;
}
# stack_add
#
# add one stack level
#
# output:
# next stack
sub stack_add() {
push @Rules_stack, -1; # add one stack level
push @Rules_success, 0; # add one success level
return @Rules_stack;
}
# stack_remove
#
# remove one stack level
#
# output:
# next stack
sub stack_remove() {
pop @Rules_stack; # remove one stack level
pop @Rules_success;
return @Rules_stack;
}
# rule_get
#
# get a rule
#
# input:
# rule stack
# output:
# rule reference
sub rule_get(@) {
debug 5;
my $rule = $Rules->[shift @_];
$rule = $rule->{'rules'}[shift @_] while @_;
return $rule;
}
# rule_current
#
# get current rule
#
# output:
# rule reference
sub rule_current() {
debug 5;
return rule_get(@Rules_stack);
}
# rule_first
#
# set first rule of present stack level
#
# output:
# rule stack
sub rule_first() {
debug 1;
$Rules_stack[@Rules_stack-1] = 0; # first rule
return @Rules_stack;
}
# rule_next
#
# set next rule of present stack level
#
# output:
# false if end of stack level
# new rule stack otherwise
sub rule_next() {
debug 1;
$Rules_stack[@Rules_stack-1]++; # next rule at this stack level
debug 3, (rule_current ? (rule_current->{'regex'} || rule_current->{'name'} || "") : "END OF LEVEL")."\n";
return (defined rule_current) ? @Rules_stack : undef;
}
# rule_last
#
# set last rule of present stack level
#
# output:
# rule stack
sub rule_last() {
debug 1;
$Rules_stack[@Rules_stack-1] = @{ rule_get(@Rules_stack[0,@Rules_stack-2])->{'rules'} }; # first rule
return @Rules_stack;
}
# rule_print
#
# print current rule for debugging
sub rule_print() {
my @s=@Rules_stack;
my @r;
unless (rule_current) {
debug 0, "END OF LEVEL\n";
return;
}
while (@Rules_stack) {
unshift @r, rule_current->{'name'} || rule_current->{'regex'} || rule_current->{'skip'} || rule_current->{'test'} || rule_current->{'type'} || "";
stack_remove;
}
debug 0, join(":", @r)."\n";
@Rules_stack=@s;
}
# next_to_check
#
# set next rule to check
#
# output:
# false if end of ruleset
# new rule stack otherwise
sub next_to_check() {
debug 1;
while (1) {
return 0 unless @Rules_stack; # false if we removed the first stack level at previous pass
rule_next unless defined rule_current->{'test'};
rule_print if get_debug == 9;
until (rule_current) {
return 0 unless stack_remove; # back one level
rule_print if get_debug == 9;
}
while (defined (my $test = rule_current->{'test'})) {
if (rule_current->{'type'} =~ /^until$/) { # until
unless ($Lines_whole =~ /$test/) {
stack_add;
}
} elsif (rule_current->{'type'} =~ /^while$/) { # while
if ($Lines_whole =~ /$test/) {
stack_add;
}
} elsif (rule_current->{'type'} =~ /^loop$/) {
if (($test == 0) || ($Rules_loop[-1] < $test)) {
$Rules_loop[-1]++;
stack_add;
}
}
rule_next;
rule_print if get_debug == 9;
}
if (not (defined rule_current)) { # we reached the end of this stack level
return 0 unless stack_remove; # back one level
} elsif (rule_current->{'rules'}) { # there are sub-rules
stack_add; # add one stack level
rule_next;
rule_print if get_debug == 9;
} else {
last;
}
}
return @Rules_stack;
}
# menu
#
# print menu
#
# input:
# available command letters
# number of corrections [ optionnal ]
sub menu($;$) {
my $l_com = shift;
my $l_max = shift || 0;
my %command = (
''=> undef,
' ' => undef);
{
my @l = qw(E H N X a l i I);
my @m = split(/\n/, __("Edit current line\nAdd hint\nSkip the rest of the line\nExit and discard all changes\nAdd in dictionnary\nAdd lowercase in dictionnary\nIgnore\nIgnore all\n")); # _r_Replace\n_Replace all
$command{shift @l} = shift @m while @l;
}
my $letters = "";
foreach (sort keys %command) {
next unless $l_com =~ /$_/;
$letters .= $_;
next unless defined $command{$_};
print ($EL.$_.$CC." $command{$_}".$NC."\n") if $Display_menu;
}
my $prompt = $letters;
$prompt =~ s/\W//g;
$prompt .= " 0" if $l_max;
$prompt .= "-".($l_max-1) if $l_max && $l_max-1;
my $l = "_";
until ($l =~ /^[$letters]?$/) {
$l = $Term -> readline("$prompt\: ");
chomp $l;
last if ($l =~ /^\d+$/) && (0 <= $l) && ($l < $l_max);
}
return $l;
}
# command_edit
#
# edit error
#
# input:
# string before the match
# match string
# string after the match
# hint array reference
# return:
# correction
sub command_edit($$) {
my $match = shift;
my $hint = shift;
my $fix = $Term -> readline(__("Enter correction to replace the highlighted part:\n"), $match);
if ($Review_mode) {
push @Lines_current, ($Term -> readline(__("Enter explanation, use displayed hint if empty:\n"))) || @{ $hint };
}
return $fix;
}
# command_line
#
# edit the current line
#
# input:
# hint array reference
# return:
# true
sub command_line($) {
my $hint = shift;
$Lines_current[0] = $Term -> readline(__("Modify the line:\n"), $Lines_current[0]);
if ($Review_mode) {
push @Lines_current, $Term -> readline(__("Enter explanation, use displayed hint if empty:\n")) || @{ $hint };
}
return 1;
}
# command_hint
#
# add hints
#
# input:
# hint array reference
# return:
# true
sub command_hint($) {
my $hint = shift;
push @Lines_current, @{ $hint };
return 1;
}
# command_next
#
# go for next line
#
# return:
# true
sub command_next() {
$Rules_success[0]++;
return 1;
}
# command_exit
#
# print exit and discard message and wait for right answer
#
# return:
# false unless exit
sub command_exit() {
my $l;
$l = $Term -> readline(__("Exit and discard all changes! type `yes' to confirm: "));
chomp $l;
exit if $l eq __("yes");
}
# command_nop
#
# nothing
#
# return:
# true
sub command_nop() {
return 1;
}
# make_fix
#
# prepare menu for fixing
#
# input:
# string before error
# matched error
# string after error
# array reference of fixes
# array reference of hints
sub make_fix($$$$$) {
my $before = shift;
my $match = shift;
my $after = shift;
my $fix = shift;
my $hint = shift;
my $bef; # beginning of the line to display
my $aft; # end of the line to display
my $line_nb; # number of displayable fixes
my $line_len; # number of colomns of the terminal
my $head_len; # line header length
my $bef_len; # length before the fix
my $fix_len; # max fix length
my $aft_len; # length after the fix
my $wish_len; # length required
my $half_len; # egal displayable lenght around fix
($line_len, $line_nb) = Term::Size::chars *STDOUT{IO};
$line_len ||= 80;
$line_nb ||= 25;
$line_nb -= ($Display_menu ? 3 : 0);
$line_nb -= 4;
$line_nb = min(scalar @{ $fix }, max($line_nb, 10));
$bef = $Lines_fixed[-1].$before;
$aft = $after;
$head_len = length($line_nb) + 1;
$bef_len = length($bef);
$fix_len = max_length($match, @{ $fix });
$aft_len = length($aft);
$wish_len = $head_len + $bef_len + $fix_len + $aft_len;
$half_len = ($line_len-$head_len-$fix_len)/2;
if ($wish_len > $line_len) {
if ($bef_len < $half_len) {
$aft = substr($aft, 0, $line_len-$head_len-$bef_len-$fix_len );
} elsif ($aft_len < $half_len) {
$bef = substr($bef, -($line_len-$head_len -$fix_len-$aft_len));
} else {
$bef = substr($bef, -$half_len);
$aft = substr($aft, 0, $half_len);
}
}
$bef_len = length $bef;
$aft_len = length $aft;
my $done = 0;
until ($done) {
print $EL." "x($head_len-1).">$NC"; # error line
print "$bef$EC$match$NC$aft\n";
my $l = 0; # fixes
foreach (@{ $fix }) {
last unless $l < $line_nb+1;
my $head = $FL." "x($head_len-length($l)-1).$l.">".$NC;
print $head;
if ($bef_len > $head_len+1) {
print " "x($bef_len-$head_len).$head."$FC$_$NC$aft\n";
} else {
print " "x $bef_len ."$FC$_$NC$aft\n";
}
$l++
}
print " "x$head_len." $CC$_$NC\n" foreach @{ $hint }; # hints
$hint->[0] = sprintf(__("%s: %s"), $match, $hint->[0]);
my $m = menu(" ENX", $l);
if ($m eq "") {
} elsif ($m eq "") {
$done = command_nop;
} elsif ($m eq " ") {
$match = command_edit($match, $hint);
$Lines_current[0] = $before.$match.$after;
$done = command_nop;
} elsif ($m eq "E") {
$done = command_line($hint);
} elsif ($m eq "N") {
$done = command_next;
} elsif ($m eq "X") {
$done = command_exit;
} elsif ((0 <= $m) && ($m < $l)) {
$Lines_current[0] = $before.$fix->[$m].$after;
$done = command_hint($hint);
}
}
}
# make_autofix
#
# prepare menu for autofixing
#
# input:
# string before error
# matched error
# string after error
# array reference of fixes
# array reference of hints
sub make_autofix($$$$$) {
my $before = shift;
my $match = shift;
my $after = shift;
my $fix = shift;
my $hint = shift;
$fix = $fix->[0]; # use first fix
print "$EL >$NC"; # error line
print $Lines_fixed[-1];
print "$before$EC$match$NC$after\n";
print "$FL >$NC"; # fix
print $Lines_fixed[-1];
print "$before$FC$fix$NC$after\n";
print "$CC$_$NC\n" foreach @{ $hint }; # hint
$hint->[0] = sprintf(__("%s: %s"), $match, $hint->[0]);
$Lines_current[0] = $before.$fix.$after;
command_hint($hint);
}
# make_warning
#
# prepare menu for warning
#
# input:
# string before error
# matched error
# string after error
# array reference of fixes
# array reference of hints
sub make_warning($$$$$) {
my $before = shift;
my $match = shift;
my $after = shift;
my $fix = shift;
my $hint = shift;
my $done = 0;
until ($done) {
print "$EL >$NC"; # error line
print $Lines_fixed[-1];
print "$before$EC$match$NC$after\n";
print "$CC$_$NC\n" foreach @{ $hint }; # hint
$hint->[0] = sprintf(__("%s: %s"), $match, $hint->[0]);
my $m = menu(" EHNX");
if ($m eq "") {
} elsif ($m eq "") {
$done = command_nop;
} elsif ($m eq " ") {
$match = command_edit($match, $hint);
$Lines_current[0] = $before.$match.$after;
$done = command_nop;
} elsif ($m eq "E") {
$done = command_line($hint);
} elsif ($m eq "H") {
$done = command_hint($hint);
} elsif ($m eq "N") {
$done = command_next;
} elsif ($m eq "X") {
$done = command_exit;
}
}
}
# make_error
#
# prepare menu for error
#
# input:
# string before error
# matched error
# string after error
# array reference of fixes
# array reference of hints
sub make_error($$$$$) {
my $before = shift;
my $match = shift;
my $after = shift;
my $fix = shift;
my $hint = shift;
my $done = 0;
until ($done) {
print "$EL >$NC"; # error line
print $Lines_fixed[-1];
print "$before$EC$match$NC$after\n";
print "$CC$_$NC\n" foreach @{ $hint }; # hint
$hint->[0] = sprintf(__("%s: %s"), $match, $hint->[0]);
my $m = menu(" EHNX");
if ($m eq "") {
} elsif ($m eq " ") {
$match = command_edit($match, $hint);
$Lines_current[0] = $before.$match.$after;
$done = command_nop;
} elsif ($m eq "") {
$done = command_nop;
} elsif ($m eq "E") {
$done = command_line($hint);
} elsif ($m eq "H") {
$done = command_hint($hint);
} elsif ($m eq "N") {
$done = command_next;
} elsif ($m eq "X") {
$done = command_exit;
}
}
}
# parse
#
# main parsing sub
#
sub parse() {
debug 1;
my $done;
until ($done) {
next_to_check;
my $rule = rule_current;
my $type = $rule->{'type'};
if ($type =~ /^comment$/i) {
my $start = $rule->{'start'};
my $skip = $rule->{'skip' };
if ($skip && $Lines_current[0] =~ /$skip/ ) {
$Lines_current[0] = (defined $`) ? $` : "";
unshift @Lines_orig, (defined $') ? $' : "";
unshift @Lines_orig, (defined $&) ? $& : "";
$Comment_skip++;
}
if ($start && $Lines_current[0] =~ /$start/) {
my $a;
my $b;
$Lines_current[0] = (defined $`) ? $` : "";
unshift @Lines_orig, (defined $') ? $' : "";
($a, $b) = get_offset($&, $rule->{'start_offset'} || "s");
$Lines_current[0] .= $a;
$Lines_orig [0] = $b.$Lines_orig[0];
unshift @Lines_orig, ($rule->{'stop_offset'} || "e");
unshift @Lines_orig, ($rule->{'stop' } );
$Comment_in++;
}
next;
} elsif ($type =~ /^nop$/) {
$done = 1;
debug 3, "nop\n";
next;
}
my $regex = $rule->{'regex'};
my @fix = $rule->{'fix' } ? @{ $rule->{'fix' } } : ();
my @hint = $rule->{'hint' } ? @{ $rule->{'hint' } } : ();
my @valid = $rule->{'valid'} ? @{ $rule->{'valid'} } : ();
if ($Lines_current[0] =~ /$regex/) {
my $before = (defined $`) ? $` : "";
my $match = (defined $&) ? $& : "";
my $after = (defined $') ? $' : "";
@fix = map { eval "\"$_\"" } @fix; # group substitution ##### FIXME security? FIXME #####
my $ok;
foreach (@valid) {
$ok = 1;
$ok &= ($before =~ $_->{'pre' }) if defined $_->{'pre' };
$ok &= ($match =~ $_->{'in' }) if defined $_->{'in' };
$ok &= ($after =~ $_->{'post'}) if defined $_->{'post'};
last if $ok;
}
next if $ok;
if ($type =~ /^fix$/ ) {
make_fix ($before, $match, $after, \@fix, \@hint);
} elsif ($type =~ /^autofix$/) {
make_autofix($before, $match, $after, \@fix, \@hint);
} elsif ($type =~ /^warning$/) {
make_warning($before, $match, $after, \@fix, \@hint);
} elsif ($type =~ /^error$/ ) {
make_error ($before, $match, $after, \@fix, \@hint);
} else {
suicide __("`%s': unknown operation\n"), $type;
}
}
}
}
# aspell_fix
#
# fix using aspell module
#
# input:
# mispelled word
sub aspell_fix($) {
my $word = shift;
my @suggestions = ($Speller->suggest($word));
my $hint = [(sprintf __("spelling for `%s'"), $word)];
my $bef; # beginning of the line to display
my $aft; # end of the line to display
my $line_nb; # number of displayable fixes
my $line_len; # number of colomns of the terminal
my $head_len; # line header length
my $bef_len; # length before the fix
my $fix_len; # max fix length
my $aft_len; # length after the fix
my $wish_len; # length required
my $half_len; # egal displayable lenght around fix
($line_len, $line_nb) = Term::Size::chars;
$line_len ||= 80;
$line_nb ||= 25;
$line_nb -= ($Display_menu ? 8 : 0);
$line_nb -= 4;
$line_nb = min(scalar @suggestions, max($line_nb, 10));
$bef = $Lines_fixed[-1].$Lines_current[0];
$aft = $Lines_current[1];
$head_len = length($line_nb) + 1;
$bef_len = length($bef);
$fix_len = max_length($word, @suggestions);
$aft_len = length($aft);
$wish_len = $head_len + $bef_len + $fix_len + $aft_len;
$half_len = ($line_len-$head_len-$fix_len)/2;
if ($wish_len > $line_len) {
if ($bef_len < $half_len) {
$aft = substr($aft, 0, $line_len-$head_len-$bef_len-$fix_len );
} elsif ($aft_len < $half_len) {
$bef = substr($bef, -($line_len-$head_len -$fix_len-$aft_len));
} else {
$bef = substr($bef, -$half_len);
$aft = substr($aft, 0, $half_len);
}
}
$bef_len = length $bef;
$aft_len = length $aft;
print $EL." "x($head_len-1).">$NC"; # error line
print "$bef$EC$word"." "x($fix_len-length($word))."$NC$aft\n";
my $l = 0; # fixes
foreach (@suggestions) {
last unless $l < $line_nb+1;
my $head = $FL." "x($head_len-length($l)-1).$l.">".$NC;
print $head;
if ($bef_len > $head_len+1) {
print " "x($bef_len-$head_len).$head."$FC$_"." "x($fix_len-length($_))."$NC\n";
} else {
print " "x $bef_len ."$FC$_"." "x($fix_len-length($_))."$NC\n";
}
$l++
}
my $done = 0;
until ($done) {
my $m = menu(" aliIrRENX", $l);
if ($m eq "") {
} elsif ($m eq "") {
$Lines_current[0] .= $word;
$done = command_nop;
} elsif ($m eq " ") { # edit word
$word = command_edit($word, $hint);
$Lines_current[1] = $word.$Lines_current[1]; # change must be checked
$done = command_nop;
} elsif ($m eq "a") { # add
$Speller->add_to_personal($word);
$Speller->save_all_word_lists;
$Lines_current[0] .= $word;
$done = command_nop;
} elsif ($m eq "l") { # add lowercase
$Speller->add_to_personal(lc $word);
$Speller->save_all_word_lists;
$Lines_current[0] .= $word;
$done = command_nop;
} elsif ($m eq "i") { # ignore
$Lines_current[0] .= $word;
$done = command_nop;
} elsif ($m eq "I") { # ignore all
$Speller->add_to_session($word);
$Lines_current[0] .= $word;
$done = command_nop;
# } elsif ($m eq "r") { # replace
# $Lines_current[0] .= $word;
# $done = command_nop;
# } elsif ($m eq "R") { # replace all
# $Lines_current[0] .= $word;
# $done = command_nop;
} elsif ($m eq "E") {
$Lines_current[0] .= $word.$Lines_current[1]; # prepare for edition
$done = command_line($hint);
$Lines_current[1] = $Lines_current[0]; # all line must be re-checked
$Lines_current[0] = "";
} elsif ($m eq "N") {
$Lines_current[0] .= $word.$Lines_current[1];
$Lines_current[1] = "";
$done = command_next;
} elsif ($m eq "X") {
$done = command_exit;
} elsif ((0 <= $m) && ($m < $l)) {
$Lines_current[0] .= $suggestions[$m];
$hint = [(sprintf __("%s: spelling for `%s'"),$suggestions[$m] ,$word)];
$done = command_hint($hint);
}
}
}
# spell
#
# main spell-checking sub
#
sub spell() {
debug 1;
my @stack = @Rules_stack;
while (@stack) {
my $rule = rule_get(@stack);
if (defined $rule->{'test'}) {
last unless defined $rule->{'spell'};
return if $rule->{'spell'} =~ /^no$/i;
last;
} else {
pop @stack;
next;
}
}
unshift @Lines_current, "";
while (1) {
my $found = $Lines_current[1] =~ /[$Word_letters]+/i;
my $before = (defined $`) ? $` : "";
my $match = (defined $&) ? $& : "";
my $after = (defined $') ? $' : "";
unless ($found) {
$Lines_current[0] .= $Lines_current[1];
$Lines_current[1] = "";
last;
}
$Lines_current[0] .= $before;
$Lines_current[1] = $after;
$found = $Speller->check($match);
if ($found) {
$Lines_current[0] .= $match;
} elsif (defined $found) {
aspell_fix($match);
} else { ##### FIXME skip on error FIXME #####
$Lines_current[0] .= $match;
}
}
my $l = shift @Lines_current;
shift @Lines_current;
unshift @Lines_current, $l;
}
# parse_file
#
# parse a loaded file
#
sub parse_file() {
debug 1;
while (line_next) {
parse;
spell if $Check_spelling && $Aspell;
}
shift @Lines_fixed; # remove first item which was line #0 and so is empty
pop @Lines_fixed; # remove last item which was prepared for next line and so is empty
}
# load_file
#
# load a file
#
# input:
# filename
sub load_file($) {
debug 3;
my $file = shift;
debug 1;
debug 2, "filename $file\n";
my $handle = *STDIN;
unless ($file eq "-") {
$handle = new IO::File($file, '<') or suicide __("Cannot read `%s': %s\n"), $file, $!;
}
@Lines_orig = $handle -> getlines;
chomp @Lines_orig;
@Lines_orig or suicide __("Empty file\n");
}
# write_file
#
# write a file
#
# input:
# filename
sub write_file($) {
debug 3;
my $file = shift;
debug 1;
debug 2, "filename $file\n";
my $handle = *STDOUT;
unless ($file eq "-") {
(-e $file) && (move($file, "$file.$Bak_e") or suicide __("Cannot backup `%s': %s\n"), $file, $!);
$handle = new IO::File($file, '>') or suicide __("Cannot write to `%s': %s\n");
}
$handle -> print(join("\n", @Lines_fixed)."\n");
}
# print_version
#
# Print version
#
sub print_version () {
debug 1;
my $me = $0; # get command name with path
$me =~ s/.*\/([^\/]*)$/$1/; # keep script name
debug 0, __("%s version %s\n"), $me, VERSION;
exit;
}
# print_help
#
# Print help message
#
sub print_help () {
debug 1;
my $me = $0; # get command name with path
$me =~ s/.*\/([^\/]*)$/$1/; # keep script name
debug 0, __("Usage: %s [OPTIONS] [INPUT_FILE]\n\noptions:\n -q, --quiet quiet mode\n -v verbose, add more for more verbosity\n --verbose set verbosity to n\n --rules <set> use rules set <set>\n --type <type> set filetype to <type>\n -i, --input <file> input filename\n -o, --output <file> output filename\n -s, --spell check spelling with aspell\n -d, --dict <lang> use <lang> dictionary\n -n, --nospell don't check spelling\n -r, --review add comments (for reviewers)\n -t, --trans don't add comments (for translators)\n --dump dump the rules and exit (for debugging)\n -V, --version print version and exit\n -h, --help print this message and exit\n\nIf input filename is '-' or not provided, data are read from STDIN\nIf output filename is not provided, input filename is used, '-' write to STDOUT\n\n%s version %s\n"), $me, $me, VERSION;
exit;
}
# main
#
# Parse command line
#
{
debug 1;
my $dump; # flag for --dump option
my $filetype;
my $input_file;
my $output_file;
Getopt::Long::Configure qw(permute bundling); # set standard gnu options (for potato perl)
Getopt::Long::GetOptions (
'verbose=i' => sub { set_debug $_[1] }, # verbose <value>
'v+' => sub { inc_debug }, # incremental
'quiet|q' => sub { set_debug 0 }, # quiet
'version|V' => sub { print_version; exit 0 }, # version
'help|h' => sub { print_help; exit 0 }, # help
'input|i=s' => \$input_file, # input filename
'output|o=s' => \$output_file, # output filename
'rules=s' => \$Rules_set, # rules set
'type=s' => \$filetype, # file type
'spell|s' => sub { $Check_spelling = 1 }, # use aspell
'nospell|n' => sub { $Check_spelling = 0 }, # short no
'dict|d=s' => \$Dictionary, # dictionary
'review|r' => sub { $Review_mode = 1 }, # review mode
'trans|t' => sub { $Review_mode = 0 }, # translation mode
'dump' => sub { $dump = 1 } # dump and exit
);
$input_file ||= shift @ARGV if @ARGV;
$input_file ||= "-";
$output_file ||= $input_file;
debug 5,
"Configuration dump:\n".
"bak_e ". $Bak_e."\n".
"comment ". $Comment."\n".
"rules set ".($Rules_set || "")."\n";
debug 4, "debug ". get_debug."\n";
debug 5, "check spelling ".($Check_spelling ? "yes" : "no" )."\n".
"aspell ".($Aspell ? "" : "not")."found\n".
"dictionary ".($Dictionary || "")."\n".
"word letters ". $Word_letters."\n".
"review mode ".($Review_mode ? "yes" : "no")."\n".
$CC."comments color".$NC."\n".
$EC."error text".$NC."\n".
$FC."fix text".$NC."\n".
$EL."error head color".$NC."\n".
$FL."fix head color".$NC."\n".
"version ". VERSION."\n";
debug 4, "input file ". $input_file."\n".
"output file ". $output_file."\n";
debug 5, "file type ". $filetype."\n" if $filetype;
debug 4, "arguments ".join(" ", @ARGV)."\n" if @ARGV;
if (not ($Aspell) && $Check_spelling) {
$Check_spelling = 0;
if ((-t) && (-t STDOUT)) {
print $EC.__("Aspell Perl module not found, spelling check cancelled.")."$NC\n";
print $CC.__("Press 'Enter' to continue")."$NC\n";
menu(" ");
} else {
warning __("Aspell Perl module not found, spelling check cancelled.");
}
}
if ($Aspell && $Dictionary) {
suicide(__("Aspell: unable to use `%s'.\n"), $Dictionary) unless $Speller -> set_option('lang', $Dictionary);
}
load_file $input_file;
$filetype ||= file_type($input_file, \@Lines_orig); # get file type if not provided
$Rules = load_ruleset($Rules_set, $filetype);
if ($dump) {
print Dumper($Rules);
exit 0;
}
parse_file;
write_file $output_file;
}