* Storable の互換性 [logging][homenet]

今まで使ってたメイルネットのサーバでは perl 5.005_03 (i386-freebsd) が使われていた．モジュール群はあまり揃っていなかったので，必要なものは ~/lib/perl に自分でインストールして使っていた．

さくらインターネットでは，/usr/bin/perl は v5.8.4 (i386-freebsd-64int)．モジュールもそこそこ揃っている．これなら自前でモジュールをインストールする必要はないかなと思っていたけど，甘かった．

Storable に互換性がない．

tb.cgi では，トラックバックのデータの保存に Storable が使われている．そのデータが読めなくなってしまった．Storable::retrieve が「Byte order is not compatible」とおっしゃっている．うーむ．

• http://perldoc.jp/docs/modules/Storable-2.05/Storable.pod

幸い，さくらインターネットのサーバには perl 5.005_03 built for i386-freebsd も /usr/bin/perl5 としてインストールされているので，こっちを使うことにした．こっちのバージョンではモジュールがあまり揃っていないらしい．というわけでメイルネットのサーバで使っていた ~/lib/perl 以下をごっそりコピーして使うことにする．再コンパイルとかせずにそのままで動くのはありがたい．

他の CGI (clsearch, kuttukibbs, noascii) は perl v5.8.4 で問題なく動くようなのでそちらで動かす．ただし use lib で ~/lib/perl を指定しているとモジュールの互換性の問題で動かないので，指定を止める．

とりあえずはこれでいいけど，いつまでもこのままってわけにもいかないかな．過去データをまとめて新しいファイル構造に変換して，v5.8.4 に移行するようにした方がいいかも知れない．調べてみると，Data::Dump を使って一旦テキストとして吐き出させるという方法があるらしい．そのうち試してみるか．

• http://www.xdelta.net/wiki/WiKicker.html#h5

---

おまけ．というかちょっとだけはまった落とし穴．

さくらインターネットのサーバには，以下の 2 種類の perl がインストールされている．

• /usr/bin/perl5 ... 5.005_03 built for i386-freebsd
• /usr/local/bin/perl ... v5.8.4 built for i386-freebsd-64int

そして以下のような symlink がある．

• /usr/bin/perl -> /usr/local/bin/perl (つまり v5.8.4)
• /usr/local/bin/perl5 -> /usr/local/bin/perl5.8.4 (/usr/local/bin/perl と同じ hard link)

/usr/local/bin/perl5 は 5.005_03 を指しているのが自然だよなあ．どうしてこんなことになっているんだか．

* ASCII じゃない文字フィルタ [tech]

英語のページを書いていたはずなのに，いつのまにか日本語の文字が混じっていて，実は英語圏から見ると化け化けだった．

てなことは，自分自身が書いたページではあまりないんだけど，世の中見回すと結構あります．

というわけで，以前 ASCII じゃない文字をハイライト表示するゲートウェイ型フィルタを書いて，某所で内部的に使ってたんだけど，また最近必要になったので，手直しして，せっかくなので公開してみる．

• http://www.kagami.org/noascii/ (ここのサーバには Crypt::SSLeay がインストールされていないので，https なページは開けません．)

その他の既知の問題としては，

• パスワード認証がかかっているページを開くのは無理 (やりたくない)
• a 要素以外でのジャンプに未対応 (だから frame なページはダメ)
• title の中に non-ascii な文字があると気持ち悪いことに
• 元のファイルに base 要素があった場合はそのままにしといた方がいい?

などがあります．

ソースはこんな感じ:

#!/usr/bin/env perl -T

use strict;
use Jcode;
use CGI;
use URI;
use HTML::Parser;
use HTML::Entities;
use LWP::UserAgent;

&main;

