はてな自動投げ銭スクリプトをはてなブログbetaに対応させた

Tweet

昨日書いた、

HTML::AccountAutoDiscoveryがはてなブログbetaに対応していない件

で、HTML::AccountAutoDiscoveryを使わなければよくね？ 的なアプローチではてなブックマークWebHook用投げ銭スクリプトがこちらとなります。

Filename: throw.cgi

#!/usr/bin/perl
 
# throw.cgi ブックマークしたら投げ銭します。
# 説明：http://blog.dtpwiki.jp/dtp/2009/06/web-hook-645b.html
# 2009-06-07 ver 0.0.1 ファーストポスト
# 2009-10-03 ver 0.0.2 最新のMechでも動くように
# 2012-01-26 ver 0.0.3 はてなブログ対応
 
 
use strict;
use warnings;
use CGI;
use Config::Pit;
use Encode;
use HTML::AccountAutoDiscovery;
use utf8;
use WWW::Mechanize;
 
# 初期設定
my $url_sendpoint = 'https://www.hatena.ne.jp/sendpoint';
my $send_point = 10; # 送信するポイント（はてな手数料別）
my $login;
my $config = pit_get('hatena.ne.jp');
die "not preset account data in Pit." if !%$config;
my $my_id    = $config->{id      } or die 'id not found.';
my $password = $config->{password} or die 'password not found.';
my $auth_key = $config->{auth_key} or die 'auth_key not found.';
 
my $q = CGI->new;
my $mech = WWW::Mechanize->new;
$mech->agent_alias('Windows IE 6');
 
{ # メインルーチン
  # 認証
  if ( $q->param('key') ne $auth_key ) {
      die "Authentication failed";
  }
  # メソッド確認
  if ( $q->param('status') eq 'add' ) {
    # エントリーの情報
    my $req = $q->Vars();
    nagesen( $req );
  }
  # はてなブックマークWeb Hook用リザルト
  print $q->header('text/plain');
  print 'ok';
}
exit;
 
sub nagesen {
  my $req = shift;
  my $url = $req->{url};
  my @account = HTML::AccountAutoDiscovery->find( $url );
  unless( @account ) { @account = find_hatenablog( $url ); }
   
  sub find_hatenablog {
    my $url = shift;
    use LWP::Simple;
    my @r;
    my $c = get( $url );
    $c =~ s/.+(<html.+?>).+/$1/so;
    if ( $c =~ m{data-admin-domain="http://blog.hatena.ne.jp"} ) {
      if ( $c =~ m{data-author="(.+)"} ) {
        push @r,{account => $1, service => 'http://blog.hatena.ne.jp' };
      }
    }
    return  @r;
  }
  
  foreach my $item ( @account ) {
    my $send_id = $item->{account}; # account name
    send_hatenapoint( $req, $send_id );
    last; # HTMLに複数のIDを埋め込んでいた場合最初の人の分
          # だけ対応（同じ人がID埋め込みまくるとポイント
          # 送信しまくるのを防ぐ）
  }
  return;
}
 
sub login_hatenapoint {
# はてなにログインします
  $mech->get( $url_sendpoint );
  # ログインを促す画面に遷移済
  $mech->follow_link( text => mech_encode('ログイン') );
  # ログイン画面に遷移済
  $mech->set_visible( $my_id, $password );
  $mech->submit();
  # ログイン済み画面に遷移済
  $mech->follow_link( text => mech_encode('こちら') );
  # 投げ銭画面に遷移済
  $login = 1;
  return;
}
 
sub send_hatenapoint {
# はてなポイント送信をします
  my $req     = shift;
  my $send_id = shift;
  unless ( $login ) {
    login_hatenapoint();
  }
  # ログイン済みの状態
  $mech->get( $url_sendpoint );
  # はてなポイント送信のページに遷移済
  # ポイント送信メッセージ組み立て
  my $send_message = decode('utf8', $req->{title})
    ."($req->{url}) をブックマークしました。投げ銭いたします。"
    .'投げ銭スクリプト：http://svn.coderepos.org/share/lang/'
    .'perl/misc/hatenabookmark_webhook_nagesen/';
  # ポイント送信用パラメータ入力
  $mech->set_visible(
    $password, $send_id, $send_point,
    undef, # 匿名にしたい場合は1
    mech_encode( $send_message )
  );
  $mech->submit();
  # confirm画面に遷移済
  return unless $mech->title() eq mech_encode(
    'はてな ポイント付きメッセージ送信確認'); # 送信確認ページ?
  $mech->click_button( value => mech_encode('送信する') );
  #open my $fh, '>', 'log.html';
  #print $fh $mech->content();
  #close $fh;
  return;
}
 
sub mech_encode {
# WWW::Mechanize 1.21_01以降の挙動に対応
  my $str = shift;
  if ( ( $WWW::Mechanize::VERSION ) < 1.21 ) {
    $str = encode( 'utf8', $str );
  }
  return $str;
}
 
__END__

2009年10月に一度改定していて、WWW::Mechanizeのバージョンによる差異を吸収していたんだけれども、

M.C.P.C.: はてな自動投げ銭スクリプトを最新WWW::Mechanizeに対応させたが、Mechの動作が変わる境目のバージョンがわからない

その分はCodeReposにコミットするの忘れていたので今回はちゃんとコミットしたよ。

http://svn.coderepos.org/share/lang/perl/misc/hatenabookmark_webhook_nagesen/

2012.01.26 23:28 投稿　大野 義貴 [Perl] | 固定リンク |