Big Sky

iTunesのライブラリ情報XMLファイルをアップロードする事で自分に合ったアーティスト情報を教えてくれるサービス、「veena!」の検索ボックスを使って、指定のアーティストに関連する

• YouTube動画
• Yahooオークション情報

をWeb::Scraperでスクレイピングしてみようと思います。
ソースはそれ程難しくもなく

#!/usr/bin/perl

use strict;
use warnings;

use URI;
use URI::Escape qw(uri_escape_utf8 uri_unescape);
use Web::Scraper;
use YAML::Syck;

my $artist = shift || 'Ozzy Ozbourne';
my $uri = URI->new('http://www.veena.jp/srch_artist.php?artist_name='
    . uri_escape_utf8($artist));

my $youtube_list = scraper {
    process '//table[@class="info_tbl"]/tr/td',
        'video[]' => scraper {
            process '//a[1]', url => sub {
                my $url = shift->attr('href');
                $url =~ s/^.*\?url=(.*)$/$1/;
                uri_unescape($url);
            };
            process '//a[2]', title => 'TEXT';
            process '//img', image => '@src';
        };
    result 'video';
};

my $auction_list = scraper {
    process '//table[@class="info_tbl"]/tr/td',
        'auction[]' => scraper {
            process '//a[1]', url => '@href';
            process '//a[2]', title => 'TEXT';
            process '//img', image => '@src';
        };
    result 'auction';
};

my $artist_list = scraper {
    process '//a[contains(@href, "artist.php")]',
        'artists[]' => scraper {
            process 'a', id => sub {
                my $url = shift->attr('href');
                $url =~ s/^.*id=(.*)$/$1/;
                $url;
            };
            process 'a', 'youtube' => sub {
                my $url = shift->attr('href');
                $url =~ s/artist\.php/http:\/\/veena.jp\/list_youtube\.php/;
                my $list = $youtube_list->scrape(URI->new($url));
                \@$list;
            };
            process 'a', 'auction' => sub {
                my $url = shift->attr('href');
                $url =~ s/artist\.php/list_auction\.php/;
                my $list = $auction_list->scrape(URI->new_abs($url, $uri));
                \@$list;
            };
            process 'a', name => 'TEXT';
        }
};
my $result = $artist_list->scrape($uri);
warn Dump $result;

って感じ。YouTube動画情報一覧とYahooオークション情報はアーティスト情報にぶら下がる形で出力したかったので検索結果一覧用のscraperとその結果を取得するscraperを親子関係にしてあります。
結構一覧としてはキレイに出力されているかと思います。

---
artists: 
  - 
    auction: 
      - 
        image: !!perl/scalar:URI::http http://ac.c.yimg.jp/7/1026/1783/000/img305.auctions.yahoo.co.jp/users/6/4/6/7/rosiertrueblue-thumb-119657918759294.jpg
        title: Ozzy Osbourne
        url: !!perl/scalar:URI::http http://page.auctions.yahoo.co.jp/jp/auction/108393777
      - 
        image: !!perl/scalar:URI::http http://ac.c.yimg.jp/7/1022/1783/000/img245.auctions.yahoo.co.jp/users/6/4/6/7/rosiertrueblue-thumb-119657997018368.jpg
        title: Ozzy Osbourne
        url: !!perl/scalar:URI::http http://page11.auctions.yahoo.co.jp/jp/auction/n61267094
      - 
        image: !!perl/scalar:URI::http http://a1017.lm.a.yimg.com/7/1017/1783/000/img257.auctions.yahoo.co.jp/users/8/2/8/3/kokita74-thumb-119486785113507.jpg
        title: Ozzy Osbourne
        url: !!perl/scalar:URI::http http://page8.auctions.yahoo.co.jp/jp/auction/h52088580
   ...
    id: 216546
    name: Randy Rhoads (Ozzy Ozbourne)
    youtube:
      -
        image: !!perl/scalar:URI::http http://img.youtube.com/vi/MEUbYkLe_wo/default.jpg
        title: Ozzy Ozbourne's top 10 songs
        url: http://www.youtube.com/watch?v=MEUbYkLe_wo
      - 
        image: !!perl/scalar:URI::http http://img.youtube.com/vi/GLtjWi4qkIY/default.jpg
        title: Goodbye to Romance - Ozzy/Randy Rhoads (solo)
        url: http://www.youtube.com/watch?v=GLtjWi4qkIY
      - 
        image: !!perl/scalar:URI::http http://img.youtube.com/vi/AQqbNHhBWcI/default.jpg
        title: iron man
        url: http://www.youtube.com/watch?v=AQqbNHhBWcI
   ...