sub main
{
    my $query = new CGI;
    my $script_uri_copied = URI->new($query->url());

    # ヘッダ出力
    print $query->header(-type => 'text/html', -charset => 'EUC-JP');

    # ハイライトの色: デフォルトは cyan
    my $color_str = $query->param('color');
    my $color_code = &hilight_color($color_str);

    # EUC に変換した HTML を取得
    my $http_response = &get_html($query->param('uri'));
    my $uri_base = $http_response->base;
    my $html_code = Jcode->new($http_response->content)->euc;

    # Parser を起動
    my $handler_text = &handler_text_closure($color_code);
    my $handler_start = &handler_start_closure($script_uri_copied, 
                                               $uri_base, $color_str);
    my $hp
      = HTML::Parser->new(default_h =>
                          [sub { print shift; }, 'text'],
                          text_h =>
                          [$handler_text, 'text'],
                          start_h =>
                          [$handler_start, 'tagname, attr, attrseq, text']
                         );
    $hp->parse($html_code);
}

sub hilight_color
{
    my ($color_str) = @_;
    my %color_hash = ('cyan'    => '#00ffff',
                      'magenta' => '#ff00ff',
                      'yellow'  => '#ffff00',
                     );
    
    return $color_hash{$color_str} || 'cyan';
}

sub get_html
{
    my ($uri_str) = @_;
    my $uri = URI->new($uri_str)->canonical;

    # http と https のみ対応
    if ($uri->scheme ne 'http' && $uri->scheme ne 'https') {
        &print_error("scheme not supported: $uri_str");
        exit;
    }
    
    # ファイルを取得して EUC に変換
    my $ua = LWP::UserAgent->new;
    my $res = $ua->get($uri->as_string);

    if (!$res->is_success) {
        print $res->error_as_HTML;
        exit;
    }
    if ($res->content_type ne 'text/html') {
        &print_error("not an HTML: " . $res->content_type);
        exit;
    }

    return $res;
}

sub handler_text_closure
{
    my ($color_code) = @_;
    my $style = "color: black; background-color: $color_code;";

    # テキスト部分で，8 ビットめが立っているところと立ってないところの
    # 境界を検出してタグを挿入する．
    return sub {
        my ($text) = @_;

        $text = " $text ";

        $text =~ s/([\x00-\x7f])([^\x00-\x7f])/$1<b style=\"$style\">$2/g;
        $text =~ s/([^\x00-\x7f])([\x00-\x7f])/$1<\/b>$2/g;

        $text =~ s/^ //;
        $text =~ s/ $//;

        print $text;
    };
}

sub handler_start_closure
{
    my ($script_uri, $uri_base, $color_str) = @_;
    my $is_base_set = 0;

    # タグもちょっといじる
    return sub {
        my ($tagname, $attr, $attrseq, $text) = @_;

        if (!$is_base_set && $tagname ne 'html' && $tagname ne 'head') {
            # html と head 以外が初めて出て来る場所の直前に base を挿入
        
            print "<base href=\"$uri_base\">\n";
            $is_base_set = 1;
        }
    
        if ($tagname eq 'a' && defined($$attr{href})) {
            # a の href の中身を，この CGI を経由するように変換する
        
            print '<a href="', 
                  &wrap_uri(encode_entities($$attr{href}), 
                            $script_uri, $uri_base, $color_str),
                  '"';
            print map {
                $_ eq 'href'? '': " $_=\"" . encode_entities($$attr{$_}) . '"';
            } @$attrseq;
            print '>';
        } elsif ($tagname eq 'meta'
                 && $$attr{'http-equiv'} =~ /^Content-Type$/i) {
            # content-type を指定する meta があるなら，EUC に書き換える
            
            print '<meta http-equiv="Content-Type"', 
                  ' content="text/html; charset=EUC-JP">';
        } else {
            print $text;
        }
    };
}

sub wrap_uri
{
    my ($arg, $script_uri, $uri_base, $color_str) = @_;

    $script_uri->query_form(uri => URI->new_abs($arg, $uri_base),
                            color => $color_str);

    return $script_uri->as_string;
}

sub print_error
{
    my ($s) = @_;
    print "<html><body>$s</body></html>\n";
}