Perlに限らず、動的に名前空間を書き換えることができる言語ならコンセプトはパクれるはずのtips.
状況
- 人様が書いたモジュールにバグ発見!
- バグ直した
- パッチも送った
- でも作者が
$VERSION++
してくれない - さあどうする?
- オレバージョンのモジュールをつなぎでつかう?
- でも標準でないものをイントールするのはいやん
- サブクラス作ってメソッドをオーバーライドする?
- でも問題のモジュールが継承をサポートしているとは限らないし
- そもそも問題のモジュール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弾𪚲
うまく行ったようだ。
早い話、動的にサブルーチンを書き換えているわけだ。ただしいくつか工夫してある点もある。
return if CGI->VERSION > 3.28;
とすることで、インストールしてあるCGI.pmのバージョンが上がったら何もしないようになっている。package CGI::Util;
により、cgi_fixup()
のスコープを内部でCGI::Util
にしている。これにより、大元のCGI::Util
のパッケージ変数にもアクセスできるようになる。sub CGI::Util::unescape{ ... }
とはせずに*unescape = sub{ ... }
としているのは、1.で指定した条件が成立しない場合には実行させないため。サブルーチンをコンパイルタイムではなくランタイムに上書きする時にはこちらの方法を利用する。- サブルーチンはもとのモジュールにあるものをそのままコピペしてからfix。コピペが正しい数少ない事例。
- 最後の
*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__
http://d.hatena.ne.jp/spiritloose/20070411/1176271585