トップ > perl

Wedata の Database: ISBN Scraper をテストするスクリプト

perl plagger

確実に私しか使わないと思うけど…。

Item - データベース: ISBN Scraper - wedata に登録してある ISBN を抽出する XPath をテストするスクリプトを書いた。

  1. Wedata からデータ(URL, XPath, SampleURL, SampleISBN)を取得
  2. SampleURL なサイトの HTML を取得
  3. HTML から XPath を評価して ISBN を取得
  4. ISBN と SampleISBN が同じであるかチェック
  5. 結果を YAML 形式で出力
  6. Plagger で YAML から RSS に変換して Gmail する

これを毎朝 cron で実行させておくと、↓こんなメールが届くのでながめてにやにやすることができる！


#!/usr/bin/perl
# isbn scraper checker
use strict;
use warnings;

use DateTime;
use LWP::UserAgent;
use WebService::Wedata;
use XML::LibXML;
use XML::LibXML::XPathContext;
use YAML;

my $wedata = WebService::Wedata->new;
my $database = $wedata->get_database('ISBN Scraper');
my $items = $database->get_items;

my $ua = LWP::UserAgent->new;
$ua->agent('Mozilla/5.0');
my $parser = XML::LibXML->new;
$parser->recover_silently(1);

my $total = 0;
my @entry;
foreach my $item (@{$items}) {
  my $data = $item->{data};
  my $url = $data->{exampleUrl};
  next
    unless $url;

  my @errors;
  ++$total;

  my $resp = $ua->get($url);
  if ($resp->is_success) {
    my $doc = $parser->parse_html_string($resp->content);
    my $xpc = XML::LibXML::XPathContext->new($doc);

    foreach my $key ('Isbn10', 'Isbn13') {
      my $xp = $data->{lc $key};
      my $ex = $data->{'example' . $key};
      next
        unless defined $ex && defined $xp;

      my $isbn = $xpc->findvalue($xp);
      next
        if $isbn eq $ex;

      push @errors,
        sprintf
          '<ul><li>cause: invalid xpath?</li>' .
          '<li>xpath: %s</li><li>value: %s</li><li>isbn: %s</li></ul>',
          $xp, $isbn, $ex;
    }

  } else {
    push @errors,
      sprintf '<ul><li>cause: %s</li></ul>', $resp->status_line;
  }

  next
    unless @errors;

  push @entry, {
    title => $item->{name},
    link => $item->{resource_url},
    body => join '<br>', @errors
  };
}

my $res = {
  entry => @entry ? \@entry : [{ title => 'no error!'}],
  title => sprintf
    'ISBN Scraper Daily Report(%s) %s %d/%d',
    DateTime->now->ymd('/'), @entry ? 'NG' : 'OK', $total - scalar @entry, $total
};
print Dump $res;

plugins:
  - module: Subscription::Config
    config:
      feed:
        - url: script:/path/to/check-isbnscraper.pl
  - module: CustomFeed::Script
  - module: Publish::Gmail
    config:
      mailto: xxxxx@gmail.com
      mailfrom: xxxxx@gmail.com
      mailroute:
        via: smtp_tls
        host: smtp.gmail.com:587
        username: xxxxx
        password: xxxxx

Google め

perl google 
#!/usr/bin/perl
use strict;
use warnings;
use utf8;

use YAML;
use Geo::Coder::Google;

my $geocoder = Geo::Coder::Google->new( apikey => 'Your API Key' );
my $location = $geocoder->geocode( location => '国立国会図書館' );

binmode STDOUT, ':utf8';
print Dump $location;

↑だと↓で、

Content-Type: text/javascript; charset=UTF-8; charset=ISO-8859-1
---
AddressDetails:
  Accuracy: 1
  Country:
    AddressLine:
      - '           '
    CountryNameCode: JP
Point:
  coordinates:
    - 139.744824
    - 35.675871
    - 0
address: '             '
id: p1
$geocoder->ua(LWP::UserAgent->new( agent => 'Mozilla/5.0' ));

↑すると↓。

