#!/usr/local/bin/perl -Tw
my $title = '「リサーチ」ちゃいまんねん「レ・サーチ」でんねん';
my @dictionaries = (
'./research.dic',
'./foo.dic',
'./bar.dic',
);
my $history = './research.hst'; # あってもなくても OK
my $sample = './research.spl'; # 通常使用時は空文字列にしてください。
my $filemode = 0600;
my $max_history = 10;
my $max_lines = 1000;
my $word_length = 1024;
my $word_delete = 1;
my $timeout = 10;
my $regexp_error = 1;
my $charset = 'Shift_JIS';
my $css = '.search b { background-color:yellow } .notice { font-size:80%; list-style:none; }';
my @colors = (
['blue', '#ddddff'],
['green', '#ddffdd'],
['red', '#ffdddd'],
['gray', '#dddddd'],
);
my @favorites = (
'h?ttps?://[\w.-]+(/[\x21\x23-\x3b\x3d\x3f-\x7e]*)?',
'[\w.-]+@[\w.-]+',
'(?<=</b>)◆[\x21-\x7e]{8,10}',
'(?<=\d{2}:\d{2}:\d{2}\s)ID:[\x21-\x3e\x40-\x7e]+?(?=<>)',
'【種別】\s*[^<]+',
'【条件】\s*[^<]+',
'【言語】\s*[^<]*?perl[^<]*',
'【言語】\s*[^<]*?php[^<]*',
'【言語】\s*[^<]*?(?:perl|php)[^<]*',
'^(?#小出しにしないで全部表示しる！)',
);
# 設定終わり
# ファイル更新時に *.tmp を作成・削除するので注意してください。
use CGI qw/:standard -no_xhtml -nosticky/;
use Encode qw/from_to/;
my @history;
#@dictionaries = grep -f, @dictionaries;
my $dict = param('dict') || 0;
$dict = $dict =~ /^(\d{1,8})$/ ? $1 % @dictionaries : 0;
my @mode = (
['key', ' 検 索 ', ''],
['word', ' 追 加 ', ''],
['del0', '削除確認', ''],
['del0', '削除実行', 'readonly'],
);
unless ($word_delete) {
for (my $i = 0; $i < @mode; $i++) {
if ($mode[$i][0] eq 'del0') {
splice @mode, $i, 1;
$i--;
}
}
}
my $mode = param('mode') || 0;
$mode = $mode =~ /^(\d{1,2})$/ ? $1 % @mode : 0;
my $obj = new Re;
$obj->from($charset);
$obj->to('utf8');
$obj->len(64);
my($re, @errors) = $obj->create_re(param('key'));
my @del;
if ($mode[$mode][0] eq 'del0') {
if ($del[0] = $obj->create_re(param('del0'))) {
$del[1] = substr scalar(param('del1')) || '', 0, 8192;
$re = $del[0];
$mode = $#mode;
}
}
print header(-charset => $charset),
start_html(
-lang => 'ja',
-title => $title,
-head => [
meta({
-http_equiv => 'Content-Style-Type',
-content => 'text/css'
}),
style({-type => 'text/css'}, comment($css))
],
),
start_form(-method => 'get', action => 'research.cgi'),
popup_menu(
-name => 'dict',
-values => [0..$#dictionaries],
-labels => {map { $_ => ($dictionaries[$_] =~ /([^\\\/]+)$/)[0] } 0..$#dictionaries},
-attributes => {map { -f $dictionaries[$_] ? () : ($_ => {-disabled => 'disabled'}) } 0..$#dictionaries}
),
hidden(-name => 'mode', -value => $mode),
textfield(-name => $mode[$mode][0], -style => "background-color:$colors[$mode][1]", $mode[$mode][2]),
submit(-value => $mode[$mode][1]),
' ',
a({-href => "research.cgi?dict=$dict&mode=" . (($mode + 1) % @mode)}, font({-color => $colors[$mode][0]}, 'モード')),
length $sample ? copy($sample, $dictionaries[0], defined param('sample')) : (),
defined $del[0] ? hidden(-name => 'del1', -value => urlencode($del[0])) : (),
end_form,
$regexp_error && @errors ? ul(li([map escapeHTML($_), '正規表現にエラーがあったため検索しませんでした。', @errors])) : ();
local $SIG{'ALRM'} = sub {
print p(strong("$timeout秒"), 'を超えたため強制終了しました。');
exit;
};
if ($timeout) {
eval { alarm $timeout };
}
if (defined $del[0] and defined $del[1] and urlencode($del[0]) eq $del[1]) {
my $success;
my $lines = 0;
if (open my $in, "< $dictionaries[$dict]") {
eval { flock $in, 2 };
if ($success = open my $out, "> $dictionaries[$dict].tmp") {
read $in, my $bom, 3;
if (defined $bom and $bom eq "\xef\xbb\xbf") {
$success = print $out $bom;
} else {
$success = seek $in, 0, 0;
}
my $re = $del[0];
while (<$in>) {
if (/$re/) {
$lines++;
} elsif (!print $out $_) {
undef $success;
last;
}
}
$success = close $out && $success;
}
$success = close $in && $success;
$success &&= rename "$dictionaries[$dict].tmp", $dictionaries[$dict];
}
if ($success) {
my $pattern = escapeHTML('' . $del[0]);
from_to($pattern, 'utf8', $charset);
print p(i('削除結果:'), strong($pattern), 'にマッチした行を', strong("$lines行"), '削除しました。');
} else {
print p(i('削除結果:'), '削除に失敗しました。');
}
}
if (defined(my $word = param('word'))) {
($word = substr $word, 0, $word_length) =~ tr/\x20-\x7e\x80-\xff//cd;
$word =~ s/^\s+//;
$word =~ s/\s+$//;
my $utf8_word = $word;
my $errormsg = '';
{
local $SIG{'__WARN__'} = sub { $errormsg .= join '', @_ };
from_to($utf8_word, $charset, 'utf8');
}
if (length $errormsg) {
warn $errormsg;
print p(strong(escapeHTML($word)), 'には UTF-8 に変換できない文字が入っているかもしれません。');
} elsif (length $utf8_word) {
if (open my $fh, "+< $dictionaries[$dict]") {
eval { flock $fh, 2 };
my $lines = 0;
my $duplication = 0;
while (<$fh>) {
chomp;
if ($_ eq $utf8_word) {
$duplication = 1;
last;
}
$lines++;
}
if ($max_lines <= $lines) {
print p('登録数が', strong($max_lines), 'を超えているため追加しませんでした。');
} elsif ($duplication) {
print p(strong(escapeHTML($word)), 'は重複しているため追加しませんでした。');
} elsif (print $fh "$utf8_word\n") {
print p(strong(escapeHTML($word)), 'を追加しました。');
} else {
print p(strong(escapeHTML($word)), 'の追加に失敗しました。');
}
close $fh;
} else {
print p(
'辞書ファイルに書き込めません。',
'ファイルが存在しているか、パーミッションが適切であるか確認してください。'
);
}
}
}
if (ref $re eq 'Regexp') {
my $found = 0;
my $lines = 0;
my @warnings;
if (open my $fh, "< $dictionaries[$dict]") {
read $fh, my $bom, 3;
unless (defined $bom and $bom eq "\xef\xbb\xbf") {
seek $fh, 0, 0;
}
print '<dl class="search">';
local $SIG{'__WARN__'} = sub { push @warnings, join '', @_ };
while (<$fh>) {
chomp;
my($html, $offset, $num) = ('', 0, 0);
while (/$re/g) {
my($len, $strlen) = (pos, length $&);
$html .= escapeHTML(substr $_, $offset, $len - $strlen - $offset);
if ($strlen) {
$html .= b(escapeHTML(substr $_, $len - $strlen, $strlen));
}
$offset = $len;
$num++;
}
if ($num) {
$html .= escapeHTML(substr $_, $offset);
$found += $num;
$lines++;
from_to($html, 'utf8', $charset);
print dt("$.行目"), dd($html);
}
if (16 <= @warnings) {
print dt('警告が多過ぎたため強制終了しました。');
last;
}
}
close $fh;
my $pattern = '' . $re;
from_to($pattern, 'utf8', $charset);
print '</dl>',
p(
i('検索結果:'),
strong(($dictionaries[$dict] =~ /([^\\\/]+)$/)[0]), 'を',
strong(escapeHTML($pattern)), 'で検索して',
strong("$lines行"), 'に',
strong("$found個"),
'見つかりました。'
);
@history = ($pattern =~ /:(.+)\)$/)[0] . "\n";
} else {
print p(
'辞書ファイルを読み込めません。',
'ファイルが存在しているか、パーミッションが適切であるか確認してください。'
);
}
if ($^W and @warnings) {
warn @warnings;
}
}
if (open my $fh, "+< $history") {
eval { flock $fh, 2 };
push @history, grep !defined $history[0] || $history[0] ne $_, <$fh>;
@history = splice @history, 0, $max_history;
if (seek $fh, 0, 0 and print $fh @history) {
truncate $fh, tell $fh;
}
close $fh;
chomp @history;
}
print ul(
{-class => 'notice'},
li('Perlで使用可能な正規表現で検索します。'),
li(i('検索結果'), 'が出ないときは検索語を変えてください。'),
li('常に行単位のマッチングです。丸読みしたファイルに対して m/pattern/mg を適用した場合と同等だと思えばいいかもしれません。'),
li({-title => '何でもありになってしまうので'}, '(?{ code }) はご利用いただけません。'),
$timeout ? li($timeout, '秒間の時間制限が有効になっています。') : (),
@favorites
? li(
dl(
dt({-title => '@favorites に登録してあるもの'}, '正規表現の例'),
array2dd($dict, @favorites)
)
)
: (),
@history
? li(
dl(
dt('みんなこんな感じで検索してるよ。'),
array2dd($dict, @history)
)
)
: (),
),
p({-style => 'color:teal'}, 'ReSearch'),
end_html;
chmod $filemode, $history, $sample, map { $_, "$_.tmp" } @dictionaries;
exit;
sub array2dd {
my $dict = shift;
dd(ol(li([map a({-href => "research.cgi?dict=$dict&mode=0&key=" . urlencode($_)}, escapeHTML($_)), @_])));
}
sub urlencode {
my $str = shift;
$str =~ s/([^\w.-])/uc '%' . unpack 'H2', $1/eg;
$str;
}
sub copy {
my($in_file, $out_file, $mode, $myself) = @_;
$myself ||= (__FILE__ =~ /([^\\\/]+)$/)[0];
my $buffer = 65535;
my $anchor = ' ';
if ($mode) {
if (open my $in, "< $in_file") {
binmode $in;
if (open my $out, "+< $out_file") {
eval { flock $out, 2 };
binmode $out;
my $data;
while (read $in, $data, $buffer) {
print $out $data;
}
truncate $out, tell $out;
close $out;
$anchor .= a({-href => $myself}, 'ファイルのコピー作業をしました。失敗していてもエラーは出ません。');
} else {
$anchor .= a({-href => $myself}, '出力ファイルが開けませんでした。');
}
close $in;
} else {
$anchor .= a({-href => $myself}, '入力ファイルが開けませんでした。');
}
} else {
$anchor .= a({-href => "$myself?sample=1"}, 'サンプルデータをコピー');
}
$anchor;
}
package Re;
use Encode qw/from_to/;
sub new { bless {} }
sub create_re {
my($self, $str) = @_;
compile_re(const_re(mb_convert_substr($str, @{$self}{qw/to from len/})));
}
sub const_re {
my $str = shift;
my $max_index = shift || 1;
my $pattern = '';
if (length $str) {
my @pattern = split / +/, $str, $max_index;
$pattern = 1 < @pattern ? join('|', map "($_)", @pattern) : $pattern[0];
}
$pattern;
}
sub compile_re {
my $pattern = shift;
my $re;
my @errors;
if (length $pattern) {
no re qw/taint eval debug/;
local $SIG{'__DIE__'} = sub { push @errors, @_ };
$re = eval 'qr/$pattern/i';
warn @errors if $^W and @errors;
}
wantarray ? ($re, @errors) : $re;
}
sub mb_convert_substr {
my($str, $to, $from, $len) = @_;
$str = '' unless defined $str;
$from ||= 'cp932';
$to ||= 'utf8';
$len = length $str unless defined $len;
$str = substr $str, 0, $len;
$str =~ tr/\x00-\x1f\x7f//d;
local $SIG{'__WARN__'} = sub {} unless $^W;
from_to($str, $from, $to);
$str;
}
sub AUTOLOAD {
my $self = shift;
if (our $AUTOLOAD =~ /::([a-z][0-9a-z]*)$/) {
$self->{$1} = shift;
}
$self;
}