Ozzy OzbourneのキーワードでRandy Rhoadsも引っかかってウハウハです。
で、このYAMLをどうするか...

use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
$ua->timeout(10);
$ua->agent('Mozilla');
for my $artist (@{$result->{artists}}) {
  for my $video (@{$artist->{youtube}}) {
    my $url = $video->{url};
    my $req = HTTP::Request->new(GET => $url);
    $req->header('Accept-Encoding', 'identity');
    my $res = $ua->request($req);
    if ($res->is_error) {
      if ((my $verify_url = $res->request->uri) =~ /\/verify_age\?/) {
        my $verify_req = HTTP::Request->new(POST => $verify_url, {action_confirm => 'Confirm'});
        $res = $ua->request($verify_req);
        $res = $ua->request($req) if $res->is_success;
      }
    }
    if ($res->content =~ /video_id=([^&]+)&l=\d+&t=([^&]+)/gms) {
      my $flv = "http://youtube.com/get_video?video_id=$1&t=$2";
      print "Downloading $flv\n";
      my $download_req = HTTP::Request->new(GET => $flv);
      $download_req->referer($url);
      my $res = $ua->request($download_req);
      if ($res->is_success) {
        open FH, ">$2.flv";
        binmode FH;
        print FH $res->content;
        close FH;
        print "Downloaded $2.flv\n";
      } else {
        print "Failed to download $2.flv\n";
      }
    } else {
      print "Not found flv file\n";
    }
  }
}

やっぱこうなりますわね...

mattn the crazy train scraper!

タレントスケジュールなんてサイトを見つけたので、さっそくスクレイピング。
ドキュメントに同じid属性が複数あるという、なんともダイナミックなHTMLにもめげず作り上げたのが以下

#!/usr/bin/perl

use encoding 'utf-8';
use strict;
use warnings;
use Encode qw(from_to);
use URI;
use URI::Escape qw(uri_escape_utf8);
use Web::Scraper;
use YAML;

if ($^O eq 'MSWin32') {
    binmode(STDERR, ':encoding(shift_jis)');
    Encode::from_to($ARGV[0], 'cp932', 'utf-8');
}
my $talent = shift || '小島よしお';

my $talent_schedule = scraper {
    process '//div[@class="find_bl"]/following-sibling::*[1]//td', day => 'TEXT';
    process '//div[@class="find_bl"]/following-sibling::*[1]//td/div',
        'schedule[]' => scraper {
            process 'div', media => sub { my $m = $_->attr('class'); $m =~ s/^icon_//g; $m };
            process '/div/a', url => '@href';
            process '/div/a', title => 'TEXT';
            process '/div/node()[1]', timespan => sub {
                my $s = $_->string_value;
                $s =~ s/　//;
                $s =~ s/(^|[^\d])(\d):(\d\d)/0$2:$3/g;
                my @span = split(/[^\d:]/, $s);
                \@span;
            };
        };
    result qw/day schedule/;
};
my $uri = URI->new('http://talent-schedule.jp/'.uri_escape_utf8($talent));
my $oppappi_schedule = $talent_schedule->scrape($uri);
warn Dump $oppappi_schedule;

ちょっと日付まわりで苦労してますが...

小島よしおって、結構番組出てますねぇ。

でもそんなの関係ry)

Web::Scraper使うときに、scraperコマンドを使って頑張る人もいれば、FirebugのDOMツリーで「XPathをコピー」とやっている人もいるでしょう。
前者の場合、端末でスクロールアウトするHTMLを見ながらXPathをこさえて間違ったらズラズラズラ…と画面が流れて行ってしまいます。後者の場合は、CLASSやID属性を使わないXPathが出来上がってしまいます。
映画に出てくるHackerの如く一発でXPathを決められればそれは素晴らしい事だと思いますが、いかんせん幾度か失敗しますよね。
で、何回もXPathを確かめられるツールが欲しいなと思い、perl-GTK2で作ってみました。

画面はこんな感じ

引数に「http://b.hatena.ne.jp/」を付けて起動したらこんな感じ

URLを変更して「Get」をクリックすれば再読み込みします。
そして、はてなブックマークトップページの「注目の動画」部分にある画像一覧を取得する為に

//a[text()="注目の動画"]/../../..//img

というXPathを書いて「Update」をクリックすれば

こんな感じのHTMLが出来上がります。
あとはこれをWeb::Scraperのprocess部分に貼っつけるだけ。

