root/lang/perl/misc/hatenabookmark_webhook_nagesen/trunk/throw.cgi @ 39106

Revision 39106, 3.9 kB (checked in by CL, 2 years ago)

Mechのバージョン差異吸収はてなブログ対応

  • Property svn:executable set to *
Line 
1#!/usr/bin/perl
2 
3# throw.cgi ブックマークしたら投げ銭します。
4# 説明:http://blog.dtpwiki.jp/dtp/2009/06/web-hook-645b.html
5# 2009-06-07 ver 0.0.1 ファーストポスト
6# 2009-10-03 ver 0.0.2 最新のMechでも動くように
7# 2012-01-26 ver 0.0.3 はてなブログ対応
8
9 
10use strict;
11use warnings;
12use CGI;
13use Config::Pit;
14use Encode;
15use HTML::AccountAutoDiscovery;
16use utf8;
17use WWW::Mechanize;
18 
19# 初期設定
20my $url_sendpoint = 'https://www.hatena.ne.jp/sendpoint';
21my $send_point = 10; # 送信するポイント(はてな手数料別)
22my $login;
23my $config = pit_get('hatena.ne.jp');
24die "not preset account data in Pit." if !%$config;
25my $my_id    = $config->{id      } or die 'id not found.';
26my $password = $config->{password} or die 'password not found.';
27my $auth_key = $config->{auth_key} or die 'auth_key not found.';
28 
29my $q = CGI->new;
30my $mech = WWW::Mechanize->new;
31$mech->agent_alias('Windows IE 6');
32 
33{ # メインルーチン
34  # 認証
35  if ( $q->param('key') ne $auth_key ) {
36      die "Authentication failed";
37  }
38  # メソッド確認
39  if ( $q->param('status') eq 'add' ) {
40    # エントリーの情報
41    my $req = $q->Vars();
42    nagesen( $req );
43  }
44  # はてなブックマークWeb Hook用リザルト
45  print $q->header('text/plain');
46  print 'ok';
47}
48exit;
49 
50sub nagesen {
51  my $req = shift;
52  my $url = $req->{url};
53  my @account = HTML::AccountAutoDiscovery->find( $url );
54  unless( @account ) { @account = find_hatenablog( $url ); }
55   
56  sub find_hatenablog {
57    my $url = shift;
58    use LWP::Simple;
59    my @r;
60    my $c = get( $url );
61    $c =~ s/.+(<html.+?>).+/$1/so;
62    if ( $c =~ m{data-admin-domain="http://blog.hatena.ne.jp"} ) {
63      if ( $c =~ m{data-author="(.+)"} ) {
64        push @r,{account => $1, service => 'http://blog.hatena.ne.jp' };
65      }
66    }
67    return  @r;
68  }
69 
70  foreach my $item ( @account ) {
71    my $send_id = $item->{account}; # account name
72    send_hatenapoint( $req, $send_id );
73    last; # HTMLに複数のIDを埋め込んでいた場合最初の人の分
74          # だけ対応(同じ人がID埋め込みまくるとポイント
75          # 送信しまくるのを防ぐ)
76  }
77  return;
78}
79 
80sub login_hatenapoint {
81# はてなにログインします
82  $mech->get( $url_sendpoint );
83  # ログインを促す画面に遷移済
84  $mech->follow_link( text => mech_encode('ログイン') );
85  # ログイン画面に遷移済
86  $mech->set_visible( $my_id, $password );
87  $mech->submit();
88  # ログイン済み画面に遷移済
89  $mech->follow_link( text => mech_encode('こちら') );
90  # 投げ銭画面に遷移済
91  $login = 1;
92  return;
93}
94 
95sub send_hatenapoint {
96# はてなポイント送信をします
97  my $req     = shift;
98  my $send_id = shift;
99  unless ( $login ) {
100    login_hatenapoint();
101  }
102  # ログイン済みの状態
103  $mech->get( $url_sendpoint );
104  # はてなポイント送信のページに遷移済
105  # ポイント送信メッセージ組み立て
106  my $send_message = decode('utf8', $req->{title})
107    ."($req->{url}) をブックマークしました。投げ銭いたします。"
108    .'投げ銭スクリプト:http://svn.coderepos.org/share/lang/'
109    .'perl/misc/hatenabookmark_webhook_nagesen/';
110  # ポイント送信用パラメータ入力
111  $mech->set_visible(
112    $password, $send_id, $send_point,
113    undef, # 匿名にしたい場合は1
114    mech_encode( $send_message )
115  );
116  $mech->submit();
117  # confirm画面に遷移済
118  return unless $mech->title() eq mech_encode(
119    'はてな ポイント付きメッセージ送信確認'); # 送信確認ページ?
120  $mech->click_button( value => mech_encode('送信する') );
121  #open my $fh, '>', 'log.html';
122  #print $fh $mech->content();
123  #close $fh;
124  return;
125}
126 
127sub mech_encode {
128# WWW::Mechanize 1.21_01以降の挙動に対応
129  my $str = shift;
130  if ( ( $WWW::Mechanize::VERSION ) < 1.21 ) {
131    $str = encode( 'utf8', $str );
132  }
133  return $str;
134}
135 
136__END__
Note: See TracBrowser for help on using the browser.