perl - パッチなしでパッチする

Perlに限らず、動的に名前空間を書き換えることができる言語ならコンセプトはパクれるはずのtips.

状況

1. 人様が書いたモジュールにバグ発見!
2. バグ直した
3. パッチも送った
4. でも作者が$VERSION++してくれない
5. さあどうする?
   • オレバージョンのモジュールをつなぎでつかう?
     • でも標準でないものをイントールするのはいやん
   • サブクラス作ってメソッドをオーバーライドする?
     • でも問題のモジュールが継承をサポートしているとは限らないし
     • そもそも問題のモジュールOOじゃなかったりもするし
   • 代替モジュールを書いてCPANにうp? -- i.e. JSON::*
     • でも元々のモジュールがあまりによく使われているし
     • うpは簡単でもサポート大変そうだし....

実例

See Also:

• 404 Blog Not Found:javascript - encodeURIUnicode()と%uXXXX問題

現在Version 3.28のCGI.pmには、%uXXXXをうまく扱えていないという問題がある。

一つは、%uXXXXを使ったときに限って、param()の戻り値にutf8フラグが立ってしまうというもの。

#!/usr/local/bin/perl -T
use strict;
use warnings;
use CGI;
my $q = CGI->new;
print $q->header(
    -type    => 'text/plain',
    -charset => 'utf-8'
);
print "$_ = " . $q->param($_) for $q->param();
print "\n";

こういう単純な例で見てみると、

% ./cgi-test.pl q=%u0061
Content-Type: text/plain; charset=utf-8

q = a

% ./cgi-test.pl q=%u0061%u5F3E
Content-Type: text/plain; charset=utf-8

Wide character in print at ./cgi-fixup.pl line 10.
q = a弾

となってそれとわかる。まあこちらはEncode::encode_utf8()とかに食わせれば解決する問題ではあるのだが、CGIのパラメターの値は、この時点ではまだdecodeされていないのが望ましい(%xXXの場合もそうだし)。

もう一つは、より深刻な問題で、Surrogate Pairを%uXXXXで食わせると、param()がだんまりになってしまうこと。

% ./cgi-fixup.pl q=%u0061%u5F3E%uD869%uDEB2
Content-Type: text/plain; charset=utf-8

これはまずい。なにしろ%uXXXX表記ではSurrogate Pairにすることは、RFCでは蹴られたものの、ECMA-262でまだサポートされていて、ブラウザーの実装もそのようになっている。

本entry末のpatchを書いて作者のLDSに送ったものの、返事はまだ来ないし、RTのティケットも30枚近くたまっている。これはすぐに$CGI::VERSION++されることは期待できない。でも、これを使いたいAppがどうしてもある。さあどうする?

解決策

こういう場合に、使えるのが以下の手段。

use CGI;
cgi_fixup();

とした上で、以下を加える。

sub cgi_fixup{
    return if CGI->VERSION > 3.28;
    package CGI::Util;
    no warnings 'redefine';
    *utf8_chr  = sub {
        require utf8;
        my $c = shift;
        my $u = chr($c);
        utf8::encode($u); # drop utf8 flag
        return $u;
        # $] < 5.006 support skipped because this is just a fixup
    };
    *unescape = sub {
        shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass));
        my $todecode = shift;
        return undef unless defined($todecode);
        $todecode =~ tr/+/ /;       # pluses become spaces
            $EBCDIC = "\t" ne "\011";
        if ($EBCDIC) {
            $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
        } else {
            # handle surrogate pairs first -- dankogai
            $todecode =~ s{
                           %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
                           %u([Dd][c-fC-F][0-9a-fA-F]{2})   # lo
                          }{
                              utf8_chr(
                                       0x10000 
                                       + (hex($1) - 0xD800) * 0x400 
                                       + (hex($2) - 0xDC00)
                                      )
                          }gex;
            $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
                defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
        }
        return $todecode;
    };
    *CGI::unescape = \&unescape; # manually exporting
    return 1;
}

うまくいくか?

% ./cgi-fixup.pl q=%u0061%u5F3E%uD869%uDEB2   
Content-Type: text/plain; charset=utf-8

q = a弾𪚲

うまく行ったようだ。

早い話、動的にサブルーチンを書き換えているわけだ。ただしいくつか工夫してある点もある。

