LWP::UserAgent@6.05でX-Meta-Twitter:cardがヘッダに含まれているページがうまく取得できない

Perl

詳しくはlwp-download fails with HTTP::Message 6.06 · Issue #3 · libwww-perl/http-message · GitHubに書かれていますが、要約すると

X-Meta-Twitter:cardのような:がヘッダに含まれているとIllegalであると判断されるようになってしまった

use strict;
use warnings;
use utf8;
use LWP::UserAgent 6.05;

my $ua = LWP::UserAgent->new();
my $res = $ua->get('http://www.youtube.com/watch?v=9Y6H-YjsE9Q');
print $res->content, "\n";
print $res->header('X-Died'), "\n";

例えば、みんな大好きYouTubeのページはうまく取得できません。X-Diedヘッダ(LWP内部での例外メッセージが覗けます)を見ると、なるほどーという感じですね。

Illegal field name 'X-Meta-Twitter:card' at HTML/HeadParser.pm line 207.

はてなブログもX-Meta-Twitter:cardがヘッダに含まれているので、うまく取得できませんね。

LWP::UserAgent@6.04を使う

割と困るので、6.05ではなく6.04を使うと幸せになれます。(いつ6.07がリリースされるんでしょうね)

akictfのはなし

最近CTFというものを知って、結構面白いなーと思いながらksnctfをちょこちょこやっています。
先日、とある方に「セキュリティについてもっとよく知りたい、これから先ステップアップするにはどうすればいいか」と聞いたところ、問題を作るのがいいよと言われたのでなるほどと思い、自分で問題を作ってみるのも面白そうだったのでちょろっと作ってみました。

akictf

もう動いている→akictf

個人的に好きな問題はHorizontal lineで、ぱっと見た感じはよくわからなくて、CTFをやったことがなくても解けてしまう感じがいいです。ほかはfrom login formもおすすめです。

問題を作るのは楽しいけど、基本的に自分の知っている技術に偏ってしまいがちなので、幅広く網羅できるようになっていきたいですね。

Perlを半殺しにするGolf

Perl

メモリを食わせまくってPerlを半殺しにしたいと思ったので少し考えてみました。

条件
  • whileを使わない
  • gotoを使わない

あからさまな無限ループをさせないというのが条件です。
で、ひとつ考えたのがこんな感じです(29 bytes)。数秒で数GB級のメモリ空間を圧迫します。

perl -e'@a=1;push@a,$_ for@a'

AnyEvent::SKKServを書いた

Perl

ついカッとなって。(AquaSKKの新しいバージョンが出たので)

akiym/AnyEvent-SKKServ · GitHub

もともとgoogle-ime-skkというものがあって、これはGoogle CGI APIを利用してSKKにGoogle日本語入力のエッセンスを加えるskkserv(辞書サーバ)。地味に便利で手放せないものになっていたんだけど、AquaSKKが新しくなってからgoogle-ime-skkがうまく動かなくなってしまった(cacheあたりがあやしい)*1。なので、とりあえずAnyEventで書いちゃえと思って書いてしまった…。
とりあえずで書いたら適当になってしまったgoogle-ime-skkの例:

use strict;
use warnings;
use utf8;
use AnyEvent;
use AnyEvent::HTTP;
use AnyEvent::SKKServ;
use Cache::Memory::Simple;
use Encode;
use JSON;
use URI;

our $GOOGLE_IME_URL = 'http://www.google.com/transliterate';

my $cache = Cache::Memory::Simple->new();
my $expire = 60 * 60 * 24;

my $json = JSON->new->utf8(1)->relaxed(1);

my $skkserv = AnyEvent::SKKServ->new(
    port => 55100,
    on_request => sub {
        my ($hdl, $req) = @_;
        $req = decode('euc-jp', $req);
        $req =~ s/([a-z])$/,$1/; # 書く => かk

        if (my $val = $cache->get($req)) {
            $hdl->push_write("1/$val\n");
        } else {
            my $uri = URI->new($GOOGLE_IME_URL);
            $uri->query_form(
                langpair => 'ja-Hira|ja',
                text     => encode_utf8($req),
            );
            http_get $uri, timeout => 1, sub {
                my $res = $json->decode($_[0]);
                my $val = join '/', @{$res->[0][1]};
                $val = encode('euc-jp', $val);

                $hdl->push_write("1/$val\n");

                $cache->set($req => $val, $expire);
            };
        }
    },
);
$skkserv->run;

AE::cv()->recv;

もう少し使ってみて問題なければCPANにアップしよう。

追記

細かいところを直した。

  • 送り仮名がついているものを無視する(書く => かk)
  • 複数の変換候補があるものは無視する(たびにでる => [度に, 旅に, 足袋に], [出る])
