Sharedwww / cgi-bin / openwebmail / openwebmail-spell.plOpen in CoCalc
Author: William A. Stein
1
#!/usr/bin/perl
2
#
3
# openwebmail-spell.pl - spell check program
4
#
5
# 2003/02/19 Scott E. Campbell, scampbel.AT.gvpl.ca
6
# add personal dictionary support
7
# 2001/09/27 tung.AT.turtle.ee.ncku.edu.tw
8
# modified from WBOSS Version 1.50a
9
#
10
# WBOSS is available at http://www.dontpokebadgers.com/spellchecker/
11
# and is copyrighted by 2001, Joshua Cantara
12
#
13
14
# This is the table of valid letters for various dictionaries.
15
# If your dictionary checks vocabularies composed by characters other
16
# than english letters, you have to define new entry in below hash
17
18
use vars qw (%dictionary_letters);
19
if ($dictionary_letters{english} eq '') {
20
%dictionary_letters =
21
(
22
english => 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz',
23
br => 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz������������������������',
24
brasileiro => 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz������������������������',
25
czech => 'A�BC�D�E��FGHI�JKLMN�O�PQR�S�T�U��VWXY�Z�a�bc�d�e��fghi�jklmn�o�pqr�s�t�u��vwxy�z�',
26
dansk => 'ABCDEFGHIJKLMNOPQRSTUVWXYZ���abcdefghijklmnopqrstuvwxyz���',
27
deutsch => 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz�������',
28
greek => '�������������������������������������������������������������������',
29
french => 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz����������������������������������������',
30
magyar => 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz���������������������������������������������~��',
31
polski => 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz����󶼿��ʣ�Ӧ��',
32
polish => 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz����󶼿��ʣ�Ӧ��',
33
spanish => 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz��������������',
34
ukrainian => '����������ȧƦ�������֤����������\'�������������������������������',
35
);
36
}
37
38
use vars qw (%memdic); # static dic in mem :)
39
if (!$memdic{a}) {
40
foreach (qw(
41
a an the this that one any none these those other another
42
who what which when where why how
43
i you he she it me him her my your his its whose
44
am is are do does have has was were did had
45
being doing having been done
46
will would shall should may might can could able unable
47
as if then since because so though however even anyway
48
at on of to by in out for from over back under through just
49
among between both all now begin end here there last next
50
ok yes not no too either neither more less and or
51
jan feb mar apr may jun jul aug sep oct nov dec
52
mon tue wed thr fri sat sun today week time
53
origional subject try tried found best regards thanks thank
54
write wrote send sent reply replied forward forwarded
55
email icq msn url web tel mobile ext eg mr dear
56
http https ftp nntp smtp mime nfs html xml sgml mailto
57
freebsd linux solaris gnu gpl bsd openwebmail webmail
58
)) { $memdic{$_}=1;}
59
}
60
61
use vars qw($SCRIPT_DIR);
62
if ( $0 =~ m!^(\S*)/[\w\d\-\.]+\.pl! ) { $SCRIPT_DIR=$1 }
63
if ($SCRIPT_DIR eq '' && open(F, '/etc/openwebmail/openwebmail_path.conf')) {
64
$_=<F>; close(F); if ( $_=~/^(\S*)/) { $SCRIPT_DIR=$1 }
65
}
66
if ($SCRIPT_DIR eq '') { print "Content-type: text/html\n\nSCRIPT_DIR not set in /etc/openwebmail/openwebmail_path.conf !\n"; exit 0; }
67
push (@INC, $SCRIPT_DIR);
68
69
foreach (qw(ENV BASH_ENV CDPATH IFS TERM)) {delete $ENV{$_}}; $ENV{PATH}='/bin:/usr/bin'; # secure ENV
70
umask(0002); # make sure the openwebmail group can write
71
72
use strict;
73
use Fcntl qw(:DEFAULT :flock);
74
use CGI qw(-private_tempfiles :standard);
75
use CGI::Carp qw(fatalsToBrowser carpout);
76
use IPC::Open3;
77
78
require "modules/dbm.pl";
79
require "modules/suid.pl";
80
require "modules/filelock.pl";
81
require "modules/tool.pl";
82
require "modules/datetime.pl";
83
require "modules/lang.pl";
84
require "modules/htmltext.pl";
85
require "auth/auth.pl";
86
require "quota/quota.pl";
87
require "shares/ow-shared.pl";
88
89
# common globals
90
use vars qw(%config %config_raw);
91
use vars qw($thissession);
92
use vars qw($domain $user $userrealname $uuid $ugid $homedir);
93
use vars qw(%prefs %style);
94
95
# extern vars
96
use vars qw(%lang_text %lang_err); # defined in lang/xy
97
98
########## MAIN ##################################################
99
openwebmail_requestbegin();
100
$SIG{PIPE}=\&openwebmail_exit; # for user stop
101
$SIG{TERM}=\&openwebmail_exit; # for user stop
102
$SIG{CHLD}='IGNORE'; # avoid zombies
103
104
userenv_init();
105
106
if (!$config{'enable_webmail'} || !$config{'enable_spellcheck'}) {
107
openwebmailerror(__FILE__, __LINE__, "$lang_text{'spellcheck'} $lang_err{'access_denied'}");
108
}
109
110
# whether we are checking a html
111
my $htmlmode = param('htmlmode');
112
113
my $form = param('form')||'';
114
my $field = param('field')||'';
115
my $dictionary = param('dictionary') || $prefs{'dictionary'} || 'english';
116
my $dicletters=$dictionary_letters{'english'};
117
$dicletters=$dictionary_letters{$dictionary} if (defined($dictionary_letters{$dictionary}));
118
119
my $spellbin=(split(/\s+/, $config{'spellcheck'}))[0];
120
if (! -x $spellbin) {
121
openwebmailerror(__FILE__, __LINE__, "Spellcheck is not available.<br>( $spellbin not found )");
122
}
123
124
if (defined(param('string'))) {
125
my ($wordcount, $wordframe, @words)=text2words($htmlmode, param('string')||'', $dicletters);
126
my ($wordshtml, $error)=spellcheck_words2html($htmlmode, $wordcount, \$wordframe, \@words, $dictionary);
127
docheckform($htmlmode, $form, $field, $dictionary, $wordshtml, $error, $wordcount, $wordframe);
128
129
} elsif (defined(param('checkagainbutton'))) {
130
my ($wordcount, $wordframe, @words)=cgiparam2words();
131
my ($wordshtml, $error)=spellcheck_words2html($htmlmode, $wordcount, \$wordframe, \@words, $dictionary);
132
docheckform($htmlmode, $form, $field, $dictionary, $wordshtml, $error, $wordcount, $wordframe);
133
134
} elsif (defined(param('finishcheckingbutton'))) {
135
my ($wordcount, $wordframe, @words)=cgiparam2words();
136
spellcheck_words2html($htmlmode, $wordcount, \$wordframe, \@words, $dictionary); # for updating pdict
137
my $finalstring=words2text(\$wordframe, \@words, $dicletters);
138
finalform($form, $field, $finalstring);
139
140
} elsif (defined(param('editpdictbutton'))) {
141
editpdict(param('dictword2delete')||'', $dictionary);
142
143
} else {
144
httpprint([], [htmlheader(), "What the heck? Invalid input for Spellcheck!", htmlfooter(1)]);
145
}
146
147
openwebmail_requestend();
148
########## END MAIN ##############################################
149
150
########## CGI FORM ROUTINES #####################################
151
sub docheckform {
152
my ($htmlmode, $formname, $fieldname, $dictionary,
153
$wordshtml, $error, $wordcount, $wordframe) = @_;
154
my $escapedwordframe;
155
local $_;
156
157
my ($html, $temphtml);
158
$html = applystyle(readtemplate("spellcheck.template"));
159
160
# $html =~ s/\@\@\@FORMNAME\@\@\@/$formname/;
161
# $html =~ s/\@\@\@FIELDNAME\@\@\@/$fieldname/;
162
$html =~ s/\@\@\@DICTIONARY\@\@\@/$dictionary/;
163
$html =~ s/\@\@\@WORDSHTML\@\@\@/$wordshtml/;
164
165
$temphtml = startform(-action=>"$config{'ow_cgiurl'}/openwebmail-spell.pl",
166
-name=>'spellcheck') .
167
ow::tool::hiddens(sessionid=>$thissession,
168
htmlmode=>$htmlmode,
169
form=>$formname,
170
field=>$fieldname,
171
dictionary=>$dictionary,
172
wordcount=>$wordcount,
173
wordframe=>ow::tool::escapeURL($wordframe));
174
$html =~ s/\@\@\@STARTSPELLCHECKFORM\@\@\@/$temphtml/;
175
176
if ( defined(param('checkagainbutton')) ) {
177
$temphtml = button(-name=>'backbutton',
178
-value=>$lang_err{'back'},
179
-onclick=>'window.history.back();',
180
-override=>'1');
181
} else { # first time check, no history to back
182
$temphtml = "";
183
}
184
if ($error>0) {
185
$temphtml .= "&nbsp;&nbsp;" if (defined(param('checkagainbutton')));
186
$temphtml .= submit(-name=>'checkagainbutton',
187
-value=>$lang_text{'checkagain'},
188
-override=>'1');
189
}
190
$html =~ s/\@\@\@CHECKAGAINBUTTON\@\@\@/$temphtml/;
191
192
$temphtml = submit(-name=>'finishcheckingbutton',
193
-value=>$lang_text{'finishchecking'},
194
-override=>'1');
195
$html =~ s/\@\@\@FINISHCHECKINGBUTTON\@\@\@/$temphtml/;
196
197
$temphtml = button(-name=>'editpdictbutton',
198
-value=>$lang_text{'editpdict'},
199
-onclick=>"window.open('$config{'ow_cgiurl'}/openwebmail-spell.pl?editpdictbutton=yes&amp;dictionary=$dictionary&amp;sessionid=$thissession','_personaldict','width=300,height=350,resizable=yes,menubar=no,scrollbars=yes');",
200
-override=>'1');
201
$html =~ s/\@\@\@EDITPERSDICTIONARYBUTTON\@\@\@/$temphtml/;
202
203
$temphtml = button(-name=>'cancelbutton',
204
-value=>$lang_text{'cancel'},
205
-onclick=>'window.close();',
206
-override=>'1');
207
$html =~ s/\@\@\@CANCELBUTTON\@\@\@/$temphtml/;
208
209
$temphtml = end_form();
210
$html =~ s/\@\@\@ENDFORM\@\@\@/$temphtml/;
211
212
httpprint([], [htmlheader(), $html, htmlfooter(2)]);
213
}
214
215
216
sub finalform {
217
my ($formname, $fieldname, $finalstring) = @_;
218
219
# since jscript has problem in unescape doublebyte char string,
220
# we only escape " to !QUOT! and unescape in jscript by RegExp
221
$finalstring=~s/"/!QUOT!/g;
222
223
print qq|Content-type: text/html
224
225
<html>
226
<head>
227
<meta HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=$prefs{'charset'}">
228
</head>
229
<body>
230
<form name="spellcheck">
231
<input type="hidden" name="finalstring" value="$finalstring">
232
</form>
233
<script language="JavaScript">
234
<!--
235
updateclose();
236
237
function updateclose()
238
{
239
var quot = new RegExp("!QUOT!","g");
240
241
//document.spellcheck.finalstring.value=unescape(document.spellcheck.finalstring.value);
242
// unescape !QUOT! to "
243
document.spellcheck.finalstring.value=(document.spellcheck.finalstring.value.replace(quot,'"'));
244
window.opener.document.$formname.$fieldname.value=document.spellcheck.finalstring.value;
245
window.opener.bodysethtml();
246
window.close();
247
}
248
//-->
249
</script>
250
</body></html>|;
251
return;
252
}
253
254
255
sub editpdict {
256
my ($dictword2delete, $dictionary) = @_;
257
local $_;
258
259
my $html= applystyle(readtemplate("editdictionary.template"));
260
my $temphtml = "";
261
262
# use same pdicfile path as spellchecker default
263
my $pdicname=$config{'spellcheck_pdicname'}; $pdicname=~s/\@\@\@DICTIONARY\@\@\@/$dictionary/;
264
my $pdicfile=ow::tool::untaint("$homedir/$pdicname");
265
266
if (-f $pdicfile) {
267
if ($dictword2delete) {
268
my $pdicwordstr="";
269
open(PERSDICT, $pdicfile) or
270
openwebmailerror(__FILE__, __LINE__, "Couldn't open personal dictionary $pdicfile! ($!)");
271
while (<PERSDICT>) {
272
chomp($_);
273
next if ($_ eq $dictword2delete);
274
$pdicwordstr.="$_\n";
275
}
276
close(PERSDICT);
277
278
open(NEWPERSDICT,">$pdicfile.new") or
279
openwebmailerror(__FILE__, __LINE__, "Couldn't open personal dictionary $pdicfile! ($!)");
280
print NEWPERSDICT $pdicwordstr;
281
close(NEWPERSDICT);
282
283
rename($pdicfile, "$pdicfile.bak");
284
rename("$pdicfile.new", $pdicfile);
285
}
286
287
my $count = 1;
288
my $bgcolor = $style{"tablerow_light"};
289
290
open(PERSDICT, $pdicfile) or
291
openwebmailerror(__FILE__, __LINE__, "Couldn't open personal dictionary $pdicfile! ($!)");
292
while (<PERSDICT>) {
293
my $dictword = $_;
294
chomp($dictword);
295
next if ($count==1 and $dictword=~m/personal_ws/); # past aspell's first line
296
297
$bgcolor=($style{"tablerow_dark"},$style{"tablerow_light"})[$count%2];
298
$temphtml .= qq|<tr><td bgcolor=$bgcolor>$dictword</td>\n<td bgcolor=$bgcolor align=center>|.
299
button(-name=>'dictword2delete',
300
-value=>$lang_text{'delete'},
301
-onclick=>"window.location.href='$config{ow_cgiurl}/openwebmail-spell.pl?editpdictbutton=yes&amp;dictword2delete=$dictword&amp;sessionid=$thissession';",
302
-class=>"medtext",
303
-override=>'1').
304
qq|</td></tr>\n|;
305
$count++;
306
}
307
close(PERSDICT);
308
}
309
$html =~ s/\@\@\@DICTIONARYWORDS\@\@\@/$temphtml/;
310
311
$temphtml = startform(-action=>"$config{'ow_cgiurl'}/openwebmail-spell.pl",
312
-name=>'spellcheck').
313
ow::tool::hiddens($lang_text{'editpdict'}=>'yes',
314
sessionid=>$thissession,
315
dictionary=>$dictionary);
316
$html =~ s/\@\@\@STARTFORM\@\@\@/$temphtml/;
317
318
$temphtml = button(-name=>'closebutton',
319
-value=>$lang_text{'close'},
320
-onclick=>'window.close();',
321
-override=>'1');
322
$html =~ s/\@\@\@CLOSEBUTTON\@\@\@/$temphtml/;
323
324
$temphtml = end_form();
325
$html =~ s/\@\@\@ENDFORM\@\@\@/$temphtml/;
326
327
httpprint([], [htmlheader(), $html, htmlfooter(0)]);
328
}
329
330
331
########## TEXT SPLIT/JOIN #######################################
332
# $wordframe is a rough structure of the original text, containing no word in it.
333
# words of the orgignal text are put into @words.
334
# text -> $wordframe and @words
335
sub text2words {
336
my ($htmlmode, $text, $dicletters)[email protected]_;
337
# init don't care term, reduce words passed to spellchecker
338
my $ignore="they'll we'll you'll she'll he'll i'll ".
339
"they've we've you've I've ".
340
"can't couldn't won't wouldn't shouldn't ".
341
"don't doesn't didn't hasn't hadn't ".
342
"isn't wasn't aren't weren't ";
343
344
# put url to ignore
345
foreach my $word ($text=~m![A-Za-z]+tp://[A-Za-z\d\.]+!ig) {
346
$ignore.=" $word";
347
}
348
# put email to ignore
349
foreach my $word ($text=~m![A-Za-z\d]+\@[A-Za-z\d]+!ig) {
350
$ignore.=" $word";
351
}
352
# put FQDN to ignore
353
foreach my $word ($text=~m![A-Za-z\d\.]+\.(?:com|org|edu|net|gov)[A-Za-z\d\.]*!ig) {
354
$ignore.=" $word";
355
}
356
357
my $wordframe=$text;
358
my $wordcount=0;
359
my @words=();
360
my %wordnums=();
361
362
if ($htmlmode) { # escape html tag so they won't be spellchecked
363
my $tagcount=0;
364
my @tags=();
365
$wordframe=~s/(<[^\<\>]*?>|&nbsp;|&amp;|&quot;|&gt;|&lt;|&#\d\d+;)/_tag2label($1, \$tagcount, \@tags)/ige;
366
$wordframe=~s/([$dicletters][$dicletters\-]*[$dicletters])|(~~[$dicletters][$dicletters\-]*[$dicletters])/_word2label($1, $ignore, \$wordcount, \@words, \%wordnums)/ge;
367
$wordframe=~s/%%TAG(\d+)%%/$tags[$1]/g;
368
} else {
369
$wordframe=~s/([$dicletters][$dicletters\-]*[$dicletters])|(~~[$dicletters][$dicletters\-]*[$dicletters])/_word2label($1, $ignore, \$wordcount, \@words, \%wordnums)/ge;
370
}
371
return($wordcount, $wordframe, @words);
372
}
373
374
sub _tag2label {
375
my ($tag, $r_tagcount, $r_tags)[email protected]_;
376
my $label='%%TAG'.${$r_tagcount}.'%%';
377
${$r_tags}[${$r_tagcount}]=$tag;
378
${$r_tagcount}++;
379
return($label);
380
}
381
382
sub _word2label {
383
my ($word, $wordignore, $r_wordcount, $r_words, $r_wordnums)[email protected]_;
384
return($word) if ($memdic{lc($word)} || $wordignore=~/\Q$word\E/i ||
385
$word =~/^WORD/ || $word =~/^TAG/);
386
return('%%WORD'.${$r_wordnums}{$word}.'%%') if (defined(${$r_wordnums}{$word}));
387
388
my $label='%%WORD'.${$r_wordcount}.'%%';
389
${$r_words}[${$r_wordcount}]=$word;
390
${$r_wordnums}{$word}=${$r_wordcount};
391
${$r_wordcount}++;
392
return($label);
393
}
394
395
# cgi param -> $wordframe and @words
396
sub cgiparam2words {
397
my $wordframe=ow::tool::unescapeURL(param('wordframe'))||'';
398
my $wordcount=param('wordcount')||0;
399
my @words=();
400
my %wordnums=();
401
402
my $newwordcount=0;
403
for (my $i=0; $i<$wordcount; $i++) {
404
if (defined(param($i))) {
405
my $word=param($i);
406
if (!defined($wordnums{$word})) {
407
$words[$i]=$word;
408
$wordnums{$word}=$i;
409
$newwordcount=$i+1;
410
} else {
411
# duplication found, replace WORD$i in wordframe with WORD$wordnums{$word}
412
$wordframe=~s/%%WORD$i%%/%%WORD$wordnums{$word}%%/g;
413
}
414
}
415
}
416
return($newwordcount, $wordframe, @words);
417
}
418
419
# rebuilt article from $wordframe and @words
420
sub words2text {
421
my ($r_wordframe, $r_words, $dicletters)[email protected]_;
422
423
my $text=${$r_wordframe};
424
$text=~s/%%WORD(\d+)%%/${$r_words}[$1]/g;
425
$text=~s/~~([$dicletters]*)/$1/g; # covert manualfix to origword
426
$text=~s/~!~([$dicletters]*)/$1/g; # covert addtodict to origword
427
return($text);
428
}
429
430
# spellcheck @words,
431
# put correct word back to word frame,
432
# and generate query html for incorrect word
433
sub spellcheck_words2html {
434
my ($htmlmode, $wordcount, $r_wordframe, $r_words, $dictionary)[email protected]_;
435
my $pdicname=$config{'spellcheck_pdicname'}; $pdicname=~s/\@\@\@DICTIONARY\@\@\@/$dictionary/;
436
my $pdicfile=ow::tool::untaint("$homedir/$pdicname");
437
438
# Below two is already done in userenv_init()
439
# chdir($homedir); # in case spellchecker write pdic in ./
440
# $ENV{'HOME'}=$homedir; # aspell/ispell refers this env to locate pdic file
441
# we pass pdicname instead of pdicfile
442
# because aspell won't work if it is fullpath?
443
444
my $spellcheck=$config{'spellcheck'};
445
$spellcheck=~s/\@\@\@DICTIONARY\@\@\@/$dictionary/;
446
$spellcheck=~s/\@\@\@PDICNAME\@\@\@/$pdicname/;
447
448
my ($stdout, $stderr)=pipeopen(split(/\s+/, $spellcheck));
449
if ($stdout!~/^\@\(#\)/ && $stderr=~/[^\s]/) {
450
pipeclose();
451
openwebmailerror(__FILE__, __LINE__, "Spellcheck error: $stderr");
452
}
453
454
my $html=${$r_wordframe};
455
if ($htmlmode) {
456
# remove html tage from wordframe
457
# so they won't be displayed during spellchecking
458
$html=ow::htmltext::html2text($html);
459
}
460
461
# conversion make text for happy html display
462
$html=~s/&/&amp;/g;
463
$html=~s/</&lt;/g;
464
$html=~s/>/&gt;/g;
465
$html=~s/\n/<BR>/g;
466
$html=~s/"/&quot;/g;
467
$html=~s/ /&nbsp;&nbsp;/g;
468
469
# find all words leading with ~!~, remove ~!~ and add them to pdict
470
my %pdicword=();
471
foreach (@{$r_words}) {
472
# check if leading with ~!~, replace with pure word
473
$pdicword{$_}=1 if (s/^~!~// );
474
}
475
my $spellcmd='';
476
foreach (keys %pdicword) {
477
$spellcmd.="*$_\n";
478
}
479
if ($spellcmd ne '') {
480
# add words to person dict
481
# the 2nd \n guarentees we have output in piperead
482
pipewrite($spellcmd."\#\n\n");
483
($stdout, $stderr)=piperead(2);
484
485
# it seems adding words to pdict doesn't generate output on aspell 0.50,
486
# so we comment out the result check here
487
# if ($stderr=~/[^\s]/) {
488
# pipeclose();
489
# openwebmailerror(__FILE__, __LINE__, "Spellcheck error: $stderr");
490
# }
491
}
492
493
my %dupwordhtml=();
494
my $error=0;
495
for (my $i=0; $i<$wordcount; $i++) {
496
my $word=${$r_words}[$i];
497
my $wordhtml='';
498
499
if (defined($dupwordhtml{$word})) { # different symbo with duplicate word
500
$wordhtml=$dupwordhtml{$word};
501
502
} elsif (defined($pdicword{$word})) { # words already put into pdic
503
$wordhtml=$dupwordhtml{$word}=$word;
504
505
} elsif ( $word=~/^~~/ ) { # check if manualfix
506
my $pureword=substr($word,2);
507
$wordhtml=qq|<input type="text" size="|.length($pureword).qq|" name="$i" value="$pureword">\n|;
508
$dupwordhtml{$word}=qq|<font color="#cc0000"><b>$pureword</b></font>|;
509
$error++;
510
511
} else { # word passed to spellchecker
512
my ($r) = spellcheck($word);
513
514
if ($r->{'type'} eq 'none' || $r->{'type'} eq 'guess') {
515
$wordhtml=qq|<select size="1" name="$i">\n|.
516
qq|<option>$word</option>\n|.
517
qq|<option value="~!~$word">--$lang_text{'addtodict'}--</option>\n|.
518
qq|<option value="~~$word">--$lang_text{'manuallyfix'}--</option>\n|.
519
qq|</select>\n|;
520
$dupwordhtml{$word}=qq|<font color="#0000cc"><b>$word</b></font>|;
521
$error++;
522
523
} elsif ($r->{'type'} eq 'miss') {
524
$wordhtml=qq|<select size="1" name="$i">\n|.
525
qq|<option>$word</option>\n|.
526
qq|<option value="~!~$word">--$lang_text{'addtodict'}--</option>\n|.
527
qq|<option value="~~$word">--$lang_text{'manuallyfix'}--</option>\n|;
528
foreach my $sugg (@{$r->{'misses'}}) {
529
$wordhtml.=qq|<option>$sugg</option>\n|;
530
}
531
$wordhtml.=qq|</select>\n|;
532
$dupwordhtml{$word}=qq|<font color="#0000cc"><b>$word</b></font>|;
533
$error++;
534
535
} else { # type= ok, compound, root
536
$wordhtml=$dupwordhtml{$word}=$word;
537
}
538
539
}
540
541
# remove the word from wordframe if it is an okay word
542
${$r_wordframe}=~s/%%WORD$i%%/$word/g if ($word eq $wordhtml);
543
544
$html=~s/%%WORD$i%%/$wordhtml/;
545
$html=~s/%%WORD$i%%/$dupwordhtml{$word}/g;
546
}
547
548
pipeclose();
549
550
return($html, $error);
551
}
552
553
########## SPELLCHECK ############################################
554
sub spellcheck {
555
my $word = $_[0]; $word =~ s/[\r\n]//g;
556
return ({'type'=>'ok'}) if ($word eq "");
557
558
my %types = (
559
# correct words:
560
'*' => 'ok',
561
'-' => 'compound',
562
'+' => 'root',
563
# misspelled words:
564
'#' => 'none',
565
'&' => 'miss',
566
'?' => 'guess',
567
);
568
my %modisp = (
569
'root' => sub {
570
my $h = shift;
571
$h->{'root'} = shift;
572
},
573
'none' => sub {
574
my $h = shift;
575
$h->{'original'} = shift;
576
$h->{'offset'} = shift;
577
},
578
'miss' => sub { # also used for 'guess'
579
my $h = shift;
580
$h->{'original'} = shift;
581
$h->{'count'} = shift; # count will always be 0, when $c eq '?'.
582
$h->{'offset'} = shift;
583
my @misses = splice @_, 0, $h->{'count'};
584
my @guesses = @_;
585
$h->{'misses'} = \@misses;
586
$h->{'guesses'} = \@guesses;
587
},
588
);
589
$modisp{'guess'} = $modisp{'miss'}; # same handler.
590
591
my ($stdout, $stderr, @commentary, @results);
592
593
pipewrite("!\n^$word\n");
594
($stdout, $stderr)=piperead();
595
if ($stderr=~/[^\s]/) {
596
pipeclose();
597
openwebmailerror(__FILE__, __LINE__, "Spellcheck error: $stderr");
598
}
599
600
foreach (split(/\n/, $stdout)) {
601
last unless $_ gt '';
602
push (@commentary, $_) if ( /^[\+\-\*\?\s\|#&]/ );
603
}
604
605
for my $i (0 .. $#commentary) {
606
my %h = ('commentary' => $commentary[$i]);
607
my @tail; # will get stuff after a colon, if any.
608
609
if ($h{'commentary'} =~ s/:\s+(.*)//) {
610
my $tail = $1;
611
@tail = split /, /, $tail;
612
}
613
614
my($c,@args) = split ' ', $h{'commentary'};
615
my $type = $types{$c} || 'unknown';
616
$modisp{$type} and $modisp{$type}->( \%h, @args, @tail );
617
$h{'type'} = $type;
618
$h{'term'} = $h{'original'};
619
push @results, \%h;
620
}
621
return $results[0];
622
}
623
624
########## PIPE ROUTINES... ######################################
625
# local globals
626
use vars qw(*spellIN *spellOUT *spellERR);
627
use vars qw($mypid $pipepid $piperun $pipeexit $pipesig);
628
$mypid=$$;
629
sub pipeopen {
630
my @cmd=@_; foreach (@cmd) { (/^(.*)$/) && ($_=$1) }; # untaint all argument
631
local $|=1; # flush CGI related output in parent
632
($piperun, $pipeexit, $pipesig)=(1,0,0);
633
$SIG{CHLD}=sub { wait; $pipeexit=$?>>8; $pipesig=$?&255; $piperun=0; };
634
eval { $pipepid = open3(\*spellIN, \*spellOUT, \*spellERR, @cmd); };
635
if ([email protected]) { # open3 return err only in child
636
if ($$!=$mypid){ # child
637
print STDERR [email protected]; # pass [email protected] to parent through stderr pipe
638
exit 9; # terminated
639
}
640
}
641
return(piperead());
642
}
643
644
sub piperead {
645
my $timeout=$_[0]; $timeout=10 if ($timeout<=0);
646
647
my ($stdout, $stderr, $retry)=('', '', 0);
648
while (1) {
649
my ($rin, $rout, $ein, $eout)=('','','','');
650
vec($rin, fileno(\*spellOUT), 1) = 1;
651
vec($rin, fileno(\*spellERR), 1) = 1;
652
$ein=$rin;
653
654
# timeout is changed to 0.001 once any data in
655
my $n=select($rout=$rin, undef, $eout=$ein, $timeout);
656
657
if ($n>0) { # fd is ready for reading
658
my ($o, $e, $buf)=(-1, -1, '');
659
if (vec($rout,fileno(\*spellOUT),1)) {
660
$o=sysread(\*spellOUT, $buf, 65536);
661
if ($o>0) { $stdout.=$buf; $timeout=0.001; }
662
}
663
if (vec($rout,fileno(\*spellERR),1)) {
664
$e=sysread(\*spellERR, $buf, 65536);
665
if ($e>0) { $stderr.=$buf; $timeout=0.001; }
666
}
667
last if ($o==0 && $e==0); # os ensure there is no more data to read
668
669
} elsif ($n==0) { # read timeout
670
if ($stdout=~/\n/||$stderr=~/\n/) { # data line already in
671
last;
672
} elsif ($stdout eq "" && $stderr eq "") { # 1st read timeout
673
$stderr="piperead nothing"; last;
674
} # else continue to read until line
675
676
} else { # n<0, read err => child dead?
677
$stderr="piperead error $n"; last;
678
}
679
680
if ($retry++>100) {
681
$stderr="piperead too many retries"; last;
682
}
683
}
684
685
if (!$piperun) {
686
$stderr="terminated abnormally" if ($stderr eq "");
687
$stderr.=" (exit $pipeexit, sig $pipesig)";
688
}
689
690
return ($stdout, $stderr);
691
}
692
693
sub pipewrite {
694
print spellIN $_[0];
695
}
696
697
sub pipeclose {
698
close spellIN; close spellOUT; close spellERR;
699
}
700