ishiducaの日記

■ [再帰]"Deep recursion on anonymous subroutine" 19:52

合成関数を作る compose 関数を実装しようとして $f = sub { $f->($g->(@_)) } としたら、"Deep recursion on anonymous subroutine" と怒られた

use strict;
use warnings;
use feature qw(say);

sub inc {    my $x = shift; $x + 1; }
sub double { my $x = shift; $x * 2; }
sub square { my $x = shift; $x * $x; }

sub compose {
    my $first = pop @_;
    while (my $g = pop @_) {
        # こうすると "Deep recursion on anonymous subroutine" と警告を出して無限ループしちゃう
        $first = sub { $first->($g->(@_)) };
    }
    $first;
}
my $ids = compose(\&inc, \&double, \&square);
my $sdi = compose(\&square, \&double, \&inc);

say $ids->(3);
say $sdi->(3);

なのでループの代わりに再帰させる

sub compose {
    my $f = pop @_;
    my $g;

    ($g = pop @_)
        ? compose(@_, sub { $f->($g->(@_)) })
        : $f;
}

my $ids = compose(\&inc, \&double, \&square);
my $sdi = compose(\&square, \&double, \&inc);

ただ、最初の compose もあっさり抜けられて

sub compose {
    my $first = pop @_;
    while (my $g = pop @_) {
        my $f = $first; # $f に代入するだけ
        $first = sub { $f->($g->(@_)) };
    }
    $first;
}
my $ids = compose(\&inc, \&double, \&square);
my $sdi = compose(\&square, \&double, \&inc);

say $ids->(3); # 64
say $sdi->(3); # 19

焦ったのでメモ

■ [AnyEvent][FriendFeed]AnyEventの文脈でFriendFeedに画像とか音声とかのファイルをポストする 14:19

ポストするだけ。

feed馬鹿には FriendFeed は必須コンテンツなので、簡単になくなってもらうと困りますね。

post.pl

#!/usr/bin/env perl
use strict;
use warnings;
use MyApp::AnyEvent::FriendFeed;

my $message = "hogehoge";
my @files   = qw( path/to/image/1.jpg );

for my $file (@files) {
    die qq(! failed: "$file" not found) unless -e $file;
}

my %options = (
    file    => [ @files ],
    comment => 'comment of hogehoge',
);

my $client = MyApp::AnyEvent::FriendFeed->new(
    username => 'your username', remotekey => 'remotekey',
);

my $cv = AE::cv;

$client->post($message, %options, sub {
    my($response, $headers) = @_;

    if ($headers->{Status} ne '200') {
        warn qq(! failed $headers->{Status} $headers->{Reason}\n);
    }

    if ($response->{errorCode}) {
        warn qq(! failed $response->{errorCode}\n);
    }

    print join '\t',
        $response->{date},
        "(id: $response->{id})",
        "url: $response->{uri}",
        "$response->{body}\n";

    $cv->send;

});

$cv->recv;

今更だけど、Tatsumaki::HTTPClient をベースにしたほうが筋いいよね...orz

package MyApp::AnyEvent::FriendFeed;
use strict;
use warnings;
use Carp;
use AnyEvent;
use AnyEvent::HTTP;
use MIME::Base64;
use HTTP::Request::Common;
use HTTP::Request;
use JSON;

our $VERSION = '0.01';

my $api = 'http://friendfeed-api.com/v2/entry';

sub new {
    my $class = shift;
    my %args  = @_;

    $args{'username'}  || Carp::croak qq(! failed: "username" not found\n);
    $args{'remotekey'} || Carp::croak qq(! failed: "remotekey" not found\n);
 
    chomp(my $auth = MIME::Base64::encode( join ':', $args{username}, $args{remotekey}));

    bless {
        authorization => "Basic ${auth}",
    }, $class;
}

