swk's log

* 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";
}

* PostScript でレイトレーシング [tech]

• http://at-aka.blogspot.com/2005/12/postscript.html
• (via http://www.pochi.cc/~sasaki/chalow/2005-12-05-5.html)

!!!!!