LDRのピンを取得してはてな記法にしてクリップボードにコピーしたい(3)

先日書いたスクリプトは色々不備があったので、修正。
修正点は

• WWW::Mechanizeを使ってPerlだけでLDR pinを取れるようにした。
  • 参考資料1: http://d.hatena.ne.jp/nTeTs/20060422/1145637483:TITLE=livedoor ReaderのAPI一覧 - ヨコナビ
  • 参考資料2: http://walrus.vox.com/library/post/livedoor-reader%E3%81%AE%E3%83%94%E3%83%B3%E3%82%92%E5%8F%96%E5%BE%97%E3%81%99%E3%82%8B%E3%82%B9%E3%82%AF%E3%83%AA%E3%83%97%E3%83%88.html:TITLE=livedoor Readerのピンを取得するスクリプト - Vox
  • 参考資料2のスクリプトはPerl5.8では動いたけど5.10だと動かないみたい。いや5.8だとなぜか動くと言ったほうがいいのかも。
• リダイレクト先の取得時のtimeout対策
• ソース取得先の文字コード判定失敗対策
  • Encode::decodeでGuessを失敗するとdieするのね・・。
• テンポラリファイルを作らないようにした。

redirect先取得処理についてですが、数が増えていくと時間がかかりますのでデフォルトはOFFにしておきます。またUserAgentはlibwwwのままだとSPAM対策で取れないこともあるかもしれませんが、基本的にそのサイトのポリシーに従った使い方が必要と思うのでこのまま。この場合、元のpinのURLが挿入されます。
# そもそもこんなニッチなスクリプトを使う人いないと思いますが念のため。
(半分は自分のために)最後に動作確認環境もメモしておきます。ActivePerl 5.10.0.1004。以下、使用Module。

Win32::Clipboard	0.55	JSON	2.12
Encode	2.29	HTML::TokeParser	2.37
WWW::Mechanize	1.34rc	LWP	5.814

#!C:\Perl\bin\perl
# LDRのピンを取得してはてな記法にしてクリップボードにコピーする
use strict;
use warnings;
use utf8;

use WWW::Mechanize;
use JSON;
use Win32::Clipboard;
use Encode        qw(encode decode);
use Encode::Guess qw(euc-jp shiftjis 7bit-jis);
use HTML::TokeParser;
use LWP::UserAgent;

my $OPT = {
    REALLINK   => 0,   # 1: redirect先までURL抽出 0: 抽出しない
    UA         => qq(libwww-perl),# UserAgent指定
    ID         => "",  # livedoorID
    PASS       => "",  # livedoorパスワード
};

&Main;
sub Main {
    my $json_pindata = &GetLDRPinData;# 取得
    my $hatenadata = &JSON2Hatena($json_pindata);# 整形
    # 出力
    Win32::Clipboard::Set(join("\n",@$hatenadata));
}
# 1. LDR PinをWWW::MechanizeでJSON形式で取得する。
sub GetLDRPinData {
    my $mech = WWW::Mechanize->new;
    $mech->get('http://member.livedoor.com/login/index'); # login
    $mech->submit_form(fields =>{
        livedoor_id => $OPT->{ID},password => $OPT->{PASS}});
    # pinを取得
    my $res = $mech->post("http://reader.livedoor.com/api/pin/all");
    return $mech->content;
}
# 2. JSONをはてな記法に変換する。
sub JSON2Hatena {
    my $obj = JSON::from_json(shift,{utf8=>1});
    my $Result;
#   my $Count = 1;$| = 1;
    foreach my $pin (@{$obj}){
        my ($reallink,$title);
        if($OPT->{REALLINK} == 1){ # redirect先を取得
            ($title,$reallink) = GetRealData($pin->{link});
            $reallink = $pin->{link} unless $reallink;
            $title = encode("sjis",$pin->{title}) unless($title);
        } else {
            $reallink = $pin->{link};
            $title = encode("sjis",$pin->{title});
        }
#       print STDERR ">>$Count: $title\n$reallink\n"; $Count++;
        push(@$Result,sprintf("- [%s:title=%s]\n",$reallink,$title));
    }
    return $Result;
}
sub GetRealData {
    my $url = shift;
    my ($realurl,$title);
    # redirect先をget
    my $ua = LWP::UserAgent->new(timeout => 5 ,agent => $OPT->{UA});
    my $res = $ua->get($url);
    if ($res->is_success){ $realurl = $ua->head($url)->base }
    else                 { $realurl = undef }
    # <title>TITLE</title>を抽出
    my $p = HTML::TokeParser->new(\$res->content)|| die "Parse error\n";
    $p->get_tag("title");
    my $titledata = $p->get_trimmed_text("/title");
    eval {$title = decode("Guess", $titledata);}; # 文字コード推測失敗
    if($@){ return (undef,$realurl) }
    else  { return (encode("sjis",$title),$realurl) }
}