ちなみにXPathでの属性値参照も出来ますので、はてなブックマークトップページで

//meta[@http-equiv="Content-Type"]/@content

というXPathを書けば

content="text/html; charset=UTF-8"

という結果が返ります。
起動にはCPANからGtk2モジュールをインストールする必要があります。HTMLのパース方法やノードの取得方法等は大体Web::Scraperと合わせていますので、Web::Scraperが動く環境にGtk2をインストールすれば動くかと思います。
また画面はLinux上で起動した物ですが、UN*Xらしい事は一切やってませんのでWindowsでも動作するかと思います。

ダウンロード：WebScraperHelper.pl

もう少し機能を足そうかと思いましたが、今日はもうギブアップ。寝ます。

Journal of miyagawa (1653)
TEXTや@srcといったショートカット結果に対して任意のフィルタをかませる事が出来るようになったようです。
これまでのように

process "span.entry-content", comment => 'TEXT';

と指定していた部分を

process "span.entry-content", comment => [ 'TEXT', 'MyFilter' ];

と記述出来るようになったのです。
MyFilterは「Web::Scraper::Filter::MyFilter」というパッケージで定義され、filterプロシージャが呼び出されます。

さっそく、twitterの発言では70%近くが英語のmiyagawaさんの発言をスクレイピングし、エキサイト翻訳で日本語にフィルタするサンプルを作って見ました。

package Web::Scraper::Filter::EnglishToJapanese;
use base qw( Web::Scraper::Filter );
use warnings;
use LWP::UserAgent;
use HTTP::Request::Common qw(POST);

sub filter {
    my($self, $value) = @_;
    my $req = POST( 'http://www.excite.co.jp/world/english/',
        [before => $value, wb_lp => 'ENJA'] );
    my $data = $Web::Scraper::UserAgent->request($req)->content;
    $data =~ s!\x0D|\x0A!!g;
    $data =~ s/^.*?<textarea[^>]*name="after"[^>]*>(.*?)<\/textarea>.*?$/$1/;
    return $data;
}

1;

use URI;
use Web::Scraper;

my $twitter = scraper {
    process 'td.content',
        'comments[]' => scraper {
            process "span.entry-content", comment => [ 'TEXT', 'EnglishToJapanese' ];
        };
    result 'comments';
};
my $comments = $twitter->scrape( URI->new("http://twitter.com/miyagawa/") );
use YAML;
warn Dump $comments;

で、結果

---
- comment: ' ウェブログを作られた http://tinyurl.com/2xldch '
- comment: ' ウェブを出荷します:、:フィルタサポートがある削り器0.21_01。 バージョン番号が言うようにこれがdevリリースであるのに注意してください。'
- comment: ' 見ます。'
- comment: ' ダッシュボード懺悔室、Yellowcard、少年は少女が好きです: 多くの誘惑が今月のSF warfieldで http://www.ticketmaster.com.. を見せます。 ... '
- comment: ' 100のコメント. diggの上のトップページングのためのtakesako、おめでとう、ワオ490、diggs、 http://tinyurl.com/255ht7 '
- comment: ' スクリーンからStreoパート2までNFGを聞くのがあります。 輝かしいアルバム'
- comment: ' @hanekomu、うん、それはしゃぶられます。 そこでは、日本で同じです。 請求先の住所が米国にある状態で、運よく私はcreditcardsを持っています。'
- comment: ' Dashboard Confessionalの新しいアルバム http://www.amazon.com/gp/pr.. を購入した、アマゾン'
- comment: ' より古いリンクの取り逃がすことは一時的であるように思えました。私がfriendfeedされることへのスイッチかJaikuに好きでないので、 http://tinyurl.com/2gq4uj は少し救いました。'
- comment: ' したがって、さえずりの丁付けはいつまでも、行きましたか? そうだとすれば、私は、確実にさえずりを使用するのを止めるつもりです。'
- comment: ' http://subtech.g.hatena.ne... のウェブログを作りました。 Yappo++typester++Plagger++'
- comment: ' @Yappo++'
- comment: ' IT Crowd s02e05を見ます。'
- comment: ' ep1を見ます。'
- comment: ' 12ドルでmonoprice.comからの外でコンポーネントケーブルと結合器を私のPSPビデオに購入しました。 すさまじい値'
- comment: ' 作成されて、playstationのための削り器は、給送 http://tinyurl.com/yqbtjb plagger++ウェブを格納して、発行しています:、:削り器++'
- comment: ' http://feeds.feedburner.com.. に加入しました。'
- comment: ' 私の2週間のabsenseでは、私はWaMu、Master、およびCapitalOneから10の+クレジットカード申し出を受けました。 ため息をついてください。'
- comment: ' ビールを飲みます。'

