2007年04月09日 16:15 [Edit]

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

camel

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


状況

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

実例

See Also:

現在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:
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__

この記事へのトラックバックURL

この記事へのトラックバック
id:otsuneに建設予定フラグがたてられていたので。 冬通りに消え行く制服ガールは、夢物語にリアルを求めない。 - subtech Perl の utf8 関係が未だ全く理解できない。わからないことがわからないので整理
perl - use utf8; #って何だ?【404 Blog Not Found】at 2009年06月15日 07:22
問題 CGI::Sessionモジュールで、セッションを生ファイルに格納している。指定したディレクトリ配下に全てのファイルを格納するのではなく、セッションIDの頭文字を付けた子ディレクトリ...
CGI::Sessionのファイル保存先を階層化する【Blogo el Ermitejo】at 2008年12月16日 02:52
XREAの共用SSLサーバを使ってPerlのCGIを使うとして、これってプロキシになっていて、スクリプト側からすると、非SSL通信になっていますので、$ENV{’REMOTE_ADDR’}は、XREAのサーバになってしまいます。 CGI::Sessionの-ip_matchに影響が出るので、パッチします。 前提条...
[Perl]XREAの共用SSLアクセスでCGI::Sessionの-ip_matchを機能させる【CLの日記】at 2008年05月14日 19:50
普段自分は携帯サイトのアプリ(webアプリPerl限定)を書いてサービスしていま...
Captchaを携帯サイトで使えるようにする【ブレーンバスター】at 2008年01月28日 13:09
入稿用ファイルアップローダにトロイの木馬スクリプトを入れてきた馬鹿者がおって、どうせロボの仕業なんだろうから、Captchaつけようかーていう案件。例のとおりうちのファイルアップローダはPerlのCGIでできております。 よって、Authen_Captchaを使ってみたんですけれども...
Authen::Captchaをモジュール側の修正無しで出力文字種を絞る【M.C.P.C.】at 2008年01月25日 12:27
この記事へのコメント
トラックバックがなぜか出来ませんが、実行時に動的にパッチあてるやつを適当に作ってみました。
http://d.hatena.ne.jp/spiritloose/20070411/1176271585
Posted by jiro at 2007年04月11日 20:11