File Coverage

blib/lib/WWW/Mixi.pm
Criterion Covered Total %
statement 32 2685 1.1
branch 5 1674 0.3
condition 0 722 0.0
subroutine 8 238 3.3
pod 5 210 2.3
total 50 5529 0.9


line stmt bran cond sub pod time code
1             package WWW::Mixi;
2            
3 1     1   31048 use strict;
  1         2  
  1         62  
4 1     1   6 use Carp ();
  1         2  
  1         24  
5 1     1   7 use vars qw($VERSION @ISA);
  1         8  
  1         154  
6            
7             $VERSION = sprintf("%d.%02d", q$Revision: 0.50$ =~ /(\d+)\.(\d+)/);
8            
9             require LWP::RobotUA;
10             @ISA = qw(LWP::RobotUA);
11             require HTTP::Request;
12             require HTTP::Response;
13            
14             # use Jcode;
15 1     1   866 use LWP::Debug ();
  1         459  
  1         15  
16 1     1   1865 use HTTP::Cookies;
  1         19816  
  1         36  
17 1     1   2681 use HTTP::Request::Common;
  1         73885  
  1         46284  
18            
19             sub new {
20 1     1 1 16 my ($class, $email, $password, %opt) = @_;
21 1         3 my $base = 'http://mixi.jp/';
22            
23             # オプションの処理
24 1 50       4 Carp::croak('WWW::Mixi mail address required') unless $email;
25             # Carp::croak('WWW::Mixi password required') unless $password;
26            
27             # オブジェクトの生成
28 1         3 my $name = "WWW::Mixi/" . $VERSION;
29 1         18 my $rules = WWW::Mixi::RobotRules->new($name);
30 1         46 my $self = LWP::RobotUA->new($name, $email, $rules);
31 1         5078 $self = bless $self, $class;
32 1         9 $self->from($email);
33 1         64 $self->delay(1/60);
34            
35             # 独自変数の設定
36 1 50       55 $self->{'mixi'} = {
    50          
    50          
    50          
37             'base' => $base,
38             'email' => $email,
39             'password' => $password,
40             'response' => undef,
41             'logcode' => exists($opt{'-logcode'}) ? $opt{'-logcode'} : undef,
42             'log' => exists($opt{'-log'}) ? $opt{'-log'} : \&callback_log,
43             'abort' => exists($opt{'-abort'}) ? $opt{'-abort'} : \&callback_abort,
44             'rewrite' => exists($opt{'-rewrite'}) ? $opt{'-rewrite'} : \&callback_rewrite,
45             };
46            
47 1         6 return $self;
48             }
49            
50             sub login {
51 0     0 0   my $self = shift;
52 0           my $page = 'login.pl';
53 0 0         my $next = ($self->{'mixi'}->{'next_url'}) ? $self->{'mixi'}->{'next_url'} : '/home.pl';
54 0 0         my $password = (@_) ? shift : $self->{'mixi'}->{'password'};
55 0 0 0       return undef unless (defined($password) and length($password));
56 0           my %form = (
57             'email' => $self->{'mixi'}->{'email'},
58             'password' => $password,
59             'next_url' => $self->absolute_url($next),
60             );
61 0           $self->enable_cookies;
62             # ログイン
63 0 0         $self->log("[info] 再ログインします。\n") if ($self->session);
64 0           my $res = $self->post($page, %form);
65 0 0 0       $self->{'mixi'}->{'refresh'} = ($res->is_success and $res->headers->header('refresh') =~ /url=([^ ;]+)/) ? $self->absolute_url($1) : undef;
66 0 0         $self->{'mixi'}->{'password'} = $password if ($res->is_success);
67 0           return $res;
68             }
69            
70             sub is_logined {
71 0     0 0   my $self = shift;
72 0 0 0       return ($self->session and $self->stamp) ? 1 : 0;
73             }
74            
75             sub is_login_required {
76 0     0 0   my $self = shift;
77 0 0         my $res = (@_) ? shift : $self->{'mixi'}->{'response'};
78 0 0         if (not $res) { return "ページを取得できていません。"; }
  0 0          
79 0           elsif (not $res->is_success) { return sprintf('ページ取得に失敗しました。（%s）', $res->message); }
80             else {
81 0           my $re_attr = '(?:"[^"]+"|\'[^\']+\'|[^\s<>]+)\s+';
82 0           my $content = $res->content;
83 0 0         return 0 if ($content !~ /
]+)/);
84 0 0         return 0 if ($self->absolute_url($1) ne $self->absolute_url('login.pl'));
85 0 0         $self->{'mixi'}->{'next_url'} = ($content =~ //) ? $1 : '/home.pl';
86 0 0         return "Login Failed ($1)" if ($content =~ /(.*?)<\/font><\/b>/);
87 0           return 'Login Required';
88             }
89 0           return 0;
90             }
91            
92             sub session {
93 0     0 0   my $self = shift;
94 0 0         if (@_) {
95 0           my $session = shift;
96 0           $self->enable_cookies;
97 0           $self->cookie_jar->set_cookie(undef, 'BF_SESSION', $session, '/', 'mixi.jp', undef, 1, undef, undef, 1);
98             }
99 0 0         return undef unless ($self->cookie_jar);
100 0 0         return ($self->cookie_jar->as_string =~ /\bSet-Cookie.*?:.*? BF_SESSION=(.*?);/) ? $1 : undef;
101             }
102            
103             sub stamp {
104 0     0 0   my $self = shift;
105 0 0         if (@_) {
106 0           my $stamp = shift;
107 0           $self->enable_cookies;
108 0           $self->cookie_jar->set_cookie(undef, 'BF_STAMP', $stamp, '/', 'mixi.jp', undef, 1, undef, undef, 1);
109             }
110 0 0         return undef unless ($self->cookie_jar);
111 0 0         return ($self->cookie_jar->as_string =~ /\bSet-Cookie.*?:.*? BF_STAMP=(.*?);/) ? $1 : undef;
112             }
113            
114 0     0 0   sub refresh { return $_[0]->{'mixi'}->{'refresh'}; }
115            
116             sub request {
117 0     0 1   my $self = shift;
118 0           my @args = @_;
119 0           my $res = $self->SUPER::request(@args);
120            
121 0 0         if ($res->is_success) {
122             # check contents existence
123 0 0 0       if ($res->content and $res->content =~ /^\Qデータはありません。\E/) {
    0 0        
    0 0        
    0          
124 0           $res->code(400);
125 0           $res->message('No Data');
126             # check rejcted by too frequent requests.
127             } elsif ($res->content and $res->content =~ /^\Q間隔を空けない連続的なページの遷移・更新を頻繁におこなわれている\E/) {
128 0           $res->code(503);
129 0           $res->message('Too frequently requests');
130             # check rejcted since content is closed.
131             } elsif ($res->content and $res->content =~ /^\Qアクセスできません\E/) {
132 0           $res->code(403);
133 0           $res->message('Closed content');
134             # check login form existence
135             } elsif (my $message = $self->is_login_required($res)) {
136 0           $res->code(401);
137 0           $res->message($message);
138             }
139             }
140            
141             # store and return response
142 0           $self->{'mixi'}->{'response'} = $res;
143 0           return $res;
144             }
145            
146             sub get {
147 0     0 1   my $self = shift;
148 0           my $url = shift;
149 0           $url = $self->absolute_url($url);
150 0           $self->log("[info] GETメソッドで\"${url}\"を取得します。\n");
151             # 取得
152 0           my $res = $self->request(HTTP::Request->new('GET', $url));
153 0           $self->log("[info] リクエストが処理されました。\n");
154 0           return $res;
155             }
156            
157             sub post {
158 0     0 1   my $self = shift;
159 0           my $url = shift;
160 0           $url = $self->absolute_url($url);
161 0           $self->log("[info] POSTメソッドで\"${url}\"を取得します。\n");
162             # リクエストの生成
163 0           my @form = @_;
164 0 0         my $req = (grep {ref($_) eq 'ARRAY'} @form) ?
  0            
165             &HTTP::Request::Common::POST($url, Content_Type => 'form-data', Content => [@form]) :
166             &HTTP::Request::Common::POST($url, [@form]);
167 0           $self->log("[info] リクエストが生成されました。\n");
168             # 取得
169 0           my $res = $self->request($req);
170 0           $self->log("[info] リクエストが処理されました。\n");
171 0           return $res;
172             }
173            
174             sub response {
175 0     0 0   my $self = shift;
176 0           return $self->{'mixi'}->{'response'};
177             }
178            
179             sub parse_main_menu {
180 0     0 0   my $self = shift;
181 0 0         my $res = (@_) ? shift : $self->response();
182 0 0 0       return unless ($res and $res->is_success);
183 0           my $base = $res->base->as_string;
184 0           my $content = $res->content;
185 0           my @items = ();
186             # parse main menu items
187 0           my @tags = ($content =~ /
  • (.*?)<\/li>/gs);
    • 188 0 0         return $self->log("[warn] li tag is missing in main menu part.\n") unless (@tags);
    189             # parse each items
    190 0           foreach my $str (@tags) {
    191 0 0         my $anchor = ($str =~ /()/) ? $1 : next;
    192 0 0         my $image = ($str =~ /()/) ? $1 : next;
    193 0           ($anchor, $image) = map { $self->parse_standard_tag($_) } ($anchor, $image);
      0            
    194 0           my $item = {
    195             'link' => $self->absolute_url($anchor->{'attr'}->{'href'}, $base),
    196             'subject' => $self->rewrite($image->{'attr'}->{'alt'})
    197             };
    198 0           push(@items, $item);
    199             }
    200 0           return @items;
    201             }
    202            
    203             sub parse_banner {
    204 0     0 0   my $self = shift;
    205 0 0         my $res = (@_) ? shift : $self->response();
    206 0 0 0       return unless ($res and $res->is_success);
    207 0           my $base = $res->base->as_string;
    208 0           my $content = $res->content;
    209 0           my @items = ();
    210 0           my @tags = ($content =~ /(