エキサイト翻訳の部分をスクレイピングするんが筋ちゃうんかいな！というツッコミは無しでお願いします。

こういう使い方もあるね。
で、どうする...って訳でもないけど
※そういうの、「使い道ない」っていうんだよね。そうだよね。

#!/usr/bin/perl

use strict;
use warnings;

use Web::Scraper;
use URI;
use YAML;

my $airlines_accident_scraper = scraper {
  process '//div[@class="entry-content"]//table/tr',
    'airlines[]' => scraper {
      process '//td[1]', title => 'TEXT';
      process '//td[2]', last_accident => 'TEXT';
      process '//td[3]', flight_count => 'TEXT';
      process '//td[4]', death_accident => 'TEXT';
      process '//td[5]', death_rate => 'TEXT';
      process '//td[6]', accident_incidence => 'TEXT';
      process '//td[7]', total_rank => 'TEXT';
    };
  result 'airlines';
};

my $list = $airlines_accident_scraper->scrape(URI->new('http://www.manji.com/jp/2007/08/post_22.html'));
use YAML;
warn Dump $list;

リストは、マスコミが報じない危険な航空会社リストから拝借。

余談ですが...
Web::Scraper 0.16あたりから、@参照するとstringでなく、URIか返ってくるようになってるので、「認証付きのページで@srcを拾い上げて、認証無しでは参照出来ない画像を落とす」なんて事に使えるようになったみたいです。

Web::Scraper 0.15とcisco_scraper.pl

問題が一つ。添削してくださったパッチだと

process '//li/node()[4]', 'title' => sub {$_->string_value;};

となっているのですが、4番目とは限らないんです。
たとえば、
http://www.cisco-records.co.jp/html/item/004/010/item393180.html
は何曲か試聴サンプルがないために、この処理だと取得できないです。

おろろ...
これはtext()でTextNodeを参照するしかないですね。
ただ、text()では改行等のゴミまで拾ってしまうので、以下のようにnormalize-space()で空文字ノードを省いています。
もしかすると、node()[2]も同じように修正した方がいいかもしれませんね。

#!/usr/bin/perl

use strict;
use warnings;

use Web::Scraper;
use URI;
use YAML;
use Data::Dumper;

my $uri = shift;

my %scraper;

$scraper{'link'} = scraper {
    process 'a', 'name' => 'TEXT';
    process 'a', 'uri'  => '@href';
    result qw/name uri/;
};

$scraper{'genre'} = scraper {
    process '//a[1]', 'top'   => $scraper{link};
    process '//a[2]', 'style' => $scraper{link};
    result qw/top style/;
};

$scraper{'track'} = scraper {
    process '//li/text()[normalize-space(.)!=""]', 'title' => sub {
        my $s = $_->as_XML;
        $s =~ s/\s+$//;
        return $s;
    };
    process 'li>a', 'uri' => '@href';
    result qw/title uri/;
};

$scraper{'item'} = scraper {
    process 'td.de_title',      'title'  => 'TEXT';
    process 'td.de_artist',     'artist' => 'TEXT';
    process 'td.nm_jacket>img', 'image'  => '@src';
    process 'td.de_price',              'price'   => 'TEXT';
    process 'td.de_label>a',            'label'   => $scraper{link};
    process 'td.de_genre',              'genre'   => $scraper{genre};
    process 'td[headers="de_format"]',  'format'  => 'TEXT';
    process 'td[headers="de_release"]', 'release' => 'TEXT';
    process 'td[headers="de_country"]', 'country' => 'TEXT';
    process 'td[headers="de_sheet"]',   'sheet'   => 'TEXT';
    process 'td[headers="de_arrival"]', 'arrival' => 'TEXT';
    process 'td[headers="de_nomber"]',  'number'  => 'TEXT';
    process '//p[@class="de_star"]/node()[2]', 'star' => 'TEXT';
    process 'ul[id="de_sound"]>li', 'tracks[]' => $scraper{track};
    result
        qw/title artist image price label genre format release release country sheet arrival number star tracks/;
};

my $item = $scraper{'item'}->scrape( URI->new($uri) );
warn Dump $item;

あと、ブックマークコメントで

コールバック渡しだと相対URLの展開がされないのは僕だけ？