Content-Type: text/javascript; charset=UTF-8; charset=UTF-8
---
AddressDetails:
  Accuracy: 1
  Country:
    AddressLine:
      - 国立国会図書館国会分館
    CountryNameCode: JP
Point:
  coordinates:
    - 139.744824
    - 35.675871
    - 0
address: 日本国立国会図書館国会分館
id: p1

あいかわらず charset が2個あるのにはびっくりだ。

Twitter の Archive から KML

twitter perl

via ttp://movatwitter.jugem.jp/?eid=60
モバツイの写ツがジオタグを付加できるようになったようなので時々試していたんだけど、私のやり方が悪いのか携帯が悪いのか全く付加されない。ExifTool がなんか警告だすのでこれが怪しいと思っている。
くやしいので Twitter の Archive から KML を生成して Google マップで表示してみた。うーん…。

http://maps.google.co.jp/?q=http://hetappi.pm.googlepages.com/hetappi-location-log.kml

一応のっけとくけど使い捨てなので。

#!/usr/bin/perl
use strict;
use warnings;
use utf8;

use URI;
use LWP::UserAgent;
use Web::Scraper;
use Geo::Coder::Google;
use Geo::GoogleEarth::Document;

my @statuses = get_twitter_archive('hetappi');

my $geocoder = Geo::Coder::Google->new( apikey => 'Your API Key' );
my $ua = LWP::UserAgent->new( agent => 'Mozilla/5.0', keepalive => 1 );
$geocoder->ua($ua);