use strict;
use warnings;
use utf8;
use AnyEvent;
use AnyEvent::HTTP;
use AnyEvent::SKKServ;
use Cache::Memory::Simple;
use Encode;
use JSON;
use URI;

use constant {
    SERVER_ERROR     => '0',
    SERVER_FOUND     => '1',
    SERVER_NOT_FOUND => '4',
    SERVER_FULL      => '9',
};

my $cache = Cache::Memory::Simple->new();
my $expire = 60 * 60 * 24;

my $json = JSON->new->utf8(1)->relaxed(1);

my $_uri = URI->new('http://www.google.com/transliterate');
sub _uri {
    my $text = shift;
    my $uri = $_uri->clone;
    $uri->query_form(
        langpair => 'ja-Hira|ja',
        text     => encode_utf8($text),
    );
    return $uri;
}

my $skkserv = AnyEvent::SKKServ->new(
    port => 55100,
    on_request => sub {
        my ($hdl, $req) = @_;
        $req = decode('euc-jp', $req);

        my $server_found = sub {
            my $val = shift;
            $hdl->push_write(SERVER_FOUND . "/$val\n");
        };
        my $server_not_found = sub {
            $hdl->push_write(SERVER_NOT_FOUND . "\n");
        };

        # okuri-ari entry
        if ($req =~ /([a-z])$/) {
            $server_not_found->();
        }

        if (my $val = $cache->get($req)) {
            if ($val eq '*') {
                $server_not_found->();
            } else {
                $server_found->($val);
            }
        } else {
            http_get _uri($req), timeout => 1, sub {
                my $res = $json->decode($_[0]);
                if (@$res == 1) {
                    my $val = join '/', @{$res->[0][1]};
                    $val = encode('euc-jp', $val);
                    $server_found->($val);

                    $cache->set($req => $val, $expire);
                } else {
                    $server_not_found->();

                    $cache->set($req => '*', $expire);
                }
            };
        }
    },
);
$skkserv->run;

AE::cv()->recv;

*1:勘違いかもしれない

Perlの食えない事情 - 演算子編

Perl

Perlの食えない事情 より
おっと、そうです、Perlには演算子が多すぎるのでした。せっかくの機会なので、Perlの演算子を紹介します。

ビーナス演算子: 0+, +0

数値として評価してくれます。意外とよく見かけますね。
なぜこの演算子を使う必要があるのかというと、Perlは文字列と数値を明確に区別できないからです。scalarを文字列として解釈するならば文字列として、

print 0+ '10';    #=> 10
print 0+ '123b';  #=> 123
print '1.2e3' +0; #=> 1200
print [] +0;      #=> 4303367864

ちなみに、文字列として評価するときにはこのようにするとかっこいいと言われています。

$obj.q();

一見メソッド呼び出しのように見えますが

$obj . '';

と等価です。

ベビーカー演算子: @{[ ]}

文字列の中に式を展開することができます。
array refをその場でデリファレンスしています。したがって、リストコンテキストで評価されることに注意しましょう。

print "1 + 1 = @{[ 1 + 1 ]}\n";
print "localtime: @{[ scalar localtime ]}\n";

バン!バン!演算子: !!

真偽値として評価してくれます。
Perlのモジュールは最後にtrueを返す必要があり、ほとんどの人はファイルの最後に1;を書きますが、わざと真偽値を返すためにこう書く人もいます:

!!1;

イヌイット演算子: }{

イヌイットは鼻と鼻をこすり合わせてあいさつをするみたいですね。そう、この演算子のように。
この演算子はENDブロックと*似たような*動作をします。ワンライナーのときに使うと便利です。

perl -lne '}{print$.'

シャクトリムシ演算子: ~~

パターンマッチ演算子？違います。コイツは単項演算子のシャクトリムシなのです。
実はscalar()と同じ動作をします。しかも"scalar"よりも4文字短いのです。

print ~~localtime; #=> Sun Feb  3 01:43:33 2013

枝の上でおやすみ中のシャクトリムシ演算子: ~-, -~

優先順位が高いインクリメント(-~)、デクリメント(~-)演算子です。

宇宙ステーション演算子: -+-

優先順位が高いビーナス演算子(0+, +0)です。

print 0+ '20GBP' x 3;  #=> 20
print -+- '20GBP' x 3; #=> 202020

Goatse演算子: =( )=

説明: この演算子の意味を理解できないのなら、あなたは運がいい。画像検索しないことをお勧めする。

うーん。この説明はちょっと意味がわかりませんね。今ちょうど検索ができない状況にあるので、誰かに確かめていただきたい :)
冗談はさておき、この演算子はどのようにして使うのか気になりますよね？右手に式を渡しておくと、左手に返り値の要素数が返ってきます。もちろんケツからは@がでてきます。

