#!/usr/bin/perl use strict; use utf8; use CGI::Carp qw/fatalsToBrowser/; BEGIN { require 'common.pl' } require Encode; my $max_result = 100; sub decode_url ($) { my $s = shift; $s =~ tr/+/ /; $s =~ s/%([0-9A-Fa-f]{2})/pack 'C', hex $1/ge; return Encode::decode ('utf-8', $s); } # decode_url sub encode_url ($) { my $s = Encode::encode ('utf-8', shift); $s =~ s/([^0-9A-Za-z_~.-])/sprintf '%%%02X', ord $1/g; return $s; } # encode_url sub htescape ($) { my $s = shift; $s =~ s/&/&/g; $s =~ s//>/g; $s =~ s/"/"/g; return $s; } # htescape my $param = {}; for (split /[&;]/, $ENV{QUERY_STRING} || '') { my ($name, $value) = split /=/, $_, 2; $param->{decode_url ($name)} = decode_url ($value); } my $suffix_patterns = { ku => qr/(?>[かこきいっくけ])/, su => qr/(?>[さそしすせ])/, tsu => qr/(?>[たとちっつて])/, nu => qr/(?>[なのにんぬね])/, mu => qr/(?>[まもみんむめ])/, ru => qr/(?>[らろりっるれ])/, u => qr/(?>[わおいっうえ])/, gu => qr/(?>[がごぎいぐげ])/, bu => qr/(?>[ばぼびんぶべ])/, ichidan => qr/(?>[るれろよ])?/, kuru => qr/(?>[るれい])?/, suru => qr/(?>す[るれ]|しろ?|せよ?|さ)?/, i => qr/(?>か[ろっ]|く|い|けれ|う)?/, ## BUG: ありがたい -> ありがとう da => qr/(?>だ[ろっ]?|で|に|なら?)?/, dasuru => qr/(?>だ[ろっ]?|で|に|なら?|す[るれ]|しろ?|せよ?|さ)?/, }; my $eword = htescape $param->{word}; my @pattern; my %tag; for (split /\s+/, $param->{word}) { if (s/^tag://) { $tag{$_} = 1; } else { my $pattern = quotemeta normalize $_; $pattern =~ s/\\-/[- ]/g; unless ($param->{cs}) { $pattern =~ s/([A-Za-z])/'[' . uc ($1) . lc ($1) . ']'/ge; } my $suffix_pattern = $suffix_patterns->{$param->{suffix}} || qr//; $pattern =~ s/$suffix_pattern$//; $pattern .= $suffix_pattern; $pattern = '\b' . $pattern . '\b' if $param->{aw}; push @pattern, $pattern; } } $|=1; print qq[Content-Type: text/html ; charset=utf-8 Search result for "$eword"

Search result for "$eword"

]; print_input_form (); unless (check_match ({en => '', ja => '', tags => []})) { print q[
]; my $has_match; for_each_entry_set (sub ($) { my (undef, $entries) = @_; $has_match |= print_matches ($entries); }, 1); if ($param->{fb}) { $has_match |= print_matches ({exact => get_fallback_entries ()}); } unless ($has_match) { print q[

No match found.

]; } else { print q[]; print_input_form (); } } exit; sub check_match ($) { my ($entry) = @_; for my $tag (keys %tag) { F: { for (@{$entry->{tags} or []}) { last F if $_ eq $tag; } return 0; } # F } for my $pattern (@pattern) { if ($entry->{en} =~ /$pattern/ or $entry->{ja} =~ /$pattern/) { # } else { return 0; } } return 1; } # check_match sub print_matches ($) { my ($entries) = @_; use feature 'state'; state $result //= 0; my $has_match; my %en2ja = (%{$entries->{exact} or {}}, %{$entries->{pattern} or {}}); for (keys %en2ja) { if (check_match ($en2ja{$_})) { $has_match = 1; print '' unless $result; print ''. get_match_text ($_, $en2ja{$_}); ++$result; # print q[
...] and last if ++$result == $max_result; } } return $has_match; } # print_matches sub get_match_text ($$) { my $hash = shift; my $entry = shift; ## NOTE: Marking will not work well if it contains &, <, >, or ", or ## the pattern matches with charrefs, e.g. "t" (part of < and "). my $r = q[
]; my $v = htescape ($entry->{en}); for my $pattern (@pattern) { $v =~ s[($pattern)][$1]g; } $v =~ s[(<[\s\S]+?>)][$1]g; $v =~ s[(&[#0-9A-Za-z]+;)][$1]g; $v =~ s[\*][*]g; $r .= $v; $r .= q[]; my $v = htescape ($entry->{ja}); for my $pattern (@pattern) { $v =~ s[($pattern)][$1]g; } $v =~ s[(<[\s\S]+?>)][$1]g; $v =~ s[(&[#0-9A-Za-z]+;)][$1]g; $v =~ s{(\[\[[^\[\]]+\]\])}[$1]g; $v =~ s[(\$[0-9]+)][$1]g; $r .= $v; $r .= q[]; $r .= join ' ', map { ($tag{$_} ? '' : '') . '' . htescape ($_) . '' . ($tag{$_} ? '' : '') } @{$entry->{tags} or []}; return $r; } # get_match_text sub print_input_form () { print qq[
]; print qq[

]; print qq[]; print qq[]; print qq[

]; print qq[

]; } # print_input_form