sub post {
    my $self = shift;
    my $body = shift || Carp::croak qq(! failed: "body" parameter not found\n);
    my $cb   = pop   || Carp::croak qq(! failed: "callback" not found\n);
    my %opts = @_;

    my $on_error  = delete $opts{on_error}  || sub { die @_; return; };
    my $on_header = delete $opts{on_header} || sub {
        my $headers = shift;
        unless ($headers->{Status} =~ /^2/) {
            $on_error->(qq(! failed: $headers->{Status} "$headers->{Reason}"\n));
            return;
        }
        return 1;
    };

    $opts{body} = $body;

    my @request_params = ($api,
        Authorization => $self->{authorization},
        Content       => \%opts
    );

    push @request_params, qw/Content_Type form-data/ if $opts{file};
    
    my $request = HTTP::Request::Common::POST(@request_params);

    my $p; $p = http_request('POST' => $api,
        headers   => $request->headers,
        body      => $request->content,
        on_header => $on_header,
        sub {
            undef $p;
            my($body, $headers) = @_;
            my $res = JSON::decode_json $body;
            $cb->($res, $headers);
        }
    );
}

1;

__END__

こっちにも https://gist.github.com/1366140

■ [AnyEvent][AnyEvent_HTTP]いまさら「YAPC::ASIA 2011 Tokyo 行ってきたので」(追記: 2011.11.07） 21:30

YAPC::ASIA 2011 Tokyoでは Marc Lehmann さんのトークの中で「アニメ」を連呼していたのがよかったですね。

（中略）ということで、マルチなダウンロードには AnyEvent を使うのがいいんだな！　と勝手に合点して、AnyEvent::Pixiv::Download というのを書いた。今更感がすごいけど。

追記: github に上げました https://github.com/ishiduca/p5-AnyEvent-Pixiv-Download 原理的には同じなんだけど、メソッド名とか変わってます (2011.11.07)

サンプルのダウンロードスクリプト(dl.pl)

#!/usr/bin/env perl
use strict;
use warnings;
use Config::Pit;
use AnyEvent::Pixiv::Download;

my $config = pit_get('www.pixiv.net', require => {
    pixiv_id => '', pass => '',
});

my $cv = AE::cv;

my $client = AnyEvent::Pixiv::Download->new(
    pixiv_id => $config->{pixiv_id},
    pass     => $config->{pass},
);

for my $illust_id (qw/22854495 22856417 22855011 22849905/) {

    $client->to_mode_medium($illust_id, 'deep', sub {
        my $information = shift;
        my $illust_top_url     = $information->{illust_top_url};

        for my $img_src (@{$information->{contents}}) {

            $cv->begin;
            $client->download($img_src, $illust_top_url, sub {
                my(undef, $headers) = @_;
                warn "!! finish ", $headers->{URL}, "\n";
                $cv->end;
            });
        }
    });
}

$cv->recv;

1;

多重コールバックになるUIとか、リ○○ラをいちいち指定しなくちゃいけないのがださくて仕方ないので、ツッコミください

lib/AnyEvent/Pixiv/Download.pm

package AnyEvent::Pixiv::Download;

use warnings;
use strict;
use Carp;
use AnyEvent;
use AnyEvent::HTTP;
use Web::Scraper;
use File::Basename;
use Data::Dumper;

our $VERSION = '0.01';

my $www_pixiv_net = 'http://www.pixiv.net';
my $login_php     = "${www_pixiv_net}/login.php";
my $mypage_php    = "${www_pixiv_net}/mypage.php";
my $illust_top    = "${www_pixiv_net}/member_illust.php?mode=medium&illust_id=";

sub new {
    my $class = shift;
    my %args  = @_;

    my $self  = bless {}, $class;

    $self->{pixiv_id}   = delete $args{pixiv_id} || Carp::croak qq(! faild: "pixiv_id" not found);
    $self->{pass}       = delete $args{pass}     || Carp::croak qq(! failed: "pass" not found);
    $self->{verbose}    = delete $args{verbose}  || 1; # this test mode !
    $self->{cookie_jar} = {};
    $self->{information_mode_medium} = {};

    $self->login;

    return $self;
}

sub login {
    my $self = shift;

    my $sub_cv = AE::cv;
    my $login; $login = http_request('POST' => $login_php,
        headers => { 'content-type' => 'application/x-www-form-urlencoded' },
        body    => "mode=login&pixiv_id=$self->{pixiv_id}&pass=$self->{pass}",
        recurse => 0,
        sub {
            my($body, $headers) = @_;
            warn Dumper $headers             if $self->{verbose} == 2;
            warn qq(fetch: "${login_php}"\n) if $self->{verbose} == 1;

            Carp::croak qq(! failed: "set-cookie" not found at $headers->{URL}\n)
                unless $headers->{'set-cookie'};

            $self->{cookie_jar} = _cookie_jar_hogehoge($headers->{'set-cookie'})
                or Carp::croak qq(! failed: something wrong...\n);

            warn Dumper $self->{cookie_jar}                   if $self->{verbose} == 2;
            warn qq(get_cookie: "$headers->{'set-cookie'}"\n) if $self->{verbose} == 1;

            my $location = $headers->{'location'};

            undef $login;

            my $redirect; $redirect = http_request('GET' => $location,
                cookie_jar => $self->{cookie_jar},
                sub {    
                    my($body, $headers) = @_;
                    Carp::croak qq(! failed: "redirect" failed\n  $headers->{URL}\n)
                        if $headers->{URL} ne $location;

                    warn Dumper $headers                if $self->{verbose} == 2;
                    warn qq(fetch: "$headers->{URL}"\n) if $self->{verbose} == 1;
                    
                    undef $redirect;
                    $sub_cv->send("sucess: login !\n");
                }
            );
        }
    );
    my $message = $sub_cv->recv;
    warn $message;

    return $self;
}

sub to_mode_medium {
    my $self      = shift;
    my $cb        = pop;
    my $illust_id = shift || Carp::croak qq(! failed: "illust_id" not found\n);
    my $deep      = shift;

    my $mode_medium; $mode_medium = http_request('GET', "${illust_top}${illust_id}",
        cookie_jar => $self->{cookie_jar},
        sub {
            my($body, $headers) = @_;
            warn Dumper $headers                if $self->{verbose} == 2;
            warn qq(fetch: "$headers->{URL}"\n) if $self->{verbose} == 1;

            Carp::croak qq(! failed: something wrong...\n  $headers->{URL}\n)
                if $headers->{URL} ne "${illust_top}${illust_id}";

            my $information  = _scrape_mode_medium($body, $headers->{URL});

            if ($deep) {
                my $mode_big; $mode_big = http_request('GET', $information->{contents_url},
                    cookie_jar => $self->{cookie_jar},
                    headers    => { referer => $headers->{URL} },
                    sub {
                        my($body, $headers) = @_;

                        Carp::croak qq(! failed: something wrong...\n  $headers->{URL}\n)
                            if $headers->{URL} ne $information->{contents_url};

                        warn Dumper $headers                if $self->{verbose} == 2;
                        warn qq(fetch: "$headers->{URL}"\n) if $self->{verbose} == 1;

                        if ($information->{contents_url} =~ /mode=manga/) {
                            $information->{mode} = 'manga';
                            $information->{contents} = [];
                            while ($body =~ m!(http://img\d\d\.pixiv\.net/img/[^']+?)'!g) {
                                push @{$information->{contents}}, $1;
                            }
                        } else { # $information->{contents_url} =~ /mode=big/
                            $information->{mode} = 'big';
                            my $scraper = scraper {
                                process '//div/a/img[1]', 'img_src' => '@src';
                            };
                            $information->{contents} = [ ($scraper->scrape($body))->{img_src} ];
                        }

                        $self->{information_mode_medium} = $information;
                        warn Dumper $information if $self->{verbose} == 2;
                        warn Dumper $information if $self->{verbose} == 1;

                        undef $mode_big;
                        undef $mode_medium;
                        $cb->($information);
                    }
                );
            } else {
                $self->{information_mode_medium}->{$illust_id} = $information;
                warn Dumper $information if $self->{verbose} == 2;
                warn Dumper $information if $self->{verbose} == 1;

                undef $mode_medium;
                $cb->($information);
            }
        }
    );

    return $self;
}

sub download {
    my $self    = shift;
    my $cb      = pop;
    my $img_src = shift || Carp::croak qq(! failed: "img_src" not found\n);;
    my $referer = shift || Carp::croak qq(! failed: "referer" not found\n);
    my $options = shift;

    my $on_body = ($options->{on_body}) ? $options->{on_body} : (sub {
        my $filename = basename $img_src;
        $filename =~ s/\?.*$//;
        open my $fh, '>', $filename or Carp::croak qq(! failed: "${filename}" $!\n);
        binmode $fh;
        return sub {
            my($partial_body, $headers) = @_;
            if ($headers->{Status} =~ /^2/) {
                print $fh $partial_body;
            }
            return 1;
        };
    })->();

    my $done; $done = http_request('GET' => $img_src,
        cookie_jar => $self->{cookie_jar},
        headers    => { referer => $referer },
        on_header => sub {
            my $headers = shift;
            if ($headers->{Status} ne '200') {
                ($options->{on_error} || sub { die @_ })->(qq(failed: "${img_src}" $headers->{Status} $headers->{Reason}\n));
                return ;
            }
            return 1;
        },
        on_body => $on_body,
        sub {
            my($body, $headers) = @_;
            undef $done;
            $cb->(@_);
        }
    );

    return $self;
}

sub _scrape_mode_medium {
    my $body           = shift || Carp::croak qq(! failed: "body" not found\n);
    my $illust_top_url = shift || Carp::croak qq(! failed: "illust_top_url" not found\n);

    my $scraper = scraper {
        process '//h3[1]', 'title' => 'TEXT';
        process '//p[@class="works_caption"]', 'description' => 'HTML';
        process '//a[@class="avatar_m"]', 'author_name' => '@title';
        process '//a[@class="avatar_m"]', 'author_url'  => [ '@href', sub {
            return $www_pixiv_net . $_;
        } ];
        process '//div[@class="works_display"]/a[1]', 'contents_url' => [ '@href', sub {
            return join '/', $www_pixiv_net, $_;
        } ];
        process '//div[@class="works_display"]/a[1]/img[1]', 'img_src' => '@src';
    };

    my $information = $scraper->scrape($body);
    $information->{author} = {};
    $information->{author}->{name} = delete $information->{author_name};
    $information->{author}->{url}  = delete $information->{author_url};
    $information->{illust_top_url} = $illust_top_url;
    return $information;
}

sub _cookie_jar_hogehoge {
    local $_ = shift || return ;
    my %cookie = ();
    my $phpsessid = 'PHPSESSID';
    map{
        my($key, $value) = split /=/;
        $cookie{$key} = $value;
    }(split /; /);

    Carp::croak  qq(! failed: "${phpsessid}" not found) unless $cookie{$phpsessid};

    return {
        $cookie{domain} => {
            $cookie{path} => {
                $phpsessid => {
                    _expires => AnyEvent::HTTP::parse_date $cookie{expires},
                    value    => $cookie{$phpsessid},
                },
            },
        },
        version => 1,
    };
}


1;

■ [binary]バイナリなファイルの読み書き 13:13

use IO:All するとよしなにしてくれるらしい。

my $read_file   = 'read.jpg';
my $write_file  = 'write.jpg';
my $buffer;

use IO::All;

$buffer = io($read_file)->binary->all;
# ごにょごにょ
$buffer > io($write_file);

使わない場合にはこう書いてる

$buffer = _read($read_file);
# ごにょごにょ
_write($write_file, $buffer);

sub _read {
    my $file = shift;
    open my $fh, '<', $file or die $!;
    binmode $fh;
    return do { local $/; <$fh> };
}
sub _write {
    my($file, $bin_data) = @_;
    open my $fh, '>', $file or die $!;
    binmode $fh;
    print $data;
    close $fh;
}

以前の _read 関数はこう

sub _read {
    my $file = shift;
    my $size = -s $file;
    my $buf;

    open my $fh, '<', $file or die $!;
    binmode $fh;
    read $fh, $buf, $size;
    $buf;
}

■ [AnyEvent-HTTP][Tatsumaki-HTTPClient][FriendFeed]AnyEvent::HTTPでFrinedFeedにポストしてコケる（未解決->解決 6/28 0:33） 20:53

（追記）ブックマークで id:mattn さんから頂いたコメント

_authの最下行の手前に chomp $auth; 入れるときっと動くナリ

をやってみたら、ポスト出来ました。 id:mattn さんありがとうございます！

--

AnyEvent::HTTP（と Tatsumaki::HTTPClient）でFriendFeedに Basic認証付きのポストをしようとするとステータスコード 404 が返ってきて、bodyパラメータが必要ですって言われる！

FriendFeedAPIのドキュメントは「FriendFeed API Documentation」にある。

use strict;
use AnyEvent;
use AnyEvent::HTTP;
use MIME::Base64;
use Data::Dumper;

my $api = 'http://friendfeed-api.com/v2/entry';

my $cv = AnyEvent->condvar;
http_request('POST' => $api,
    headers => {
	    'Authorization' => _auth('my username', 'my remotekey') 
    },
    body    => "body=test",
    sub {
        warn Dumper \@_;
        $cv->send;
    },
);

$cv->recv;
exit 0;

sub _auth {
    my($username, $remote_key) = @_;
    my $auth = MIME::Base64::encode(join(":", $username, $remote_key));
    chomp $auth; # add
    "Basic $auth";
}

結果: 401が返ってきてないから、Basic認証は通ってるけど、errorCode で "body-required" って言ってるので、リクエストボディに問題があるっぽい。ちなみにFriendfeedAPIではリクエストボディに必ず body パラメータが必要で、それがリクエストボディに記述がないってエラーコードなんだけど、、、リクエストボディの送信ができてないのか、それともリクエストボディの記述が間違いなのか？

$VAR1 = [
          '{"errorCode":"body-required"}',
          {
            'URL' => 'http://friendfeed-api.com/v2/entry',
            'connection' => 'close',
            'set-cookie' => 'HASFF=1; Path=/,AT=3295780562084656563_1309173742; Path=/',
            'Status' => '404',
            'HTTPVersion' => '1.1',
            'date' => 'Mon, 27 Jun 2011 11:22:22 GMT',
            'content-length' => '29',
            'Reason' => 'Not Found',
            'content-type' => 'text/javascript; charset=UTF-8',
            'server' => 'FriendFeedServer/0.1'
          }
        ];

AnyEvent::HTTPのラッパーの Tatsumaki::HTTPClient を使ってみる

my $client = Tatsumaki::HTTPClient->new;

my $cv = AnyEvent->condvar;
$client->post(
    $api,
    [ body => 'TEST' ],
    Authorization => _auth('my username', 'my remotekey'), 
    sub {
        warn Dumper shift;
        $cv->send;
    }
);

$cv->recv;
exit 0;

結果: 同じ結果

$VAR1 = bless( {
      '_content' => '{"errorCode":"body-required"}',
      '_rc' => '404',
      '_headers' => bless( {
           'connection' => 'close',
           'set-cookie' => 'HASFF=1; Path=/,AT=2762172806905182125_1309174542; Path=/',
           'date' => 'Mon, 27 Jun 2011 11:35:42 GMT',
           'status' => '404',
           'reason' => 'Not Found',
           'httpversion' => '1.1',
           'content-length' => '29',
           'content-type' => 'text/javascript; charset=UTF-8',
           'url' => bless( do{\(my $o = 'http://friendfeed-api.com/v2/entry')}, 'URI::http' ),
           'server' => 'FriendFeedServer/0.1'
         }, 'HTTP::Headers' ),
      '_msg' => 'Not Found'
    }, 'HTTP::Response' );

ちなみに

• LWP::UserAgent を使うとポストできる
• 他のコンテンツへのポストは成功している