$n =(@c)= "abababab" =~ /a/g; # $n = 4; @c = qw( a a a a )

例えば、PATHの個数だけを調べたいときに使えます:

$count =()= split /:/, $ENV{PATH};
$count = @{[ split /:/, $ENV{PATH} ]}; # ベビーカー演算子

Xウィング(燃)演算子: =< >=~

ファイルから一行読み込み、その際に正規表現のキャプチャを受け取ることができます。

# pick named fields from input
@data{@fields} =<>=~ $regexp;

Xウィングに乗ることもできます:

# use the source, Luke!
$luke = \*DATA;
@data{@fields} =<$luke>=~ $regexp;

タコ演算子: ~~<>

凧。またの名をsperm演算子。
ファイルから一行読み込みます。リストに埋め込むときに便利です:

@triplets = ( ~~<>, ~~<>, ~~<> );

ダブルブレード演算子: <> m;

Perlで複数行コメントを実現するには

=pod
  comment
=cut

とするのがよく知られています。でも少し面倒ですよね？そうです、そんなときにはダブルブレード演算子が使えます:

<<m=~m>>
  Use the secret operator on the previous line.
  Put your comments here.
  Lots and lots of comments.

  You can even use blank lines.
  Finish with a single
m
;

正確にはコメントではないので注意してください。

マイナスドライバー演算子: -=!, -=!!

$x -=!! $y     # $x-- if $y;
$x -=!  $y     # $x-- unless $y;

プラスドライバー演算子: +=!, +=!!

$x +=!! $y;    # $x++ if $y;
$x +=!  $y;    # $x++ unless $y;

ポジドライバー演算子: x=!, x=!!

$x x=!! $y;    # $x = '' unless $y;
$x x=!  $y;    # $x = '' if $y;

トルクスドライバー演算子: *=!, *=!!

$x *=!! $y;    # $x = 0 unless $y;
$x *=!  $y;    # $x = 0 if $y;

ウインクファットカンマ演算子: ,=>

ファットカンマ演算子(=>)は次のようなケースで不便です。

use constant APPLE   =>  1;
use constant CHERRY  =>  2;
use constant BANANA  =>  3;

my %hash = (
    APPLE   =>  "green",
    CHERRY  =>  "red",
    BANANA  =>  "yellow",
);
#=> %hash = ( "APPLE", "green", "CHERRY", "red", "BANANA", "yellow" );

本当は、constantで宣言したものがキーとなって欲しかったのですが、キーがそのまま文字列として解釈されてしまいました。
そんなときにはウインクファットカンマ演算子(,=>)を使いましょう:

use constant APPLE   =>  1;
use constant CHERRY  =>  2;
use constant BANANA  =>  3;

my %hash = (
    APPLE   ,=>  "green",
    CHERRY  ,=>  "red",
    BANANA  ,=>  "yellow",
);
#=> %hash = ( 1, "green", 2, "red", 3, "yellow" );

エンタープライズ演算子: ()x!!

演算子の名前はスタートレックに由来しているらしいです。

my @shopping_list = ('bread', 'milk');
push @shopping_list, 'apples'   if $cupboard{apples} < 2;
push @shopping_list, 'bananas'  if $cupboard{bananas} < 2;
push @shopping_list, 'cherries' if $cupboard{cherries} < 20;
push @shopping_list, 'tonic'    if $cupboard{gin};

エンタープライズ演算子を使うと以下のように書くことができます:

my @shopping_list = (
    'bread',
    'milk',
   ('apples'   )x!! ( $cupboard{apples} < 2 ),
   ('bananas'  )x!! ( $cupboard{bananas} < 2 ),
   ('cherries' )x!! ( $cupboard{cherries} < 20 ),
   ('tonic'    )x!! $cupboard{gin},
);


参考にさせていただきました:

Shipped App::Tacochan 0.05!

[D] MacのSpotlightを使ってスカイプのチャットルームをサクサク切り替えられる方法 - Drift Diary XV の記事を見てこんなことができたのかと知り、tacochanもSkype URIをコピーするだけでメッセージ送信ができるようにしたかったのでサクっと書きました。
使い方はとても簡単で、メッセージを送りたいチャットに

/get uri

と送信すると、skype:から始まるSkype URIが返ってくるので、それをtacochanに渡してあげると簡単に動くようになっています。
今まではチャット名を調べるときにはチャットの一覧を表示していて、その中からchatnameをコピーしてくる必要があったので面倒でしたが、今回の変更のおかげでとても簡単になりましたね。