との事ですが...少し調べてみた所Web::Scraper側でパッチが必要かもしれません。
以下svn/trunk(rev2351)からの差分です。

Index: lib/Web/Scraper.pm
===================================================================
--- lib/Web/Scraper.pm  (revision 2351)
+++ lib/Web/Scraper.pm  (working copy)
@@ -152,12 +152,12 @@
         local $_ = $node;
         return $val->($node);
     } elsif (blessed($val) && $val->isa('Web::Scraper')) {
-        return $val->scrape($node);
+        return $val->scrape($node, $uri);
     } elsif ($val =~ s!^@!!) {
         my $value =  $node->attr($val);
         if ($uri && is_link_element($node, $val)) {
             require URI;
-            $value = URI->new_abs($value, $uri);
+            $value = URI->new_abs($value, $uri)->as_string;
         }
         return $value;
     } elsif (lc($val) eq 'content' || lc($val) eq 'text') {

Web::Scraperの0.15がリリースされたので、色々試してみてます。
ほんのりと変わった所を調べてみます。

UserAgentが置き換えられるようになった

uaのスコープを変えて頂けたので、先日の「WWW::MechanizeとWeb::Scraperでtwitterのfriendsを全部取ってみる」でやった以下の様な無理やりなUA置き換えでなく

undef &Web::Scraper::__ua;
*Web::Scraper::__ua = sub {
    $mech;
};

以下のようにキレイな置き換えが出来るようになります。

$Web::Scraper::UserAgent = $mech;

スコープもourになってますから、別のパッケージ作るときにも便利かもしれませんね。

ショートカットとしてRAWが使えるようになった

これはインラインのjavascriptをそのままスクレイピングするのに使えますね。

#!/usr/bin/perl

use strict;
use warnings;
use Web::Scraper;
use URI;
use YAML;
use Data::Dumper;

my $my_script = scraper {
    process '//script[2]', 'code' => 'raw';
    result 'code';
};
my $item = $my_script->scrape( URI->new("http://mattn.kaoriya.net") );
warn Dump $item;

この例では、はてなスターのトークン設定部が取得出来ます。

--- |-
<!--
Hatena.Star.Token = '43aa5d7954c8fc062faae4eaaa864913599c277b';
-->

※htmlというショートカットでも使えます。

相対URLから絶対URLを自前で生成しなくてもよくなった

「お腹が空いてきたのでWeb::Scraperでモスバーガーのメニューをスクレイピング」でやったように、今までは

process '.', url => sub {URI->new_abs($_->attr('href'), $uri)->as_string;};

というコードが必要でしたが、「@」による属性参照でリンクエレメントであるようならば、自動的に絶対URLを生成してくれます。
上のようなコードも

process '.', url => '@href';

と楽になりますね。
以上が私が0.13と0.15のdiffをざーーーーと見た感じの変更点です。

おまけ

今日はこれに付け加え、一つtipsを...
Web::ScraperでCISCO RECORDSをスクレーピングより

たとえば

<li><span>1</span>Track 1</li>

というHTMLから"Track1"だけを抽出しようにも

process 'li', 'title' => 'TEXT';

だと

1Track1

なんて結果になるのでそれを回避するために

process 'li', 'title' => sub {
    my $elem = shift;
    $elem->find_by_tag_name('span')->delete;
    return $elem->as_text;
};

なんてことをしてるのですが、もっといい方法があるはず。

treeを壊さずやるとすれば、TextNodeを参照するのがいいかと思います。
例えば、XPathのnode()を使い、番号指定で取得します。だた現状のWeb::ScraperではTextNodeはショートカットで参照出来ませんので、以下のようにstring_valueを返すように手を加えると上手く行きます。
※相対URLの修正も含んでいます。

--- cisco_scraper.pl    Tue Sep 18 13:30:20 2007
+++ cisco_scraper2.pl   Tue Sep 18 14:12:49 2007
@@ -14,9 +14,7 @@
 
 $scraper{'link'} = scraper {
     process 'a', 'name' => 'TEXT';
-    process 'a', 'uri'  => sub {
-        return URI->new_abs( $_->attr('href'), $uri )->as_string;
-    };
+    process 'a', 'uri'  => '@href';
     result qw/name uri/;
 };
 
@@ -27,23 +25,15 @@
 };
 
 $scraper{'track'} = scraper {
-    process 'li', 'title' => sub {
-        my $elem = shift;
-        $elem->find_by_tag_name('span')->delete;
-        return $elem->as_text;
-    };
-    process 'li>a', 'uri' => sub {
-     &n