1. return if CGI->VERSION > 3.28;とすることで、インストールしてあるCGI.pmのバージョンが上がったら何もしないようになっている。
2. package CGI::Util;により、cgi_fixup()のスコープを内部でCGI::Utilにしている。これにより、大元のCGI::Utilのパッケージ変数にもアクセスできるようになる。
3. sub CGI::Util::unescape{ ... }とはせずに*unescape = sub{ ... }としているのは、1.で指定した条件が成立しない場合には実行させないため。サブルーチンをコンパイルタイムではなくランタイムに上書きする時にはこちらの方法を利用する。
4. サブルーチンはもとのモジュールにあるものをそのままコピペしてからfix。コピペが正しい数少ない事例。
5. 最後の*CGI::unescape = \&unescape;は、実際にescape()が使われる際にはCGI::Util直ではなくCGIの方にimportされているため。

さらなる解決策

同様の方法は、モジュールを使っても可能だ。

package CGI::Fixup;
use strict;
use warnings;
our $VERSION = 0.01;

sub cgi_fixup{
  # 同一に付き (ry
}

\*import = cgi_fixup();
"fixed";

とした上で、use CGI;している側は直後にuse CGI::Fixup;すればよい。

まとめ

このように、応急処置のやりかたもいろいろあります。今回のCGI.pmのように、Perl Coreに入っていたり非常によく使われていたりするCPAN Moduleの作者はなにかと忙しく、依存度が高いモジュールに限ってアップデートが遅かったりするのはPerlの世界だけではありません。

こういう時には、Patchを送りつつもこうして応急処置をする方法があることを思い出してもいいでしょう。

Happy Hacking!

Dan the Yet Another Perl Hacker

See Also:

• 404 Blog Not Found:書評 - PERL HACKS (日本語版)

diff -ruN CGI.pm-3.28/CGI/Util.pm CGI.pm-3.28_01/CGI/Util.pm
--- CGI.pm-3.28/CGI/Util.pm     2006-12-07 00:18:18.000000000 +0900
+++ CGI.pm-3.28_01/CGI/Util.pm  2007-04-07 15:37:09.000000000 +0900
@@ -7,7 +7,7 @@
 @EXPORT_OK = qw(rearrange make_attributes unescape escape 
                expires ebcdic2ascii ascii2ebcdic);
 
-$VERSION = '1.5';
+$VERSION = '1.5_01';
 
 $EBCDIC = "\t" ne "\011";
 # (ord('^') == 95) for codepage 1047 as on os390, vmesa
@@ -141,8 +141,12 @@
 
 sub utf8_chr {
         my $c = shift(@_);
-       return chr($c) if $] >= 5.006;
-
+       if ($] >= 5.006){
+           require utf8;
+           my $u = chr($c);
+           utf8::encode($u); # drop utf8 flag
+           return $u;
+       }
         if ($c < 0x80) {
                 return sprintf("%c", $c);
         } elsif ($c < 0x800) {
@@ -189,6 +193,17 @@
     if ($EBCDIC) {
       $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
     } else {
+       # handle surrogate pairs first -- dankogai
+       $todecode =~ s{
+                       %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi
+                       %u([Dd][c-fC-F][0-9a-fA-F]{2})   # lo
+                     }{
+                         utf8_chr(
+                                  0x10000 
+                                  + (hex($1) - 0xD800) * 0x400 
+                                  + (hex($2) - 0xDC00)
+                                 )
+                     }gex;
       $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
        defined($1)? chr hex($1) : utf8_chr(hex($2))/ge;
     }
diff -ruN CGI.pm-3.28/t/percent-u.t CGI.pm-3.28_01/t/percent-u.t
--- CGI.pm-3.28/t/percent-u.t   1970-01-01 09:00:00.000000000 +0900
+++ CGI.pm-3.28_01/t/percent-u.t        2007-04-07 14:55:25.000000000 +0900
@@ -0,0 +1,27 @@
+#
+# This tests %uXXXX notation
+# -- dankogai
+BEGIN {
+    if ($] < 5.008) {
+       print "1..0 # \$] == $] < 5.008\n";
+       exit(0);
+    }
+}
+use strict;
+use warnings;
+use Encode;
+use Test::More tests => 6;
+use utf8;
+use CGI::Util;
+
+my %escaped = (
+              encode_utf8(chr(0x61))    => '%u0061',
+              encode_utf8(chr(0x5F3E))  => '%u5F3E',
+              encode_utf8(chr(0x2A6B2)) => '%uD869%uDEB2',
+);
+
+for my $chr (keys %escaped){
+    is  !utf8::is_utf8($chr), 1;
+    is CGI::Util::unescape($escaped{$chr}), $chr, "$escaped{$chr} => $chr";
+}
+__END__

Comments

トラックバックがなぜか出来ませんが、実行時に動的にパッチあてるやつを適当に作ってみました。
http://d.hatena.ne.jp/spiritloose/20070411/1176271585

Posted by jiro at 2007年04月11日 20:11