Open MagicVox.net
ヘッダメニュー
|
MovableType から、はてなダイアリーキーワードへリンクを貼るプラグインは幾つか存在するようですが、折角に訪問頂いたビジターを外部コンテンツに安易に誘導することは少なからず勿体無い気がします。当サイトでは Tagwire plugin を使って独自にタグデータベースを蓄積していますので、これを上手に使って似たようなことができないでしょうか？
そこで、ビジターに一つでも多くの記事を参照してもらう機会を増やせるよう、はてなのキーワードリンクよろしく記事文中に現れた文字列に自動的にタグリンクを張れるようにしてみました。
package Regexp::TrieEUC;
;# original code from
;# mk_trie_regexp.pl,v 0.1 2005/09/10 20:19:44 dankogai
;# @see http://blog.livedoor.jp/dankogai/archives/50074802.html
;# copyright (c) 2005 Piroli YUKARINOMIYA. Some rights reserved.
;# @see http://www.magicvox.net/archive/2005/11051922.php
use strict;
use warnings;
use Jcode;
sub new{ bless {} => shift }
sub add{
my $self = shift;
my $str = shift;
my $ref = $self;
for my $char (Jcode->new($str)->euc
=~ /[x00-x7F]|[x8ExA1-xFE][xA1-xFE]|x8F[xA1-xFE][xA1-xFE]/og){
;# @see http://www.din.or.jp/~ohzaki/perl.htm#JP_Split
$ref->{$char} ||= {};
$ref = $ref->{$char};
}
$ref->{''} = 1;# as terminator
$self;
}
sub _regexp{
my $self = shift;
return if $self->{''} and scalar keys %$self == 1; # terminator
my (@alt, @cc);
my $q = 0;
for my $char (sort keys %$self){
my $qchar = quotemeta $char;
if (ref $self->{$char}){
if (defined (my $recurse = _regexp($self->{$char}))){
push @alt, $qchar . $recurse;
}else{
push @cc, $qchar;
}
}else{
$q = 1;
}
}
my $cconly = !@alt;
@cc and push @alt, @cc == 1 ? $cc[0] : '(?:'. join('|', @cc). ')';
my $result = @alt == 1 ? $alt[0] : '(?:' . join('|', @alt) . ')';
$q and $result = $cconly ? "$result?" : "(?:$result)?";
$result;
}
sub as_regexp{ my $str = shift->_regexp; qr/$str/ }
1;
MTTagsAsKeyword の処理については、再びDan Kogaiさん公開の Click'n Hatenizeを 大変参考にさせて頂きましたm(_ _)m ありがとうございます。
;# piroli++, '05/11/04
MT::Template::Context->add_tag('TagsAsRegexp' => &tags_as_regexp);
sub tags_as_regexp {
my ($ctx, $args) = @_;
;# retrieving parameters and set default values
# cutoff_score (0..100, default = 0)
my $tag_score = $args->{cutoff_score} || 0;
# cutoff_length (default = 0)
my $tag_length = $args->{cutoff_length} || 0;
# case_sensitive (0/1, default = 1)
my $case_sensitive = defined $args->{case_sensitive} ? $args->{case_sensitive} : 1;
;# add up tags
my $blog_id = $ctx->stash('blog_id');
my $data = get_pd_indexes($blog_id) || get_db_indexes($blog_id)
or return '';
my %tindex = %{$data->{tindex}};
my %tags = ();
my $most_tags_count = 1;
foreach (keys %tindex) {
my $t = $case_sensitive ? $_ : lc $_;
$tags{$t} += scalar @{$tindex{$_}->{eids}};
$most_tags_count = $tags{$t} if ($most_tags_count < $tags{$t});
}
;# create TRIE
use Regexp::TrieEUC;
my $trie = Regexp::TrieEUC->new;
foreach (keys %tags) {
$trie->add($_)
if $tag_length <= length
and $tag_score <= int (0.5 + $tags{$_} * 100 / $most_tags_count);
}
;# return as regular expression
'qr{'. $trie->as_regexp. '}';
}
MT::Template::Context->add_container_tag('TagsAsKeyword' => &tags_as_keyword);
sub tags_as_keyword {
my ($ctx, $args, $cond) = @_;
;# retrieving parameters and set default values
# repeat_count
my $kw_repeat = $args->{repeat_count} || 0;
# pattern
my $kw_pattern = $args->{keyword_pattern}
or $ctx->error('no keyword pattern is specified.');
;# retrieving the regexp pattern of keywords
my $re;
if (defined (my $regexp_file = $args->{regexp_file})) {
;# @see <$MTInclude file="..."$>
$re = MT::Template::Context::_hdlr_include (
$ctx, {'file' => $args->{regexp_file}}, $cond);
} elsif (defined (my $regexp_template = $args->{regexp_template})) {
;# you can use the file which is built with Index Template
;# @see <$MTLink template="..."$>
my $file_path = MT::Template::Context::_hdlr_link (
$ctx, {'template' => $args->{regexp_template}}, $cond);
my $site_url = $ctx->stash('blog')->site_url;
my $site_path = $ctx->stash('blog')->site_path;
$file_path =~ s/Q$site_urlE/$site_path//;
$file_path =~ s//+///g;
$re = do $file_path;
} elsif (defined (my $regexp_module = $args->{regexp_module})) {
;# it may be the performance issue when too many tags
;# but you can control this behaviour by parameters :)
;# @see <$MTInclude module="..."$>
$re = MT::Template::Context::_hdlr_include (
$ctx, {'module' => $args->{regexp_module}}, $cond);
} else {
;# it may be the performance issue when too many tags
;# and be called with using all args as default values :(
$re = eval tags_as_regexp ($ctx, $args);
}
$ctx->error('no regexp is specified.') if (! $re);
;# build contents within container tag
defined (my $content = $ctx->stash('builder')->build ($ctx, $ctx->stash ('tokens')))
or return $ctx->error ($ctx->errstr);
;# convert $content to EUC temporally because regexp is written in EUC
use Jcode;
my $j = jcode ($content);
my $original_charset = $j->icode;
$j->can("fallback") and $j->fallback (Jcode::FB_HTMLCREF());
$content = $j->euc;
;# should not keywordnize in these tags
my %ignore_tags = ();
map { $ignore_tags{lc $_} = 1; } split /,/, 'a,blockquote,pre,textarea';
defined $args->{ignore_tags}
and map { $ignore_tags{lc $_} = 1; } split /,/, $args->{ignore_tags};
defined $args->{apply_tags}
and map { $ignore_tags{lc $_} = 0; } split /,/, $args->{apply_tags};
;# Parse the $content for retrieving the text areas that should be given the keywords
my $output = '';
my $keywordnize = 0;
my %tags = ();
use HTML::Parser;
my $html_parser = HTML::Parser->new (
start_h => [ sub {
my ($tagname, $text) = @_;
$ignore_tags{$tagname} && $keywordnize++;
$output .= $text;
} => 'tagname,text'],
end_h => [ sub {
my ($tagname, $text) = @_;
0 < $keywordnize && $ignore_tags{$tagname} && --$keywordnize;
$output .= $text;
} => 'tagname,text'],
text_h => [ sub {
my ($text) = @_;
;# Replace the found keywords with $kw_pattern
if ($keywordnize == 0) {
$text =~ s{($re)}{
my $kw = $1;
if ($kw_repeat and $kw_repeat < ++$tags{$kw}) {
$kw;
} else {
use MT::Util;
my $pattern = $kw_pattern;
$pattern =~ s/%e/MT::Util::encode_url(Jcode::convert ($kw, $original_charset, 'euc'))/oge;
$pattern =~ s/%k/$kw/og;
MT::Util::decode_html ($pattern);
}
}egx;
}
$output .= $text;
} => 'text'],
default_h => [""]);
$html_parser->parse ($content);
$html_parser->eof;
;# return contents in the original charset
Jcode::convert ($output, $original_charset, 'euc');
}
;# ++piroli, '05/09/26
参考リンク：Shift_JIS に含まれない文字をエスケープ (Jcode.pm編)
MTTagsAsKeyword で使用することができます。
keyword_pattern="<a href="/tag/%e">%k</a>"
regexp_file、regexp_template、regexp_module が何れも指定されていない場合、 内部的にデフォルトパラメータを用いて MTTagsAsRegexp を呼び出します。 そのため、構築のたびに正規表現式の生成が行われるため、 タグ数が増えた場合にパフォーマンス上の問題となる可能性があります。
ignore_tags="span,address"
apply_tags="a,textarea"
これらの指定はデフォルトのignore_tags ＜ ignore_Tags ＜ apply_tags の順に優先されます。
MTTagsAsRegexp と MTTagsAsKeyword を使用します。
<MTTagsAsKeyword regexp_file="tags.rx" keyword_pattern="<a href="/tag/%e">%k</a>"> <$MTEntryBody$> </MTTagsAsKeyword>
<$MTTagsAsRegexp cutoff_score="50" cutoff_length="2" case_sensitive="1"$>
<MTTagsAsKeyword regexp_template="Tags Regexp Template" keyword_pattern="<a href="/tag/%e">%k</a>"> <$MTEntryBody$> </MTTagsAsKeyword>
<$MTTagsAsRegexp cutoff_score="50" cutoff_length="2" case_sensitive="1"$>
<MTTagsAsKeyword regexp_module="Tags Regexp Module" keyword_pattern="<a href="/tag/%e">%k</a>"> <$MTEntryBody$> </MTTagsAsKeyword>
| ダウンロード / MD5 | バージョン | 日付 | サイズ(Bytes) | 動作環境 | 備考 |
|---|---|---|---|---|---|
|
Tagwire plugin w/ TrieEUC | 0.11
| '06/02/07 | MovableType | 文字化け対策 要Jcode 1.99以上 3.151-ja で動作確認 |
Tagwire plugin; Copyright 2005, Hirotaka Ogawa (hirotaka.ogawa at gmail.com)
This code is released under the Artistic License. The terms of the Artistic License are described at
http://www.perl.com/language/misc/Artistic.html
mk_trie_regexp.pl is the original of TrieEUC. Copyright 2005, dankogai
English
寄せられたコメント (全 16 件中、最新 5 件まで表示しています)
Tagwireのコードが変わってしまっているせいだろうとは思うのですが、当然素人が手を出せるものでは無さそうです。
どこをどうしたらいいのでしょうか？
とりとめのない質問で申し訳ありませんが、（今更という気もしますが）対応をお願いします。
keyword_pattern="<a href="/tag/%e">%k</a>"
の%kが文字化けを起こして正しく表示されません。
その後、この問題は解決されたのでしょうか？
解決方法があれば、教えてください。お願いします。
ここでの処理に失敗しているのでしょうか？？
# (MTの文字コード)→EUC-JP→(MTの文字コード)という感じ
この部分、ちょっと(かなり？)いい加減なところがあるので少し見直してみますね…
試しにPerl5.8.7のサーバ(前と同じくxrea.comですが、サーバ違い)に設置してみると、「〜」の文字化けはなくなりました。
ただ、キーワードパターンの「%k」に限って、2バイト文字のタグだと化ける用になってしまいました。
※「%k」でも1バイト文字のタグと、「%e」では問題ありませんでした。
また、Perl4.6.1のサーバではこの現象が起きていませんでした。
どうぞ、よろしくお願いします。
あとはコンパイルできれば何とかなりそうなのですが、環境になくコンパイルできません。
次元の低い話で申し訳ありません…。
ちなみに、Perl 4.8.1 にアップしようとサーバを変えてみようとか思いましたが、エントリーがうまく移行できなかったのであきらめました。