my $doc = Geo::GoogleEarth::Document->new;
foreach my $s(@statuses) {
  next
    unless $s->{status} =~ /L:(.+?)[\[\s]/;

  my $name = $1;
  my $location = $geocoder->geocode( location => $1 );
  next
    unless $location;

  my $status = $s->{status};
  if ($status =~ m!<a href="http://f\.hatena\.ne\.jp/twitter/((\d{8})\d{6})"!) {
    my $img = sprintf '<img src="http://f.hatena.ne.jp/images/fotolife/t/twitter/%s/%s.jpg">', $2, $1;
    $status =~ s!http://f\.hatena\.ne.jp/twitt\.\.\.!$img!;
  }

  $doc->Placemark(
    name => $name,
    lat => $location->{Point}->{coordinates}[1],
    lon => $location->{Point}->{coordinates}[0],
    address => $location->{address},
    description => $status . '<br>' . $s->{date}
  );
}

binmode STDOUT, ':utf8';
print $doc->render();

sub get_twitter_archive {
  my $id = shift;

  my $scraper = scraper {
    process '//table[@id="timeline"]/tr', 'statuses[]' => scraper {
      process '//.', 'id' => ['@id', sub { $_[0] =~ /status_(\d+)/; $1; }];
      process '//span[@class="entry-content"]', 'status' => 'HTML';
      process '//abbr', 'date' => '@title';
    };
  };

  my $ua = LWP::UserAgent->new( keepalive => 1 );
  $scraper->user_agent($ua);

  my @statuses;
  for (my $page = 1; ; ++$page) {
    my $uri = URI->new(sprintf 'http://twitter.com/%s?page=%s', $id, $page);
    my $res = $scraper->scrape($uri);
    last
      unless $res->{statuses};
    push @statuses, @{$res->{statuses}};
  }

  @statuses;
}

Yahoo! ファイナンス変った？

perl stock

Yahoo! ファイナンスから持ち株の合計評価額を取得してはてなグラフに登録するようにしてあったのだけど、何か変わったのか最近うまく動いていなかったみたい。
center タグって久々にみた希ガス。

#!/usr/bin/perl
use strict;
use warnings;

use URI;
use Readonly;
use DateTime;
use LWP::UserAgent;
use Web::Scraper;
use YAML;

Readonly my $USERNAME => 'hetappi';
Readonly my $PASSWD   => 'xxxxxxx';
Readonly my $GRAPH    => 'stock';
Readonly my @STOCKS   => (
  ['2121.t', 5], ['3715.t', 1]);

my $ua = LWP::UserAgent->new(keep_alive => 1);
$Web::Scraper::UserAgent = $ua;

my $ws = scraper {
  process
    '//center/div[@class="invest"]/table[2]/tr[2]/td[5]/b',
    price => [ 'text', sub { s/,//g } ];
};

my $price = 0;
foreach my $stock(@STOCKS) {
  $price +=
    $ws->scrape(URI->new('http://quote.yahoo.co.jp/q?s=' . $stock->[0]))->{price}
      * $stock->[1];
}

$ua->credentials('graph.hatena.ne.jp:80', '', $USERNAME, $PASSWD);
my $res = $ua->post(
  'http://graph.hatena.ne.jp/api/post',
  { graphname => $GRAPH, date => DateTime->now->ymd, value => $price });

順調に下がってる…。
stock

あけおめ

perl

素敵な feed を吐くようになったので書きなおした。
ffmpeg はキー入力をチェックしているのでバックグラウンドで動かせないみたい。無効にするオプションを追加すればいいのに。
なので、強引に

yes | ffmpeg -i ...

で回避した。これで寝ている間にサーバで（ｒｙ。

#!/usr/bin/perl
use strict;
use warnings;
use utf8;

use Readonly;
use URI;
use XML::Feed;
use LWP::UserAgent;

Readonly my $VIDEOSDIR => 'videos';

binmode STDOUT, ':utf8';

my $newfeed = XML::Feed->parse(
  URI->new('http://pulpsite.net/youravhost/rss_enclosure'))
    or die XML::Feed->errstr;

my $ua = LWP::UserAgent->new(keep_alive => 1);
mkdir $VIDEOSDIR
  unless -d $VIDEOSDIR;

foreach my $entry ($newfeed->entries) {
  my ($file, $actress) =
    $entry->title =~ /(.+)\..+\s-\s(.+)と思われるYourAVHost/;
  my $dir = "$VIDEOSDIR/$actress";
  mkdir $dir
    unless -d $dir;

  my $flv = "$dir/$file.flv";
  my $mp4 = "$dir/$file.mp4";
  next
    if -f $mp4;

  print $mp4, "\n";
  my $resp = $ua->request(
    HTTP::Request->new(GET => $entry->{entry}->{enclosure}->{url}), $flv);
  $resp->is_success
    or die $resp->status_line;

  system "yes | ffmpeg -sameq -i $flv $mp4";
  unlink $flv;
}

YourAVHost をスクレイピング

perl

私は ero ではないですが erogeek さんを尊敬しています。
表には出さないけど絶対みんなやってるよね。改良の余地ありありです。

#!/usr/bin/perl
use strict;
use warnings;

use URI;
use URI::Escape 'uri_unescape';
use HTTP::Request;
use LWP::UserAgent;
use Web::Scraper;

my $ua = LWP::UserAgent->new(keep_alive => 1);
$Web::Scraper::UserAgent = $ua;

my $avs = scraper {
  process '//div[@class="entry"]', 'avs[]' => scraper {
    process '//h2/a', name => 'text';
    process '//div/div/div/a[img]', 'flvs[]' => [
      '@href', sub { sleep 1; print $_->as_string, "\n"; $_->as_string }, \&yfh2flv ];
  }
}->scrape(URI->new('http://pulpsite.net/youravhost/'))->{avs};

foreach (@{$avs}) {
  mkdir $_->{name}
    unless -d $_->{name};
  foreach my $flv (@{$_->{flvs}}) {
    my ($file) = $flv =~ m!([^/]+\.flv)!;
    my $path = $_->{name} . '/' . $file;
    next
      if -f $path;
    print $file, "\n";
    $ua->request(HTTP::Request->new(GET => $flv), $path);
    sleep 1;
  }
};

sub yfh2flv {
  my $yfh = shift;
  scraper {
    process '//object/param[@name="movie"]', flv => sub {
      $_->attr('value') =~ /video=([^&]+)/;
      my $resp = $ua->get(uri_unescape($1));
      $resp->is_success
        or die;
      $resp->content =~ /video_id=([^&]+)/;
      uri_unescape($1);
    }
  }->scrape(URI->new($yfh))->{flv};
}

[h@lily eg]$ ls -R
.:
yah.pl      きららかおり  一色志乃  桜月舞      瀬戸由衣  早乙女優  竹内あい  瞳めい    姫咲しゅり  友崎亜希
かすみ果穂  鮎川なお      橘ますみ  山咲あかり  倉持茜    大沢佑香  桃井りか  美波さら  片瀬まこ    恋野恋

./かすみ果穂:
146fc5e53c4dad621171bdb0da71904e.flv  8afe76be86f40b6e318948eb2c8a219c.flv  ddc733538d0cba6a967765b6bbd9d94e.flv
4ae92a846c38c1760ecabe5e783e13fc.flv  a1e4a223039f15b9bdc90ec1cc1703ff.flv  ddfeededcbead61bb783248f4f60441a.flv
4e476eb1febce5d1134e03f233f78ab6.flv  b101d3ee971cf6ecab9f9b5b9aa17cd2.flv  e753f67f4d48f492648c376197aa9dcc.flv
66e56420ac6f938e0c7da9321d367265.flv  b614aa03ca610f8a5a7abf2c6e223667.flv  eb80d43ae86b0db37960d16f1bd39f4a.flv
（略）

2007/12/28 追記
これ使えばよかたー。
http://yusukebe.com/tech/archives/20071227/013225.html

東京図書館マップ

google library perl

以前、都内の図書館やらをマーキングする Google マイマップを作ったのだけど、手作業でマーカーを追加するしかなく非常にめんどうだったので放置していた。
が、いつのまにか KML インポート機能が追加されていたので、これを使ってさっくり完成させました。


図書館のデータはなぜか既にある。

[h@lily gmap]$ ls libs*.txt
libs-national.txt  libs-tokyo-east.txt  libs-tokyo-west.txt
[h@lily gmap]$ cat libs-national.txt 
国立,国会図書館,東京都千代田区永田町1-10-1,35.678418,139.744149
#国立,国会図書館関西館,京都府相楽郡精華町精華台8-1-3,34.74368,135.77009
[h@lily gmap]$

KML は Geo::GoogleEarth::Document なるものが CPAN にあったのでこれを使ってみた。載せるまでもないけど一応。

#!/usr/bin/perl
use strict;
use warnings;
use Geo::GoogleEarth::Document;

my @cols = qw/blue red green lightblue yellow purple pink orange/;

my $doc = Geo::GoogleEarth::Document->new(name => '東京図書館マップ');
foreach my $col (@cols) {
  $doc->Style(id => $col, iconHref => "http://maps.google.co.jp/mapfiles/ms/icons/$col.png");
}

my $idx = 0;
my $last;
while (<>) {
  chomp;
  my @c = split ',';
  next
    if $c[0] =~ /^#/;
  $idx = $idx < $#cols ? $idx + 1 : 0
    if $last && $last ne $c[0];
  $doc->Placemark(
    name => $c[0] . $c[1], lat => $c[3], lon => $c[4], address => $c[2], styleUrl => "#$cols[$idx]");
  $last = $c[0];
}

print $doc->render();

[h@lily gmap]$ cat libs-*.txt | ./mkkml.pl > libs-tokyo.kml
[h@lily gmap]$ cat libs-tokyo.kml
<?xml version='1.0' standalone='yes'?>
<Document>
  <name>東京図書館マップ</name>
  <Placemark>
    <name>国立国会図書館</name>
    <Point>
      <coordinates>139.744149,35.678418,0</coordinates>
    </Point>
    <address>東京都千代田区永田町1-10-1</address>
    <styleUrl>#blue</styleUrl>
  </Placemark>
  <Placemark>
...（略）...
  </Style>
  <Style id="orange">
    <IconStyle>
      <Icon>
        <href>http://maps.google.co.jp/mapfiles/ms/icons/orange.png</href>
      </Icon>
    </IconStyle>
  </Style>
</Document>

間違って何度もインポートするのは嫌なので Google Earth で確認してみた。予想通り２、３度やり直したよ。
ローカルディスクからインポートできるようなのだがなぜか失敗するので、一度どこかにアップロードし URL 指定でインポートすると成功するみたい。


東京図書館マップ

東京は図書館が多すぎて一度にすべてを表示できないみたい…。