WWW::Mixi - Perl extension for scraping the MIXI social networking service.
Index
Code Index:
NAME
WWW::Mixi - Perl extension for scraping the MIXI social networking service.
SYNOPSIS
require WWW::Mixi;
$mixi = WWW::Mixi->new('me@foo.com', 'password');
$mixi->login;
my $res = $mixi->get('home.pl');
print $res->content;
DESCRIPTION
WWW::Mixi uses LWP::RobotUA to scrape mixi.jp.
This provide login method, get and put method, and some parsing method for user who create mixi spider.
I think using WWW::Mixi is better than using LWP::UserAgent or LWP::Simple for accessing Mixi.
WWW::Mixi automatically enables cookie, take delay 1 second for each access, take care robot exclusions.
See "mixi.pod" for more detail.
SEE ALSO
AUTHORS
WWW::Mixi is written by TSUKAMOTO Makio <tsukamoto@gmail.com>
Some bug fixes submitted by Topia (http://clovery.jp/), shino (http://www.freedomcat.com/), makamaka (http://www.donzoko.net/), ash.
get_ and post_add_diary, get_ and post_delete_diary, parse_list_diary and parse_new_diary contributed by DonaDona (http://hsj.jp/).
get_ and parse_view_diary contributed by shino (http://www.freedomcat.com/).
get_ and parse_list_outbox contributed by AsO (http://www.bx.sakura.ne.jp/~clan/rn/cgi-bin/index.cgi).
get_ and post_send_message contributed by noname (http://untitled.rootkit.jp/diary/).
COPYRIGHT
Copyright 2004-2006 Makio Tsukamoto.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
package WWW::Mixi;
use strict;
use Carp ();
use vars qw($VERSION @ISA);
$VERSION = sprintf("%d.%02d", q$Revision: 0.50$ =~ /(\d+)\.(\d+)/);
require LWP::RobotUA;
@ISA = qw(LWP::RobotUA);
require HTTP::Request;
require HTTP::Response;
# use Jcode;
use LWP::Debug ();
use HTTP::Cookies;
use HTTP::Request::Common;
sub new {
my ($class, $email, $password, %opt) = @_;
my $base = 'http://mixi.jp/';
# ¥ª¥×¥·¥ç¥ó¤Î½èÍý
Carp::croak('WWW::Mixi mail address required') unless $email;
# Carp::croak('WWW::Mixi password required') unless $password;
# ¥ª¥Ö¥¸¥§¥¯¥È¤ÎÀ¸À®
my $name = "WWW::Mixi/" . $VERSION;
my $rules = WWW::Mixi::RobotRules->new($name);
my $self = LWP::RobotUA->new($name, $email, $rules);
$self = bless $self, $class;
$self->from($email);
$self->delay(1/60);
# Æȼ«ÊÑ¿ô¤ÎÀßÄê
$self->{'mixi'} = {
'base' => $base,
'email' => $email,
'password' => $password,
'response' => undef,
'logcode' => exists($opt{'-logcode'}) ? $opt{'-logcode'} : undef,
'log' => exists($opt{'-log'}) ? $opt{'-log'} : \&callback_log,
'abort' => exists($opt{'-abort'}) ? $opt{'-abort'} : \&callback_abort,
'rewrite' => exists($opt{'-rewrite'}) ? $opt{'-rewrite'} : \&callback_rewrite,
};
return $self;
}
sub login {
my $self = shift;
my $page = 'login.pl';
my $next = ($self->{'mixi'}->{'next_url'}) ? $self->{'mixi'}->{'next_url'} : '/home.pl';
my $password = (@_) ? shift : $self->{'mixi'}->{'password'};
return undef unless (defined($password) and length($password));
my %form = (
'email' => $self->{'mixi'}->{'email'},
'password' => $password,
'next_url' => $self->absolute_url($next),
);
$self->enable_cookies;
# ¥í¥°¥¤¥ó
$self->log("[info] ºÆ¥í¥°¥¤¥ó¤·¤Þ¤¹¡£\n") if ($self->session);
my $res = $self->post($page, %form);
$self->{'mixi'}->{'refresh'} = ($res->is_success and $res->headers->header('refresh') =~ /url=([^ ;]+)/) ? $self->absolute_url($1) : undef;
$self->{'mixi'}->{'password'} = $password if ($res->is_success);
return $res;
}
sub is_logined {
my $self = shift;
return ($self->session and $self->stamp) ? 1 : 0;
}
sub is_login_required {
my $self = shift;
my $res = (@_) ? shift : $self->{'mixi'}->{'response'};
if (not $res) { return "¥Ú¡¼¥¸¤ò¼èÆÀ¤Ç¤¤Æ¤¤¤Þ¤»¤ó¡£"; }
elsif (not $res->is_success) { return sprintf('¥Ú¡¼¥¸¼èÆÀ¤Ë¼ºÇÔ¤·¤Þ¤·¤¿¡£¡Ê%s¡Ë', $res->message); }
else {
my $re_attr = '(?:"[^"]+"|\'[^\']+\'|[^\s<>]+)\s+';
my $content = $res->content;
return 0 if ($content !~ /<form (?:$re_attr)*action=("[^""]+"|'[^'']+'|[^\s<>]+)/);
return 0 if ($self->absolute_url($1) ne $self->absolute_url('login.pl'));
$self->{'mixi'}->{'next_url'} = ($content =~ /<input type=hidden name=next_url value="(.*?)">/) ? $1 : '/home.pl';
return "Login Failed ($1)" if ($content =~ /<b><font color=#DD0000>(.*?)<\/font><\/b>/);
return 'Login Required';
}
return 0;
}
sub session {
my $self = shift;
if (@_) {
my $session = shift;
$self->enable_cookies;
$self->cookie_jar->set_cookie(undef, 'BF_SESSION', $session, '/', 'mixi.jp', undef, 1, undef, undef, 1);
}
return undef unless ($self->cookie_jar);
return ($self->cookie_jar->as_string =~ /\bSet-Cookie.*?:.*? BF_SESSION=(.*?);/) ? $1 : undef;
}
sub stamp {
my $self = shift;
if (@_) {
my $stamp = shift;
$self->enable_cookies;
$self->cookie_jar->set_cookie(undef, 'BF_STAMP', $stamp, '/', 'mixi.jp', undef, 1, undef, undef, 1);
}
return undef unless ($self->cookie_jar);
return ($self->cookie_jar->as_string =~ /\bSet-Cookie.*?:.*? BF_STAMP=(.*?);/) ? $1 : undef;
}
sub refresh { return $_[0]->{'mixi'}->{'refresh'}; }
sub request {
my $self = shift;
my @args = @_;
my $res = $self->SUPER::request(@args);
if ($res->is_success) {
# check contents existence
if ($res->content and $res->content =~ /^\Q¥Ç¡¼¥¿¤Ï¤¢¤ê¤Þ¤»¤ó¡£\E<html>/) {
$res->code(400);
$res->message('No Data');
# check rejcted by too frequent requests.
} elsif ($res->content and $res->content =~ /^\Q´Ö³Ö¤ò¶õ¤±¤Ê¤¤Ï¢Â³Åª¤Ê¥Ú¡¼¥¸¤ÎÁ«°Ü¡¦¹¹¿·¤òÉÑÈˤˤª¤³¤Ê¤ï¤ì¤Æ¤¤¤ë\E/) {
$res->code(503);
$res->message('Too frequently requests');
# check rejcted since content is closed.
} elsif ($res->content and $res->content =~ /^\Q¥¢¥¯¥»¥¹¤Ç¤¤Þ¤»¤ó\E<html>/) {
$res->code(403);
$res->message('Closed content');
# check login form existence
} elsif (my $message = $self->is_login_required($res)) {
$res->code(401);
$res->message($message);
}
}
# store and return response
$self->{'mixi'}->{'response'} = $res;
return $res;
}
sub get {
my $self = shift;
my $url = shift;
$url = $self->absolute_url($url);
$self->log("[info] GET¥á¥½¥Ã¥É¤Ç\"${url}\"¤ò¼èÆÀ¤·¤Þ¤¹¡£\n");
# ¼èÆÀ
my $res = $self->request(HTTP::Request->new('GET', $url));
$self->log("[info] ¥ê¥¯¥¨¥¹¥È¤¬½èÍý¤µ¤ì¤Þ¤·¤¿¡£\n");
return $res;
}
sub post {
my $self = shift;
my $url = shift;
$url = $self->absolute_url($url);
$self->log("[info] POST¥á¥½¥Ã¥É¤Ç\"${url}\"¤ò¼èÆÀ¤·¤Þ¤¹¡£\n");
# ¥ê¥¯¥¨¥¹¥È¤ÎÀ¸À®
my @form = @_;
my $req = (grep {ref($_) eq 'ARRAY'} @form) ?
&HTTP::Request::Common::POST($url, Content_Type => 'form-data', Content => [@form]) :
&HTTP::Request::Common::POST($url, [@form]);
$self->log("[info] ¥ê¥¯¥¨¥¹¥È¤¬À¸À®¤µ¤ì¤Þ¤·¤¿¡£\n");
# ¼èÆÀ
my $res = $self->request($req);
$self->log("[info] ¥ê¥¯¥¨¥¹¥È¤¬½èÍý¤µ¤ì¤Þ¤·¤¿¡£\n");
return $res;
}
sub response {
my $self = shift;
return $self->{'mixi'}->{'response'};
}
sub parse_main_menu {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# parse main menu items
my @tags = ($content =~ /<li class="gnavibt\d+">(.*?)<\/li>/gs);
return $self->log("[warn] li tag is missing in main menu part.\n") unless (@tags);
# parse each items
foreach my $str (@tags) {
my $anchor = ($str =~ /(<a .*?>)/) ? $1 : next;
my $image = ($str =~ /(<img .*?>)/) ? $1 : next;
($anchor, $image) = map { $self->parse_standard_tag($_) } ($anchor, $image);
my $item = {
'link' => $self->absolute_url($anchor->{'attr'}->{'href'}, $base),
'subject' => $self->rewrite($image->{'attr'}->{'alt'})
};
push(@items, $item);
}
return @items;
}
sub parse_banner {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my @tags = ($content =~ /(<iframe [^<>]*>)/gs);
return $self->log("[warn] content has no iframe tags.\n") unless (@tags);
foreach my $str (@tags) {
my $tag = $self->parse_standard_tag($str);
next unless ($tag->{'attr'}->{'src'} and $tag->{'attr'}->{'src'} =~ /^http:\/\/ads.mixi.jp/);
my $item = { 'link' => $tag->{'attr'}->{'src'} };
push(@items, $item);
last;
}
return @items;
}
sub parse_tool_bar {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get tool bar part
my $content_from = qq(<ul [^<>]*id="snavi"[^<>]*>);
my $content_till = qq(\Q</ul>\E);
return $self->log("[warn] tool bar part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse tool bar items
my @tags = ($content =~ /<li.*?>(.*?)<\/li>/gs);
return $self->log("[warn] li tag is missing in tool bar part.\n") unless (@tags);
# parse tool bar part
foreach my $str (@tags) {
my $anchor = ($str =~ /(<a .*?>)/) ? $1 : next;
my $image = ($str =~ /(<img .*?>)/) ? $1 : next;
($anchor, $image) = map { $self->parse_standard_tag($_) } ($anchor, $image);
my $item = {
'link' => $self->absolute_url($anchor->{'attr'}->{'href'}, $base),
'subject' => $self->rewrite($image->{'attr'}->{'alt'})
};
push(@items, $item);
}
return @items;
}
sub parse_information {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get information part
my $content_from = qq(\Q<!-- ¤ªÃΤ餻¥á¥Ã¥»¡¼¥¸ ¤³¤³¤«¤é -->\E);
my $content_till = qq(\Q<!-- ¤ªÃΤ餻¥á¥Ã¥»¡¼¥¸ ¤³¤³¤Þ¤Ç -->\E);
return $self->log("[warn] information is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse information part
$content =~ s/[\r\n]+//g;
$content =~ s/<!--.*?-->//g;
while ($content =~ s/<tr><td>(.*?)<\/td><td>(.*?)<\/td><td>(.*?)<\/td><\/tr>//i) {
my ($subject, $linker) = ($1, $3);
my $re_attr_val = '(?:"[^"]+"|\'[^\']+\'|[^\s<>]+)\s*';
my $style = {};
$subject =~ s/^.*?¡¦<\/font>(?: | )//;
while ($subject =~ s/^\s*<([^<>]*)>\s*//) {
my $tag = lc($1);
my ($tag_part, $attr_part) = split(/\s+/, $tag, 2);
$style->{'font-weight'} = 'bold' if ($tag_part eq 'b');
while ($attr_part =~ s/([^\s<>=]+)(?:=($re_attr_val))?//) {
my ($attr, $val) = ($1, $2);
$val =~ s/^"(.*)"$/$1/ or $val =~ s/^'(.*)'$/$1/;
$val = $self->unescape($val);
if ($attr eq 'style') { $style->{$1} = $2 while ($val =~ s/([^\s:]+)\s*:\s*([^\s:;]+)//); }
elsif ($attr eq 'color') { $style->{'color'} = $val; }
}
}
$subject =~ s/\s*<.*?>\s*//g;
my ($link, $description) = ($1, $2) if ($linker =~ /<a href=(.*?) .*?>(.*?)<\/a>/i);
my $item = {
'subject' => $self->rewrite($subject),
'style' => $style,
'link' => $self->absolute_url($link, $base),
'description' => $self->rewrite($description)
};
push(@items, $item);
}
return @items;
}
sub parse_home_new_album {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get new album part
my $content_from = qq(\Q¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·¥¢¥ë¥Ð¥à\E);
my $content_till = qq(\Q<table border="0" cellspacing="0" cellpadding="0" width="300">\E);
return $self->log("[warn] new album part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse new album part
while ($content =~ s/<img src=.*?>(\d{2})·î(\d{2})Æü.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br clear="all" \/>//is) {
my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5);
$subj = $self->rewrite($subj);
$name = $self->rewrite($name);
$link = $self->absolute_url($link, $base);
push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name});
}
return @items;
}
sub parse_home_new_bbs {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get new bbs part
my $content_from = qq(\Q¥³¥ß¥å¥Ë¥Æ¥£ºÇ¿·½ñ¤¹þ¤ß\E);
my $content_till = qq(\Q<table border="0" cellspacing="0" cellpadding="0" width="300">\E);
return $self->log("[warn] new bbs part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse new bbs part
while ($content =~ s/<img src=.*?>(\d{2})·î(\d{2})Æü.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br clear="all" \/>//is) {
my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5);
$subj = $self->rewrite($subj);
$name = $self->rewrite($name);
$link = $self->absolute_url($link, $base);
push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name});
}
return @items;
}
sub parse_home_new_comment {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get new comment part
my $content_from = qq(\QÆüµ¥³¥á¥ó¥ÈµÆþÍúÎò\E);
my $content_till = qq(\Q<table border="0" cellspacing="0" cellpadding="0" width="300">\E);
return $self->log("[warn] new comment part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse new comment part
while ($content =~ s/<img src=.*?>(\d{2})·î(\d{2})Æü.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br clear="all" \/>//is) {
my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5);
$subj = $self->rewrite($subj);
$name = $self->rewrite($name);
$link = $self->absolute_url($link, $base);
push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name});
}
return @items;
}
sub parse_home_new_friend_diary {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get new friend diary part
my $content_from = qq(\Q¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·Æüµ</font>\E.*?\Q</td>\E);
my $content_till = qq(\Q<table border="0" cellspacing="0" cellpadding="0" width="300">\E);
return $self->log("[warn] new friend diary part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse new friend diary part
while ($content =~ s/<img src=.*?>(\d{2})·î(\d{2})Æü.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br clear="all" \/>//is) {
my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5);
$subj = $self->rewrite($subj);
$name = $self->rewrite($name);
$link = $self->absolute_url($link, $base);
push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name});
}
return @items;
}
sub parse_home_new_review {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get new friend diary part
my $content_from = qq(\Q¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·¥ì¥Ó¥å¡¼\E);
my $content_till = qq(\Q<table border="0" cellspacing="0" cellpadding="0" width="300">\E);
return $self->log("[warn] new review part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse new friend diary part
while ($content =~ s/<img src=.*?>(\d{2})·î(\d{2})Æü.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br clear="all" \/>//is) {
my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5);
$subj = $self->rewrite($subj);
$name = $self->rewrite($name);
$link = $self->absolute_url($link, $base);
push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name});
}
return @items;
}
sub parse_ajax_new_diary {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my $re_date = q{(\d{1,2})·î(\d{1,2})Æü};
my $re_link = q{(<a (?:"[^"]*"|'[\']*'|[^>]+)*>)(.*?)<\/a>};
my $re_name = q{\((.*?)\)};
my @today = reverse((localtime)[3..5]);
$today[0] += 1900;
$today[1] += 1;
foreach my $row ($content =~ /<div align=left>(.*?)<\/div>/isg) {
next unless ($row =~ /$re_date ¡Ä $re_link/);
my $item = {};
my @date = (undef, $1, $2);
$item->{'link'} = $self->absolute_url($self->parse_standard_anchor($3), $base);
$item->{'subject'} = (defined($4) and length($4)) ? $self->rewrite($4) : '(ºï½ü)';
$date[0] = ($date[1] > $today[1]) ? $today[0] - 1 : $today[0] if (not defined($date[0]));
$item->{'time'} = sprintf('%04d/%02d/%02d', @date);
map { $item->{$_} =~ s/^\s+|\s+$//gs } (keys(%{$item}));
push(@items, $item);
}
return @items;
}
sub parse_community_id {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my $item;
if ($content =~ /view_community.pl\?id=(\d+)/) {
$item = $1;
}
return $item;
}
sub parse_edit_member {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get member list part
my $content_from = qq(\Q<table border="0" cellspacing="1" cellpadding="4" width="630">\E);
my $content_till = qq(\Q</table>\E);
return $self->log("[warn] member list part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# get member list
$content =~ s/[\t\r\n]//g;
my @rows = ($content =~ /<tr>(.*?)<\/tr>/ig);
return $self->log("[warn] member list has no rows.\n") unless (@rows);
# parse rows
foreach my $row (@rows) {
my @cols = ($row =~ /<td[^<>]*?>(.*?)<\/td>/g);
if ($#cols >= 1 and $cols[1] =~ /<a href="([^'""<>]*?)">(.*)<\/a>/) {
my $item = {'link' => $self->absolute_url($1, $base), 'subject' => $self->rewrite($2)};
$item->{'date'} = "${1}/${2}/${3}" if ($cols[0] =~ /(\d{4})ǯ(\d{4})·î(\d{4})Æü/);
$item->{'delete_member'} = {'link' => $self->absolute_url($1, $base), 'subject' => $self->rewrite($2)} if ($#cols >= 2 and $cols[2] =~ /<a href="([^'""<>]*?)">(.*)<\/a>/);
$item->{'transfer_admin'} = {'link' => $self->absolute_url($1, $base), 'subject' => $self->rewrite($2)} if ($#cols >= 3 and $cols[3] =~ /<a href="([^'""<>]*?)">(.*)<\/a>/);
push(@items, $item);
}
}
return @items;
}
sub parse_edit_member_pages {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $current = $res->request->uri->as_string;
my $content = $res->content;
my @items = ();
# get page list part
my $content_from = qq(\Q<!-- start: page number -->\E[^\\[\\]]*\\[);
my $content_till = qq(\\][^\\[\\]]*\Q<!-- end: page number -->\E);
return $self->log("[warn] page list part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse rows
$content =~ s/[\t\r\n]//g;
while ($content =~ s/ (?:<a href=["']?([^"'<>]*)["']?>)?(\d+)(?:<\/a>)? / /) {
my $item = {'subject' => $self->rewrite($2)};
$item->{'link'} = ($1) ? $self->absolute_url($1, $base) : $current;
$item->{'current'} = ($1) ? 0 : 1;
push(@items, $item);
}
return @items;
}
sub parse_list_bbs {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get bbs list part
my $content_from = qq(\Q<table border="0" cellspacing="1" cellpadding=3 width="630">\E);
my $content_till = qq(\Q<!--///·Ç¼¨ÈÄ°ìÍ÷¤³¤³¤Þ¤Ç///-->\E);
return $self->log("[warn] bbs list part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# get records
my $record_from = qq(\Q<!--¢¥¹¥ì1-->\E);
my $record_till = "\n\n<\/td>\n<\/tr>\n\n";
my @records = ($content =~ /$record_from(.*?)$record_till/isg);
return $self->log("[warn] no bbs records found.\n") unless (@records);
# parse records
my $re_date = '<td align="center" rowspan="3" nowrap="nowrap" bgcolor="#FFD8B0" width="65">(\d{2})·î(\d{2})Æü<br />(\d{1,2}):(\d{2})</td>';
my $re_subj = '<td bgcolor="#FFF4E0"> (.+?)</td>';
my $re_thum = '<td bgcolor="#FFFFFF">(.*?)</table>';
my $re_desc = '<td class="h120" width="551">\n*(.*?)\n</td>';
my $re_name = '\((.*?)\)';
my $re_link = '<a href="?([^<>]+)"?>½ñ¤¹þ¤ß\((\d+)\)<\/a>';
foreach my $record (@records) {
unless ($record =~ /$re_date/is) { $self->log("[warn] time is not found.\n$record\n"); next; }
my $time = sprintf('%02d/%02d %02d:%02d', $1, $2, $3, $4);
unless ($record =~ /${re_subj}/is) { $self->log("[warn] subject is not found.\n$record\n"); next; }
my $subj = $1;
unless ($record =~ /${re_thum}/is) { $self->log("[warn] thums are not found.\n$record\n"); next; }
my $thumbs = $1;
unless ($record =~ /${re_desc}/is) { $self->log("[warn] desc is not found.\n$record\n"); next; }
my $desc = $1;
unless ($record =~ /${re_link}/is) { $self->log("[warn] link is not found.\n$record\n"); next; }
my ($link, $count) = ($1, $2);
$subj = $self->rewrite($subj);
$desc = $self->rewrite($desc);
$desc =~ s/^$//g;
$link = $self->absolute_url($link, $base);
my @images = ();
while ($thumbs =~ s/MM_openBrWindow\('(.*?)',.+?<img src=["']?([^<>]*?)['"]? border//is){
my $img = $self->absolute_url($1, $base);
my $thumbimg = $self->absolute_url($2, $base);
push(@images, {'thumb_link' => $thumbimg, 'link' => $img});
}
push(@items, {'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $link, 'count' => $count, 'images' => [@images]});
}
return @items;
}
sub parse_list_bbs_next {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<td align="right">.*?<a href=([^<>]*?list_bbs.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_list_bbs_previous {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<td align="right"><a href=([^<>]*?list_bbs.pl[^<>]*?)>([^<>]*?)<\/a>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_list_bookmark {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get bookmark list part
my $content_from = qq(\Q<!-- ### friend_loop.s ### -->\E);
my $content_till = qq(\Q<!-- ### friend_loop.e ### -->\E);
return $self->log("[warn] bookmark list part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse rows
my $record_from = qq(\Q<table border="0" cellspacing="1" cellpadding="4" width="500">\E);
my $record_till = qq(\Q</table>\E);
my @records = ($content =~ /$record_from(.*?)$record_till/isg);
return $self->log("[warn] no bookmark records found.\n") unless (@records);
foreach my $record (@records) {
my $item = {};
my @lines = ($record =~ /<tr.*?>(.*?)<\/tr>/isg);
if (@lines < 3) { $self->log("[warn] not enough rows are found in record.\n$record"); next; }
my @rows = map { [$_ =~ /<td\b[^<>]*>(.*?)<\/td>/gis] } @lines[0..2];
if (@{$rows[0]} < 3) { $self->log("[warn] not enough cols are found in first row.\n$lines[0]"); next; }
if (@{$rows[1]} < 2) { $self->log("[warn] not enough cols are found in second row.\n$lines[1]"); next; }
if (@{$rows[2]} < 2) { $self->log("[warn] not enough cols are found in third row.\n$lines[2]"); next; }
my @cols = @{$rows[0]};
$item->{'link'} = ($cols[0] =~ /(<a\b.*?>)/) ? $self->parse_standard_tag($1)->{'attr'}->{'href'} : $self->log("[warn] link is not found in the col.\n" . $cols[0]);
$item->{'image'} = ($cols[0] =~ /(<img\b.*?>)/) ? $self->parse_standard_tag($1)->{'attr'}->{'src'} : $self->log("[warn] image is not found in the col.\n" . $cols[0]);
$item->{'subject'} = (length($cols[2])) ? $cols[2] : $self->log("[warn] subject is not found in the col.\n" . $cols[2]);
$item->{'gender'} = undef;
@cols = @{$rows[1]};
$item->{'description'} = $cols[1];
@cols = @{$rows[2]};
$item->{'time'} = $cols[1];
# format
$item->{'description'} =~ s/(^\n+|\s+$)//gs;
foreach (qw(image link)) { $item->{$_} = $self->absolute_url($item->{$_}, $base) if ($item->{$_}); }
foreach (qw(subject description)) { $item->{$_} = $self->rewrite($item->{$_}); }
$item->{'time'} = $self->convert_login_time($item->{'time'}) if ($item->{'time'});
if (not $item->{'link'} or not $item->{'subject'}) { $item->{'record'} = $record, $self->log("[warn] not enough datas in record.\n$record"); next; }
push(@items, $item) if ($item->{'subject'} and $item->{'link'});
}
@items = sort { $b->{'time'} cmp $a->{'time'} } @items;
return @items;
}
sub parse_list_comment {
my $self = shift;
return $self->parse_standard_history(@_);
}
sub parse_list_community {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my $status_backgrounds = {
'bg_orange1-.gif' => '´ÉÍý¼Ô',
};
# get community list part
my $content_from = qq(\Q<table border="0" cellspacing="1" cellpadding="2" width="560">\E);
my $content_till = qq(\Q</table>\E);
return $self->log("[warn] community list part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# get community list rows
my @rows = ();
push(@rows, [$1, $2]) while ($content =~ s/<tr align="center" bgcolor="#FFFFFF">(.*?)<\/tr>\s*<tr align="center" bgcolor="#FFF4E0">(.*?)<\/tr>//is);
return $self->log("[warn] community list has no rows.\n") unless (@rows);
# parse each items
foreach my $row (@rows) {
my ($image_part, $text_part) = @{$row};
my @images = ($image_part =~ /<td\b[^<>]*>.*?<\/td>/gis);
my @texts = ($text_part =~ /<td\b[^<>]*>(.*?)<\/td>/gis);
return $self->log("[warn] image is missing in image part.\n\t$image_part\n") unless (@images);
return $self->log("[warn] text is missing in text part.\n\t$text_part\n") unless (@texts);
for (my $i = 0; $i < @images or $i < @texts; $i++) {
my $item = {};
my ($image, $text) = ($images[$i], $texts[$i]);
unless ($text =~ /^\s*([^\n]*)\((\d+)\)\n/) {
$self->log("[warn] name or count is missing in text.\n\t$text\n") if ($i == 0);
last;
}
($item->{'subject'}, $item->{'count'}) = ($1, $2);
unless ($image =~ /(<td\b[^<>]*>)\s*(<a\b[^<>]*>)\s*(<img\b[^<>]*>)/s) {
$self->log("[warn] td, a or img tag is missing in image.\n\t$image\n") if ($i == 0);
next;
}
my @tags = ($1, $2, $3);
my ($td, $a, $img) = map { $self->parse_standard_tag($_) } @tags;
$item->{'background'} = $td->{'attr'}->{'background'} or return $self->log("[warn] background is missing in tag.\n\t$tags[0]\n");
$item->{'link'} = $a->{'attr'}->{'href'} or return $self->log("[warn] link is missing in tag.\n\t$tags[1]\n");
$item->{'image'} = $img->{'attr'}->{'src'} or return $self->log("[warn] image is missing in tag.\n\t$tags[2]\n");
$item->{'status'} = ($item->{'background'} and $item->{'background'} =~ /([^\/]+)$/) ? $1 : undef;
if ($item->{'link'}) {
$item->{'subject'} = $self->rewrite($item->{'subject'});
$item->{'link'} = $self->absolute_url($item->{'link'}, $base);
$item->{'image'} = $self->absolute_url($item->{'image'}, $base);
$item->{'background'} = $self->absolute_url($item->{'background'}, $base);
$item->{'status'} = $status_backgrounds->{$item->{'status'}};
push(@items, $item);
}
}
}
return @items;
}
sub parse_list_community_next {
my $self = shift;
my ($res, $content, $url, $base) = $self->parse_parser_params(@_);
return unless ($res and $res->is_success);
return $self->log("[warn] Page link part is missing.\n") unless ($content =~ s/^.*\Q<table border=0 cellspacing=0 cellpadding=0 width=556>\E(.*?)<\/table>.*$/$1/s);
return $self->log("[warn] Next page is not exists.\n") unless ($content =~ / (<a\b[^<>]*>)(.*?)<\/a>/);
my $subject = $self->rewrite($2);
my $tag = $self->parse_standard_tag($1);
my $link = $self->absolute_url($tag->{'attr'}->{'href'}, $base);
my $next = {'link' => $link, 'subject' => $subject};
return $next;
}
sub parse_list_community_previous {
my $self = shift;
my ($res, $content, $url, $base) = $self->parse_parser_params(@_);
return unless ($res and $res->is_success);
return $self->log("[warn] Page link part is missing.\n") unless ($content =~ s/^.*\Q<table border=0 cellspacing=0 cellpadding=0 width=556>\E(.*?)<\/table>.*$/$1/s);
return $self->log("[warn] Previous page is not exists.\n") unless ($content =~ /(<a\b[^<>]*>)(.*?)<\/a> /);
my $subject = $self->rewrite($2);
my $tag = $self->parse_standard_tag($1);
my $link = $self->absolute_url($tag->{'attr'}->{'href'}, $base);
my $previous = {'link' => $link, 'subject' => $subject};
return $previous;
}
sub parse_list_diary {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my $re_date = '<td [^<>]*><font COLOR=#996600>(\d{4})ǯ<br \/>(\d{2})·î(\d{2})Æü<br>(\d{1,2}):(\d{2})</font>.*?</td>';
my $re_subj = '<td bgcolor="#FFF4E0"> (.+?)</td>';
my $re_desc = '<td CLASS=h120>\n(?:<table>(.*?)<\/table>)?\n(.+?)\n<br>\n\n</td>';
my $re_link = '<a href="?(.+?)"?>³¤¤Ï¤³¤Á¤é<\/a>';
my $re_comm = '<a href="?.+?"?>¥³¥á¥ó¥È\((\d+)\)<\/a>';
# get diary list part
my $content_from = qq(\Q<table BORDER=0 CELLSPACING=1 CELLPADDING=3 WIDTH=525>\E);
my $content_till = qq(\Q<table BORDER=0 CELLSPACING=0 CELLPADDING=0 BGCOLOR=#D3B16D>\E);
return $self->log("[warn] diary list part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# get diary list items
my @rows = ();
push(@rows, $1) while ($content =~ s/<tr VALIGN=top>(.*?)(<tr VALIGN=top>|<\/table>\s*$)/$2/is);
return $self->log("[warn] diary list has no rows.\n") unless (@rows);
# parse each items
foreach my $row (@rows) {
my $row_org = $row;
my $time = ($row =~ s/$re_date//is) ? sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5) : $self->log("[warn] row does not match re_date.");
my $subj = ($row =~ s/$re_subj//is) ? $1 : $self->log("[warn] row does not match re_subj.");
my ($thumbs, $desc) = ($row =~ s/$re_desc//is) ? ($1, $2) : $self->log("[warn] row does not match re_desc.");
my $count = ($row =~ s/$re_comm//is) ? $1 : $self->log("[warn] row does not match re_comm.");
my $link = ($row =~ s/$re_link//is) ? $1 : $self->log("[warn] row does not match re_link.");
if (scalar(grep { not defined($_) } ($time, $subj, $desc, $link, $count))) {
$self->log($row_org);
next;
}
$subj = $self->rewrite($subj);
$desc = $self->rewrite($desc);
$desc =~ s/^$//g;
$link = $self->absolute_url($link, $base);
my @images = ();
while ($thumbs =~ s/MM_openBrWindow\('(.*?)',.+?<img src=["']?([^<>]*?)['"]? border//is){
my $img = $self->absolute_url($1, $base);
my $thumbimg = $self->absolute_url($2, $base);
push(@images, {'thumb_link' => $thumbimg, 'link' => $img});
}
push(@items, {'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $link, 'count' => $count, 'images' => [@images]});
}
return @items;
}
sub parse_list_diary_capacity {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->request->uri->as_string;
my $content = $res->content;
return unless ($content =~ /<table width="165" border="0" cellspacing="1" cellpadding="2">(.*?)<\/table>/is);
my $box = $1;
return unless ($box =~ /(\d+\.\d+).*?MB\/.*?(\d+\.\d+).*?MB/);
my $capacity = {'used' => $1, 'max' => $2};
return $capacity;
}
sub parse_list_diary_next {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5>.*?<a href=([^<>]*?list_diary.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_list_diary_previous {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5><a href=([^<>]*?list_diary.pl[^<>]*?)>([^<>]*?)<\/a>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_list_diary_monthly_menu {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get monthly menu part
my $content_from = qq(<img .*?alt=\Q"³Æ·î¤ÎÆüµ"\E.*?>);
my $content_till = qq(\Q</table>\E);
return $self->log("[warn] monthly menu part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# get monthly menu items
my @rows = ($content =~ /(<a [^<>]*>)/gis);
return $self->log("[warn] monthly meny has no rows.\n") unless (@rows);
# parse monthly menu
foreach my $row (@rows) {
my $anchor = $self->parse_standard_tag($row);
my $link = $anchor->{'attr'}->{'href'};
my $year = $1 if ($link =~ /year=(\d+)/i);
my $month = $1 if ($link =~ /month=(\d+)/i);
push(@items, {'link' => $self->absolute_url($link, $base), 'year' => $year, 'month' => $month}) if ($link and $year and $month);
}
return @items;
}
sub parse_list_friend {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my $status_backgrounds = {
'bg_orange1-.gif' => '1»þ´Ö°ÊÆâ',
'bg_orange2-.gif' => '1Æü°ÊÆâ',
};
my @time1 = reverse((localtime(time - 3600))[0..5]);
my @time2 = reverse((localtime(time - 3600 * 24))[0..5]);
# get friend list part
my $content_from = qq(\Q<table border="0" cellspacing="1" cellpadding="2" width="560">\E);
my $content_till = qq(\Q</table>\E);
return $self->log("[warn] friend list part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# get friend list rows
my @rows = ();
push(@rows, [$1, $2]) while ($content =~ s/\Q<tr align="center" bgcolor="#FFFFFF">\E(.*?)<\/tr>\s*\Q<tr align="center" bgcolor="#FFF4E0">\E(.*?)<\/tr>//is);
return $self->log("[warn] friend list has no rows.\n") unless (@rows);
# parse each items
foreach my $row (@rows) {
my ($image_part, $text_part) = @{$row};
my @images = ($image_part =~ /<td\b[^<>]*>.*?<\/td>/gis);
my @texts = ($text_part =~ /<td\b[^<>]*>(.*?)<\/td>/gis);
return $self->log("[warn] image is missing in image part.\n\t$image_part\n") unless (@images);
return $self->log("[warn] text is missing in text part.\n\t$text_part\n") unless (@texts);
for (my $i = 0; $i < @images or $i < @texts; $i++) {
my $item = {};
my ($image, $text) = ($images[$i], $texts[$i]);
last if ($text eq '<br>');
$text =~ /^\s*([^<>]*)\((\d+)\)\s*(?:<br\b[^<>]*>|$)/s or return $self->log("[warn] name or count is missing in text.\n\t$text\n");
($item->{'subject'}, $item->{'count'}) = ($1, $2);
$image =~ /(<td\b[^<>]*>)\s*(<a\b[^<>]*>)\s*(<img\b[^<>]*>)/s or return $self->log("[warn] td, a or img tag is missing in image.\n\t$image\n");
my @tags = ($1, $2, $3);
my ($td, $a, $img) = map { $self->parse_standard_tag($_) } @tags;
$item->{'background'} = $td->{'attr'}->{'background'} or return $self->log("[warn] background is missing in tag.\n\t$tags[0]\n");
$item->{'link'} = $a->{'attr'}->{'href'} or return $self->log("[warn] link is missing in tag.\n\t$tags[1]\n");
$item->{'image'} = $img->{'attr'}->{'src'} or return $self->log("[warn] image is missing in tag.\n\t$tags[2]\n");
$item->{'status'} = ($item->{'background'} and $item->{'background'} =~ /([^\/]+)$/) ? $1 : undef;
if ($item->{'link'}) {
$item->{'subject'} = $self->rewrite($item->{'subject'});
$item->{'link'} = $self->absolute_url($item->{'link'}, $base);
$item->{'id'} = $2 if ($item->{'link'} =~ /(.*?)?id=(\d*)/);
$item->{'image'} = $self->absolute_url($item->{'image'}, $base);
$item->{'background'} = $self->absolute_url($item->{'background'}, $base);
$item->{'status'} = $status_backgrounds->{$item->{'status'}};
push(@items, $item);
}
}
}
return @items;
}
sub parse_list_friend_next {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ / <a href=([^<>]*?list_friend.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_list_friend_previous {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->request->uri->as_string;
my $content = $res->content;
return unless ($content =~ /<a href=([^<>\s]*list_friend.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a> /);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $previous = {'link' => $link, 'subject' => $2};
return $previous;
}
sub parse_list_member {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get member list part
my $content_from = "\Q<table border=\"0\" cellspacing=\"1\" cellpadding=\"2\" width=\"560\">\E";
my $content_till = "\Q</table>\E";
return $self->log("[warn] member list part is missing.\n") unless ($content =~ /$content_from(.+?)$content_till/s);
$content = $1;
# get member list rows
my @rows = ();
push(@rows, [$1, $2]) while ($content =~ s/<tr align="center" bgcolor="#FFFFFF">(.*?)<\/tr>\s*<tr align="center" bgcolor="#FFF4E0">(.*?)<\/tr>//is);
return $self->log("[warn] no rows found in member list part.\n") unless (@rows);
# parse each items
foreach my $row (@rows) {
my ($image_part, $text_part) = @{$row};
my @images = ($image_part =~ /<td\b[^<>]*>.*?<\/td>/gis);
my @texts = ($text_part =~ /<td\b[^<>]*>(.*?)<\/td>/gis);
return $self->log("[warn] image is missing in image part.\n\t$image_part\n") unless (@images);
return $self->log("[warn] text is missing in text part.\n\t$text_part\n") unless (@texts);
for (my $i = 0; $i < @images or $i < @texts; $i++) {
my $item = {};
my ($image, $text) = ($images[$i], $texts[$i]);
unless ($text =~ /^\s*([^<>]*)\((\d+)\)\s*$/) {
$self->log("[warn] name or count is missing in text.\n\t$text\n") if ($i == 0);
last;
}
($item->{'subject'}, $item->{'count'}) = ($1, $2);
unless ($image =~ /(<td\b[^<>]*>)\s*(<a\b[^<>]*>)\s*(<img\b[^<>]*>)/s) {
$self->log("[warn] td, a or img tag is missing in image.\n\t$image\n") if ($i == 0);
next;
}
my @tags = ($1, $2, $3);
my ($td, $a, $img) = map { $self->parse_standard_tag($_) } @tags;
$item->{'background'} = $td->{'attr'}->{'background'} or return $self->log("[warn] background is missing in tag.\n\t$tags[0]\n");
$item->{'link'} = $a->{'attr'}->{'href'} or return $self->log("[warn] link is missing in tag.\n\t$tags[1]\n");
$item->{'image'} = $img->{'attr'}->{'src'} or return $self->log("[warn] image is missing in tag.\n\t$tags[2]\n");
$item->{'status'} = ($item->{'background'} and $item->{'background'} =~ /([^\/]+)$/) ? $1 : undef;
if ($item->{'link'}) {
$item->{'subject'} = $self->rewrite($item->{'subject'});
$item->{'link'} = $self->absolute_url($item->{'link'}, $base);
$item->{'image'} = $self->absolute_url($item->{'image'}, $base);
$item->{'background'} = $self->absolute_url($item->{'background'}, $base);
$item->{'id'} = $1 if ($item->{'link'} =~ /\bid=(\d+)/);
push(@items, $item);
}
}
}
return @items;
}
sub parse_list_member_next {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ / <a href=([^<>]*?list_member.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_list_member_previous {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->request->uri->as_string;
my $content = $res->content;
return unless ($content =~ /<a href=([^<>\s]*list_member.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a> /);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $previous = {'link' => $link, 'subject' => $2};
return $previous;
}
sub parse_list_message {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->request->uri->as_string;
my $content = $res->content;
my @items = ();
my $img_rep = $self->absolute_url('img/mail5.gif', $base);
my %emvelopes = (
$self->absolute_url('img/mail1.gif', 'http://img.mixi.jp/') => 'new',
$self->absolute_url('img/mail2.gif', 'http://img.mixi.jp/') => 'opened',
$self->absolute_url('img/mail5.gif', 'http://img.mixi.jp/') => 'replied',
);
my $re_link = '<a href="?(.+?)"?>(.+?)<\/a>';
if ($content =~ /<!--¼õ¿®È¢°ìÍ÷-->.*?<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=553>(.+?)<\/table>/s) {
$content = $1;
while ($content =~ s/<tr BGCOLOR="(#FFF7E1|#FFFFFF)">(.*?)<\/tr>//s) {
my $message = $2;
my $emvelope = ($message =~ s/<td[^<>]*>\s*<img SRC="(.*?)".*?>\s*<\/td>//s) ? $self->absolute_url($1, $base) : undef;
my $status = $emvelopes{$emvelope} ? $emvelopes{$emvelope} : 'unknown';
if ($message =~ /<td>([^<>]*?)<\/td>\s*<td>${re_link}<\/td>\s*<td>(\d{2})·î(\d{2})Æü<\/td>/is) {
my ($name, $link, $subj) = ($1, $2, $3);
my $time = sprintf('%02d/%02d', $4, $5);
my $item = {
'time' => $time,
'subject' => $self->rewrite($subj),
'name' => $self->rewrite($name),
'link' => $self->absolute_url($link, $base),
'status' => $status,
'emvelope' => $emvelope,
};
push(@items, $item);
}
}
}
return @items;
}
sub parse_list_outbox {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->request->uri->as_string;
my $content = $res->content;
my @items = ();
my $re_link = '<a href="?(.+?)"?>(.+?)<\/a>';
if ($content =~ /<!--Á÷¿®ºÑ¤ß°ìÍ÷-->.*?<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=553>(.+?)<\/table>/s) {
$content = $1;
while ($content =~ s/<tr BGCOLOR="?(#FFF7E1|#FFFFFF)"?>(.*?)<\/tr>//s) {
my $message = $2;
if ($message =~ /<td>([^<>]*?)<\/td>\s*<td>${re_link}<\/td>\s*<td>(\d{2})·î(\d{2})Æü<\/td>/is) {
my ($name, $link, $subj) = ($1, $2, $3);
my $time = sprintf('%02d/%02d', $4, $5);
my $item = {
'time' => $time,
'subject' => $self->rewrite($subj),
'name' => $self->rewrite($name),
'link' => $self->absolute_url($link, $base),
};
push(@items, $item);
}
}
}
return @items;
}
sub parse_list_request {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get requests
my @records = ($content =~ /(<a name="\d+">.*?)<\/table>/isg);
return $self->log("[info] No request found.\n") if (not @records);
# parse requests
foreach my $record (@records) {
my $item = {};
my $record = $1;
$record =~ s/^.*<table\b[^<>]*>//is;
my @lines = ($record =~ /<tr.*?>(.*?)<\/tr>/gis);
if (@lines < 4) { $self->log("[warn] not enough rows are found in record.\n$record"); next; }
my @rows = map { [$_ =~ /<td\b[^<>]*>(.*?)<\/td>/gis] } @lines[0..3];
if (@{$rows[0]} < 3) { $self->log("[warn] not enough cols are found in first row.\n$lines[0]"); next; }
if (@{$rows[1]} < 2) { $self->log("[warn] not enough cols are found in second row.\n$lines[1]"); next; }
if (@{$rows[2]} < 2) { $self->log("[warn] not enough cols are found in third row.\n$lines[2]"); next; }
if (@{$rows[3]} < 3) { $self->log("[warn] not enough cols are found in fourth row.\n$lines[3]"); next; }
my @cols = @{$rows[0]};
$item->{'link'} = ($cols[0] =~ /(<a\b.*?>)/) ? $self->parse_standard_tag($1)->{'attr'}->{'href'} : $self->log("[warn] link is not found in the col.\n" . $cols[0]);
$item->{'image'} = ($cols[0] =~ /(<img\b.*?>)/) ? $self->parse_standard_tag($1)->{'attr'}->{'src'} : $self->log("[warn] image is not found in the col.\n" . $cols[0]);
$item->{'subject'} = ($cols[2] =~ /<a\b.*?>(.*?)<\/a>/i) ? $1 : $self->log("[warn] subject is not found in the col.\n" . $cols[2]);
$item->{'gender'} = undef;
@cols = @{$rows[1]};
$item->{'description'} = $cols[1];
@cols = @{$rows[2]};
$item->{'message'} = $cols[1];
@cols = @{$rows[3]};
$item->{'time'} = $cols[1];
$item->{'button'} = [];
foreach my $button ($cols[2] =~ /<a\b[^<>]*>.*?<\/a>/gis) {
my $link = ($button =~ /(<a\b.*?>)/) ? $self->parse_standard_tag($1) : $self->log("[warn] link is not found in the button.\n$button");
my $image = ($button =~ /(<img\b.*?>)/) ? $self->parse_standard_tag($1) : $self->log("[warn] image is not found in the button.\n$button");
$button = { 'link' => $link->{'attr'}->{'href'}, 'image' => $image->{'attr'}->{'src'}, 'title' => $image->{'attr'}->{'alt'} };
map { $button->{$_} = $self->absolute_url($button->{$_}, $base) } qw(link image);
map { $button->{$_} = $self->rewrite($button->{$_}, $base) } qw(title);
$item->{'button'} = [] unless ($item->{'button'});
push(@{$item->{'button'}}, $button);
}
# format
map { $item->{$_} = $self->absolute_url($item->{$_}, $base) } qw(link image);
map { $item->{$_} = $self->rewrite($item->{$_}, $base) } qw(subject description message);
$item->{'time'} = $self->convert_login_time($item->{'time'}) if ($item->{'time'});
push(@items, $item) if ($item->{'subject'} and $item->{'link'});
}
@items = sort { $b->{'time'} cmp $a->{'time'} } @items;
return @items;
}
sub parse_new_album { &parse_standard_history(@_); }
sub parse_new_bbs { &parse_standard_history(@_); }
sub parse_new_bbs_next { &parse_standard_history_next(@_); }
sub parse_new_bbs_previous { &parse_standard_history_previous(@_); }
sub parse_new_comment { &parse_standard_history(@_); }
sub parse_new_friend_diary { &parse_standard_history(@_); }
sub parse_new_friend_diary_next { &parse_standard_history_next(@_); }
sub parse_new_friend_diary_previous { &parse_standard_history_previous(@_); }
sub parse_new_review { &parse_standard_history(@_); }
sub parse_release_info {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my $re_subj = '<b><font COLOR=#605048>(.+?)</font></b>';
my $re_date = '<td ALIGN=right><font COLOR=#605048>(\d{4}).(\d{2}).(\d{2})</font></td>';
my $re_desc = '<td CLASS=h130>(.*?)</td>';
if ($content =~ /¿·µ¡Ç½¥ê¥ê¡¼¥¹¡¦¾ã³²¤Î¤´Êó¹ð(.*?)<!--¥Õ¥Ã¥¿-->/s) {
$content = $1;
while ($content =~ s/<table BORDER=0 CELLSPACING=0 CELLPADDING=2 WIDTH=520 BGCOLOR=#F7F0E6>.*?${re_subj}.*?${re_date}.*?${re_desc}.*?<!--¢§1¤Äʬ¤³¤³¤Þ¤Ç-->//is) {
my $subj = $1;
my $date = sprintf('%04d/%02d/%02d', $2, $3, $4);
my $desc = $5;
$subj = $self->rewrite($subj);
$desc = $self->rewrite($desc);
$desc =~ s/^$//g;
push(@items, {'time' => $date, 'description' => $desc, 'subject' => $subj});
}
}
return @items;
}
sub parse_self_id {
my $self = shift;
my $session = $self->session;
return ($session and $session =~ /^(\d+)_/) ? $1 : 0;
}
sub parse_search_diary {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my @time = localtime();
my ($month, $year) = ($time[4] + 1, $time[5] + 1900);
if ($content =~ m{<!--///// ºÇ¿·Æüµ¸¡º÷¤³¤³¤Þ¤Ç /////-->(.+?)<!--¥Õ¥Ã¥¿-->}s) {
$content = $1;
while ($content =~ s/<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=550>(.*?)<\/table>//is) {
my $record = $1;
my @lines = ($record =~ /<tr.*?>(.*?)<\/tr>/gis);
my $item = {};
# parse record
($item->{'link'}, $item->{'image'}) = ($1, $2) if ($lines[0] =~ /<td WIDTH=90 .*?><a href="([^"]*view_diary.pl\?id=\d+\&owner_id=\d+)"><img SRC="([^"]*)".*?>/is);
($item->{'name'}, $item->{'gender'}) = ($1, $2) if ($lines[0] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>([^<>\n]*)/is);
$item->{'subject'} = $1 if ($lines[1] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?)<\/td>/is);
$item->{'description'} = $1 if ($lines[2] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?)<\/td>/is);
$item->{'time'} = $1 if ($lines[3] =~ /<td BGCOLOR=#FFFFFF WIDTH=220>(.*?)<\/td>/is);
# format
my @time = ($item->{'time'} =~ /\d+/g);
unshift(@time, ($time[0] == $month) ? $year : $year - 1) if (@time == 4);
$item->{'time'} = (@time == 5) ? sprintf('%04d/%02d/%02d %02d:%02d', @time) : '';
foreach (qw(image link)) { $item->{$_} = $self->absolute_url($item->{$_}, $base) if ($item->{$_}); }
foreach (qw(name subject description gender time)) {
$item->{$_} =~ s/<.*?>//g if ($item->{$_});
$item->{$_} = $self->rewrite($item->{$_});
}
push(@items, $item) if ($item->{'subject'} and $item->{'link'});
}
}
return @items;
}
sub parse_search_diary_next {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5>.*?<a href=([^<>]*?search_diary.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_search_diary_previous {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5><a href=([^<>]*?search_diary.pl[^<>]*?)>([^<>]*?)<\/a>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_show_calendar {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my %icons = ('i_sc-.gif' => 'ͽÄê', 'i_bd.gif' => 'ÃÂÀ¸Æü', 'i_iv1.gif' => '»²²Ã¥¤¥Ù¥ó¥È', 'i_iv2.gif' => '¥¤¥Ù¥ó¥È');
my %whethers = ('1' => 'À²', '2' => 'ÆÞ', '3' => '±«', '4' => 'Àã', '8' => '¤Î¤Á', '9' => '¤È¤¤É¤');
my @items = ();
my $term = $self->parse_show_calendar_term($res) or return undef;
# get calendar part
my $content_from = qq(\Q<table width="670" border="0" cellspacing="1" cellpadding="3">\E);
my $content_till = qq(\Q</table>\E);
return $self->log("[warn] calendar part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse main menu items
my @days = ();
$content =~ s/<tr align=center bgcolor=#fff1c4>.*?<\/tr>//is;
push(@days, [$1, $2]) while ($content =~ s/<td height="65" [^<>]*><font style="color: [^""]+">\s*(\d+)\s*<\/font>(.*?)<\/td>//is);
return $self->log("[warn] no day found in calendar.\n") unless (@days);
# parse each days
foreach my $day (@days) {
my ($date, $text) = @{$day};
$date = sprintf('%04d/%02d/%02d', $term->{'year'}, $term->{'month'}, $date);
if ($text =~ s/<img src="(.*?)" width="23" height="16" align="absmiddle" \/>(.*?)<\/font><\/font>//i) {
my $item = { 'subject' => "Å·µ¤", 'link' => undef, 'name' => $2, 'time' => $date, 'icon' => $1};
$item->{'icon'} = $self->absolute_url($item->{'icon'}, $base);
my $weather = ($item->{'icon'} =~ /i_w(\d+).gif$/) ? $1 : 'ÉÔÌÀ';
$weather =~ s/(\d)/$whethers{$1}/g;
$item->{'name'} = sprintf("%s(%s%%)", $weather, $self->rewrite($item->{'name'}));
push(@items, $item);
}
my @events = split(/<br>/, $text);
foreach my $event (@events) {
my $item = {};
if ($event =~ /<img src="(.*?)" width="16" height="16" align="middle" \/><a href=(.*?)>(.*?)<\/a>/i) {
$item = { 'subject' => $1, 'link' => $2, 'name' => $3, 'time' => $date, 'icon' => $1};
} elsif ($event =~ /<a href=".*?" onClick="MM_openBrWindow\('(view_schedule.pl\?id=\d+)'.*?\)"><img src="(.*?)" .*?>(.*?)<\/a>/i) {
$item = { 'subject' => $2, 'link' => $1, 'name' => $3, 'time' => $date, 'icon' => $2};
} else {
next;
}
$item->{'subject'} = ($item->{'subject'} =~ /([^\/]+)$/ and $icons{$1}) ? $icons{$1} : "ÉÔÌÀ($1)";
$item->{'link'} = $self->absolute_url($item->{'link'}, $base);
$item->{'icon'} = $self->absolute_url($item->{'icon'}, $base);
$item->{'subject'} = $self->rewrite($item->{'subject'});
$item->{'name'} = $self->rewrite($item->{'name'});
push(@items, $item);
}
}
return @items;
}
sub parse_show_calendar_term {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<a href="show_calendar.pl\?year=(\d+)&month=(\d+)&pref_id=\d+">[^&]*?<\/a>/);
return {'year' => $1, 'month' => $2};
}
sub parse_show_calendar_next {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<a href="(show_calendar.pl\?.*?)">([^<>]+?) >>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $subject};
return $next;
}
sub parse_show_calendar_previous {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<a href="(show_calendar.pl\?.*?)"><< ([^<>]+)/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $subject};
return $next;
}
sub parse_show_friend_outline {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->request->uri->as_string;
my $content = $res->content;
my $outline = {'link' => $base};
return unless ($content =~ /<img [^<>]*?src=["']?http:\/\/img.mixi.jp\/img\/q_yellow2.gif['"]?[^<>]*?>[^\r\n]*\n(.+?)\n[^\r\n]*?<img [^<>]*?src=["']?http:\/\/img.mixi.jp\/img\/q_yellow3.gif['"]?[^<>]*?>/s);
$content = $1;
# parse relation
if ($content =~ s/<td ALIGN=center COLSPAN=3>(.*?)<table BORDER=0 CELLSPACING=0 CELLPADDING=1 BGCOLOR=#D3B16D>//s) {
my $relation_part = $1;
my @nodes = ($relation_part =~ /(<a href=show_friend.pl\?id=\d+>.*?<\/a>)/g);
$outline->{'step'} = @nodes;
if ($outline->{'step'} == 2) {
if ($nodes[0] =~ /<a href="?(.+?)"?>(.+?)<\/a>/) {
my ($link, $name) = ($1, $2);
$outline->{'relation'} = { 'link' => $self->absolute_url($link, $base), 'name' => $self->rewrite($name) };
} else {
$outline->{'relation'} = { 'link' => '', 'name' => '' };
}
}
}
# parse image
if ($content =~ s/<table BORDER=0 CELLSPACING=0 CELLPADDING=3 WIDTH=250 BGCOLOR=#FFFFFF>(.*?)<\/table>//s) {
my $image_part = $1;
$outline->{'image'} = ($image_part =~ s/<img SRC="(.*?)".*?VSPACE=2.*?>//) ? $self->absolute_url($1, $base) : '';
}
# parse nickname
if ($content =~ s/([^\n]+)¤µ¤ó\((\d+)\)<br>\n<span class="f08x">\((.*?)\)<\/span><br>//) {
my ($name, $count, $desc) = ($1, $2, $3);
$outline->{'name'} = $self->rewrite($name);
$outline->{'count'} = $count;
$outline->{'description'} = $self->rewrite($desc);
}
return $outline;
}
sub parse_show_friend_profile {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my $profile = {};
my $re_link = '<a href=.*?>(.+?)<\/a>';
return unless ($content = ($content =~ /<!--¥×¥í¥Õ¥£¡¼¥ë-->(.+?)<!--¥×¥í¥Õ¥£¡¼¥ë¤³¤³¤Þ¤Ç-->/s) ? $1 : '');
return unless ($content = ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=425>(.+?)<!-- start:/s) ? $1 : '');
while ($content =~ s/<tr BGCOLOR=#FFFFFF>(.*?)<\/tr>//is) {
my $row = $1;
my ($key, $val) = ($row =~ /<td\b.*?>(.*?)<\/td>/gs);
$key =~ s/ //g;
$key = $self->rewrite($key);
$key =~ s/(^\s+|\s+$)//gs;
$val =~ s/[\r\n]//g;
$val =~ s/<br ?\/?>/\n/g;
$val =~ s/$re_link/$1/g;
$val = $self->rewrite($val);
$val =~ s/(^\s+|\s+$)//gs;
$profile->{$key} = $val;
}
return $profile if (keys(%{$profile}));
return;
}
sub parse_show_intro {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
if ($content =~ /¤«¤é¤Î¾Ò²ðʸ(.+?)<!--¥Õ¥Ã¥¿-->/s) {
$content = $1;
while ($content =~ s/<tr bgcolor=#FFFFFF>.*?<a href="(.+?)"><img src="(.+?)".*?\n(.+?)<\/td>.*?<td WIDTH=480>\n(.*?)\n(.*?)<\/td>//is) {
my ($link, $img, $name, $rel, $desc) = ($1, $2, $3, $4, $5);
$rel =~ s/´Ø·¸¡§(.+?)<br>/$1/;
my $intro = ($desc =~ /edit_intro.pl\?id=.+?\&type=edit/) ? "1" : "0";
my $delete = ($desc =~ s/<a href="delete_intro.pl\?id=(\d+)">ºï½ü<\/a>//s) ? "1" : "0";
$name = $self->rewrite($name);
$rel = $self->rewrite($rel);
$desc = $self->rewrite($desc);
$desc =~ s/¤³¤Îͧ¿Í¤ò¾Ò²ð¤¹¤ë//;
$desc =~ s/[\r\n]+//ig;
$link = $self->absolute_url($link, $base);
my $item = {'link' => $link, 'name' => $name, 'image' => $img, 'relation' => $rel, 'description' => $desc, 'introduction' => $intro, 'detele' => $delete};
push(@items, $item);
}
}
return @items;
}
sub parse_show_log {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my $re_date = '(\d{4})ǯ(\d{2})·î(\d{2})Æü (\d{1,2}):(\d{2})';
my $re_link = '<a href="?(.+?)"?>(.+?)<\/a>';
# get log part
my $content_from = qq(\Q<ul class="log new_log" style="margin:0px;padding:0px;">\E);
my $content_till = qq(\Q</ul>\E);
return $self->log("[warn] log part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse main menu items
my @lines = ($content =~ /<li\b[^<>]*>(.*?)<\/li>/gs);
return $self->log("[warn] no log found in log part.\n") unless (@lines);
# parse each items
foreach my $line (@lines) {
$line =~ /${re_date} (<a\b[^<>]*>)(.*)<\/a>/ or return $self->log("[warn] a tag, date or name in not found in '$line'.\n");
my $time = sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5);
my $a = $self->parse_standard_tag($6);
my $name = $self->rewrite($7);
my $link = $self->absolute_url($a->{'attr'}->{'href'}, $base);
push(@items, {'time' => $time, 'name' => $name, 'link' => $link});
}
return @items;
}
sub parse_show_log_count {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my $count = ($content =~ /¥Ú¡¼¥¸Á´ÂΤΥ¢¥¯¥»¥¹¿ô¡§<b>(\d+)<\/b> ¥¢¥¯¥»¥¹/) ? $1 : 0;
return $count;
}
sub parse_view_album {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get album part
my $content_from = qq(\Q<!-- begin box -->\E);
my $content_with = qq(\Q<!-- end album -->\E);
my $content_till = qq(\Q<!-- begin list -->\E);
return $self->log("[warn] album part is missing.\n") unless ($content =~ /$content_from(.*?$content_with.*?)$content_till/s);
$content = $1;
# parse album part
my $img = ($content =~ /<div class="thumbnail">(<img .*?>)/is) ? $1 : return $self->log("[warn] thumbnail is missing.\n");
$img = $self->parse_standard_tag($img);
$img = $img->{'attr'}->{'src'};
my $name = ($content =~ /<div class="entry">(.*?)\Q¤µ¤ó¤Î¥Õ¥©¥È¥¢¥ë¥Ð¥à\E<\/p>/is) ? $1 : return $self->log("[warn] name is missing.\n");
my $subj = ($content =~ /<td class="photo_title">(.*?)<\/td>/is) ? $1 : return $self->log("[warn] title is missing.\n");
my $desc = ($content =~ /ÀâÌÀ<\/th>\s*<td class="h120">(.*?)<\/td>/s) ? $1 : return $self->log("[warn] description is missing.\n");
my $level = ($content =~ /¸ø³«¥ì¥Ù¥ë<\/th>\s*<td>(.*?)<br \/>/s) ? $1 : return $self->log("[warn] level is missing.\n");
my $time = ($content =~ /ºîÀ®Æü»þ<\/th>\s*<td>(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2})<\/td>/s) ? sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5) : return $self->log("[warn] time is missing.\n");
my $comm = ($content =~ /<td [^<>]*class="view_etc">.*?¥³¥á¥ó¥È\((\d+)\)/is) ? $1 : return $self->log("[warn] comment is missing.\n");
my $number = ($content =~ /<span class="number">.*?(\d+)Ëç/) ? $1 : return $self->log("[warn] number is missing.\n");
$name = $self->rewrite($name);
$subj = $self->rewrite($subj);
$desc = $self->rewrite($desc);
my $item = { 'image' => $self->absolute_url($img, $base), 'name' => $name, 'subject' => $subj, 'description' => $desc, 'level' => $level, 'time' => $time, 'comment_number' => $comm, 'photo_number' => $number};
push(@items, $item);
return @items;
}
sub parse_view_album_comment {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get comment part
my $content_from = "\Q<!-- begin comment loop -->\E";
my $content_till = "\Q<!-- end comment loop -->\E";
return $self->log("[warn] Album comment part is missing.\n") unless ($content =~ /$content_from(.+?)$content_till/s);
$content = $1;
# parse comment items
my @rows = ($content =~ /(<th rowspan="2">.*?<\/tr>.*?)<\/tr>/gis);
return $self->log("[warn] no item found in album comment part.\n") unless (@rows);
# parse comments
foreach my $str (@rows) {
my $time = ($str =~ /<th rowspan="2">(\d{4})ǯ(\d{2})·î(\d{2})Æü<br \/>(\d{2}):(\d{2})/) ? sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5) : next;
my ($link, $name) = ($str =~ /<td class="user_comm">(<a .*?>)(.*?)<\/a>/is) ? ($1, $2) : next;
$link = $self->parse_standard_tag($link);
$link = $link->{'attr'}->{'href'};
my $desc = ($content =~ /<td class="h120">(.*?)<\/td>/is) ? $1 : next;
my $item = {
'time' => $time,
'link' => $self->absolute_url($link, $base),
'name' => $self->rewrite($name),
'description' => $self->rewrite($desc)
};
push(@items, $item);
}
return @items;
}
sub parse_view_album_photo {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get album photo part
my $content_from = qq(\Q<!-- begin list -->\E);
my $content_till = qq(\Q<!-- end list -->\E);
return $self->log("[warn] album photo part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse album photo items
my @rows = ($content =~ /<div class="thumbnail">(.*?)<\/p>/gs);
return $self->log("[warn] no item found in album photo part.\n") unless (@rows);
# parse tool bar part
foreach my $str (@rows) {
my $anchor = ($str =~ /(<a .*?>)/) ? $1 : next;
my $image = ($str =~ /(<img .*?>)/) ? $1 : next;
my $subj = ($str =~ /<p class="cover"><a .*?>(.*?)<\/a>/) ? $1 : next;
($anchor, $image) = map { $self->parse_standard_tag($_) } ($anchor, $image);
my $item = {
'description' => $image->{'attr'}->{'alt'},
'thumb_link' => $self->absolute_url($image->{'attr'}->{'src'}, $base),
'link' => $self->absolute_url($anchor->{'attr'}->{'href'}, $base),
'subject' => $self->rewrite($subj)
};
push(@items, $item);
}
return @items;
}
sub parse_view_bbs {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
# get topic, comments part
my $topic_from = qq(\Q<!-- TOPIC: start -->\E);
my $topic_till = qq(\Q<!-- TOPIC: end -->\E);
my $comments_from = qq(\Q<table width="630" border="0" cellspacing="1" cellpadding="3">\E);
my $comments_till = qq(\Q<table width="630" border="0" cellspacing="1" cellpadding="0" bgcolor="#d3b16d">\E);
my $content_topic = ($content =~ /${topic_from}(.*?)${topic_till}/s) ? $1 : return $self->log("[warn] topic part is missing.\n");
my $content_comments = ($content =~ /${comments_from}(.*?)${comments_till}/s) ? $1 : return $self->log("[warn] comments part is missing.\n");
# regex for parsing
my $re_subj = '<td width="595"[^<>]*><b>(.*?)<\/b><\/td>';
my $re_time = '<td [^<>]* nowrap>\s*(\d{4})ǯ(\d{2})·î(\d{2})Æü\s*<br>\s*(\d{1,2}):(\d{2})';
my $re_link = '<td bgcolor="#fdf9f2">.*?<a href="?(.+?)"?>(.*?)<\/a>';
my $re_imgs = '<td bgcolor="#ffffff" align="center">\s*(<table>.*?<\/table>)?';
my $re_desc = '<td bgcolor="#ffffff" align="center">\s*(?:<table>.*?<\/table>)?(.*?)<\/td>';
# parse topic
my $subj = ($content_topic =~ /$re_subj/) ? $1 : return $self->log("[warn] subject is not found.\n$content_topic");
my $time = ($content_topic =~ /$re_time/) ? sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5) : return $self->log("[warn] time is not found.\n$content_topic");
my $link = ($content_topic =~ /$re_link/) ? $1 : return $self->log("[warn] link is not found.\n$content_topic");
my $name = $2;
my $imgs = ($content_topic =~ /$re_imgs/s) ? $1 : return $self->log("[warn] imgs are not found.\n$content_topic");
my $desc = ($content_topic =~ /$re_desc/s) ? $1 : return $self->log("[warn] description is not found.\n$content_topic");
($name, $desc) = map { s/[\r\n]+//g; s/<br>/\n/g; $_ = $self->rewrite($_); $_; } ($name, $desc);
my $item = { 'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $res->request->uri->as_string, 'images' => [], 'comments' => [] , 'name' => $name, 'name_link' => $self->absolute_url($link, $base)};
my @images = ($imgs =~ /<a href="javascript:void(0)" [^<>]*>.*?<\/a>/gs);
foreach my $image (@images) {
# parse images
next unless ($image =~ /<a [^<>]*'show_picture.pl\?img_src=(.*?)'[^<>]*><img src=([^ ]*) border=0>/);
push(@{$item->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)});
}
# parse comments
my @comments = ($content_comments =~ /<tr valign="top">(.*?)\n<\/table>\n<\/td>\n<\/tr>/gs);
foreach my $comment (@comments) {
unless ($comment =~ /$re_time/) { $self->log("[warn] time is not found in comment.\n$comment"); next; }
my $time = sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5);
unless ($comment =~ /$re_link/s) { $self->log("[warn] link is not found in comment.\n$comment"); next; }
my $link = $1;
my $name = $2;
unless ($comment =~ /$re_imgs/s) { $self->log("[warn] imgs are not found in comment.\n$comment"); next; }
my $imgs = $1;
unless ($comment =~ /$re_desc/s) { $self->log("[warn] desc is not found in comment.\n$comment"); next; }
my $desc = $1;
($name, $desc) = map { s/[\r\n]+//g; s/<br>/\n/g; $_ = $self->rewrite($_); $_; } ($name, $desc);
my $comment = {'time' => $time, 'link' => $self->absolute_url($link, $base), 'name' => $name, 'description' => $desc, 'images' => []};
my @images = ($imgs =~ /<a href="javascript:void(0)" [^<>]*>.*?<\/a>/g);
foreach my $image (@images) {
# parse images
next unless ($image =~ /<a [^<>]*'show_picture.pl\?img_src=(.*?)'[^<>]*><img src=([^ ]*) border=0>/);
push(@{$comment->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)});
}
push(@{$item->{'comments'}}, $comment);
}
push(@items, $item);
return @items;
}
sub parse_view_diary {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my $item = undef;
my $re_date = qr/(\d{4})ǯ(\d{1,2})·î(\d{1,2})Æü.*?(\d{1,2}):(\d{1,2})/is;
# diary
my $diary_from = qq(\Q<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=540 BGCOLOR=#F8A448>\E);
my $diary_till = qq(\Q<a name=comment></a>\E);
return $self->log("[warn] diary part is missing.\n") unless ($content =~ /$diary_from(.*?)$diary_till/s);
my $diary_part = $1;
{
# get and parse diary title part
my $re_part = qr/<tr Valign="?top"?>(.*?)<\/tr>/is;
my $re_cols = qr/<td\b[^<>]*>(.*?)<\/td>\s*<td\b[^<>]*>(.*?)<\/td>/is;
my ($level_part, $subj_part) = ($diary_part =~ /^(.*)$re_part/is) ? ($1, $2) : return $self->log("[warn] subj part is not found in content.\n$diary_part");
my ($time, $subj) = ($subj_part =~ $re_cols) ? ($1, $2) : return $self->log("[warn] time and/or subj are not found in subj part.\n$subj_part");
$time = ($time =~ $re_date) ? sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5) : $self->log("[warn] time is not matches regex.\n$time");
$subj =~ s/^ //;
$subj = $self->rewrite($subj);
my $level = undef;
my $raw_img = ($level_part =~ /(<img\b[^<>]*alt=[^<>]*>)/) ? $1 : $self->log("[warn] open level is not found in level part.\n$level_part");
my $img = $self->parse_standard_tag($raw_img);
$level = { 'description' => $self->rewrite($img->{'attr'}->{'alt'}), 'link' => $self->absolute_url($img->{'attr'}->{'src'}, $base), 'raw' => $raw_img };
$item = { 'subject' => $subj, 'link' => $res->request->uri->as_string, 'time' => $time, 'level' => $level };
}
# parse diary description part
{
my $re_part = "<table BORDER=\"?0\"? CELLSPACING=\"?0\"? CELLPADDING=\"?3\"? WIDTH=\"?410\"?>(.*?)\n\Q</table>\E\n";
my $re_desc = "<td class=\"?h12\"? width=\"410\">(.+?)<\/td>";
my $re_imgs = "<table><tr>(<td width=\"130\" height=\"140\" align=\"center\" valign=\"middle\">.+?)\s*\Q</tr></table>\E.*?";
my $desc_part = ($content =~ /$re_part/is) ? $1 : return $self->log("[warn] description is not found in content.\n$content");
my ($raw_imgs, $raw_desc) = ($desc_part =~ /(?:$re_imgs)?$re_desc/is) ? ($1, $2) : return $self->log("[warn] desc is not found in desc part.\n$desc_part");
my $desc = $raw_desc;
$desc =~ s/[\r\n]+//g;
$desc =~ s/<br>/\n/g;
while ($desc =~ /(<img\b.*?>)/) {
my $tag = $1;
my $img = $self->parse_standard_tag($1);
$img = ($img) ? "[²èÁü] " . $self->absolute_url($img->{'attr'}->{'src'}, $base) . " " : "";
$desc =~ s/\Q$tag\E/\Q$img\E/g;
}
$item->{'raw_description'} = $raw_desc;
$item->{'description'} = $self->rewrite($desc);
$item->{'images'} = [];
foreach my $image ($raw_imgs =~ /<td\b[^<>]*>(.*?)<\/td>/g) {
next unless ($image =~ /<a [^<>]*'(show_diary_picture.pl\?.*?)'[^<>]*><img src="?([^ ]*)"?\b.*?>/);
push(@{$item->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)});
}
}
# get and parse diary comment part
my $comment_from = qq(\Q<a name=comment></a>\E);
my $comment_till = qq(\Q<img src=http://img.mixi.jp/img/q_brown3.gif WIDTH=7 HEIGHT=7>\E);
return $self->log("[warn] comment part is missing.\n") unless ($content =~ /$comment_from(.*?)$comment_till/s);
my $comment_part = $1;
$item->{'comments'} = [];
{
my $comm_from = qq(\Q<td rowspan="2" align="center" width="95" bgcolor="#f2ddb7" nowrap>\E);
my $desc_from = "\Q<td CLASS=h12>\E[\r\n]?";
my $desc_till = "\Q</td>\E";
foreach my $comment ($comment_part =~ /$comm_from(.*?${desc_from}.*?${desc_till})/gis) {
my ($header, $raw_desc) = ($comment =~ /^(.*)${desc_from}(.*?)${desc_till}/gis) ? ($1, $2) : return $self->log("[warn] description is not found in comment.\n$comment");
my $desc = $raw_desc;
$desc =~ s/[\r\n]+//g;
$desc =~ s/<br>/\n/g;
my $time = ($header =~ $re_date) ? sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4) : return $self->log("[warn] time is not found in comment header.\n$header");
my ($link, $name) = ($header =~ /<a href="(show_friend.pl\?id=[0-9]+)">(.*)<\/a>/) ? ($1, $2) : return $self->log("[warn] name and link are not found in comment header.\n$header");
push(@{$item->{'comments'}}, {
'time' => $time, 'link' => $self->absolute_url($link, $base), 'name' => $self->rewrite($name),
'description' => $self->rewrite($desc), 'raw_description' => $raw_desc
});
}
}
return ($item);
}
sub parse_view_event {
my $self = shift;
my ($res, $content, $url, $base) = $self->parse_parser_params(@_);
return unless ($res and $res->is_success);
my @items = ();
# get event, pages, comments part
my $event_from = "\Q<!--///// ¥È¥Ô¥Ã¥¯¤³¤³¤«¤é /////-->\E";
my $content_event = ($content =~ /$event_from(.*?)\Q<!-- TOPIC: end -->\E/s) ? $1 : return $self->log("[warn] event part is missing.\n");
my $content_pages = ($content =~ /\Q<!-- COMMENT: start -->\E(.*?)\Q<!-- start : Loop -->\E/s) ? $1 : '';
my $content_comments = ($content =~ /\Q<!-- start : Loop -->\E(.*?)\Q<!-- end : Loop -->\E/s) ? $1 : '';
# make regex for table parsing
my $attr = qr/\s+(?:"[^""]*"|'[^'']*'|[^<>]+)?/;
my ($table, $tr, $td) = (qr/table(?:$attr)*/, qr/tr(?:$attr)*/, qr/td(?:$attr)*/);
my $char = qr/(?!<\/?(?:table|th|tr|td)(?:$attr)*>)[\s\S]/;
my $str = qr/(?:$char)*/;
my $s = qr/(?:\s+|\Q \E)*/;
# parse event
my $item = {};
my $time = sprintf('%04d/%02d/%02d %02d:%02d', $2, $3, $4, $5, $6) if ($content_event =~ /(<$td>$s(\d{4})ǯ(\d{2})·î(\d{2})Æü$str(\d{1,2}):(\d{2})$s<\/$td>)/is);
my @images = ($1, $2, $3) if ($content_event =~ /$1$s<$td>$s<$table>$s<$tr>$s<$td>($str)<\/$td>(?:$s<$td>($str)<\/$td>(?:$s<$td>($str)<\/$td>)?)?$s<\/$tr>$s<\/$table>$s<\/$td>$s<\/$tr>/is);
my $subj = $1 if ($content_event =~ /<$td>$s\Q¥¿¥¤¥È¥ë\E$s<\/$td>$s<$td>$s($str)<\/$td>/is);
return $self->log("[warn] Can't parse event time.\n") unless(defined($time));
return $self->log("[warn] Can't parse event title.\n") unless(defined($subj));
my $name = $1 if ($content_event =~ /<$td>$s\Q´ë²è¼Ô\E$s<\/$td>$s<$td>$s($str)<\/$td>/is);
my $date = $1 if ($content_event =~ /<$td>$s\Q³«ºÅÆü»þ\E$s<\/$td>$s<$td>$s($str)<\/$td>/is);
my $loca = $1 if ($content_event =~ /<$td>$s\Q³«ºÅ¾ì½ê\E$s<\/$td>$s<$td>$s($str)<\/$td>/is);
my $comm = $1 if ($content_event =~ /<$td>$s\Q´ØÏ¢¥³¥ß¥å¥Ë¥Æ¥£\E$s<\/$td>$s<$td>$s($str)<\/$td>/is);
my $desc = $1 if ($content_event =~ /<$td>$s\Q¾ÜºÙ\E$s<\/$td>$s<$td><$table>$s<$tr>$s<$td>($str)<\/$td>$s<\/$tr>$s<\/$table>$s<\/$td>/is);
my $limit = $1 if ($content_event =~ /<$td>$s\QÊ罸´ü¸Â\E$s<\/$td>$s<$td>$s($str)<\/$td>/is);
my ($count, $list) = ($1, $2) if ($content_event =~ /<$td>$s\Q»²²Ã¼Ô\E$s<\/$td>$s<$td>$s<$table>$s<$tr>$s<$td>$s($str)<\/$td>$s<$td>$s($str)<\/$td>/is);
my $join = $1 if ($content_event =~ /<form(?:$attr)*>$s<$tr>$s<$td>$s<input(?:$attr)*VALUE="([^""]*)"(?:$attr)*>$s<\/$td>$s<\/$tr>$s<\/form>/is);
$join = ($join eq '¡¡¥¤¥Ù¥ó¥È¤Ë»²²Ã¤¹¤ë¡¡') ? 1 : ($join eq "¡¡»²²Ã¤ò¥¥ã¥ó¥»¥ë¤¹¤ë¡¡") ? 2 : 0;
($comm, my $comm_link) = ($comm =~ /<a(?:$attr)*href=["']?([^"'<> ]*)["'](?:$attr)*>(.*?)<\/a>/is) ? ($2, $self->absolute_url($1, $base)) : (undef, undef);
($list, my $list_link) = ($list =~ /<a(?:$attr)*href=["']?([^"'<> ]*)["'](?:$attr)*>(.*?)<\/a>/is) ? ($2, $self->absolute_url($1, $base)) : (undef, undef);
($name, my $name_link) = ($name =~ /<a(?:$attr)*href=["']?([^"'<> ]*)["'](?:$attr)*>(.*?)<\/a>/is) ? ($2, $self->absolute_url($1, $base)) : (undef, undef);
($subj, $desc, $date, $loca) = map { s/[\r\n]+//g; s/<br>/\n/g; $_ = $self->rewrite($_); } ($subj, $desc, $date, $loca);
$item = {
'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $url, 'name' => $name, 'name_link' => $name_link,
'date' => $date, 'location' => $loca, 'deadline' => $limit, 'join' => $join,
'images' => [], 'comments' => [], 'pages' => [],
'list' => { 'subject' => $list, 'link' => $list_link, 'count' => $count },
'community' => { 'name' => $comm, 'link' => $comm_link },
};
foreach my $image (@images) {
next unless ($image and $image =~ /<a(?:$attr)*onClick="MM_openBrWindow\('([^']*?)'.*?\)[^""]*"(?:$attr)*>$s<img(?:$attr)*src=["']?([^"'\s]*)["']?(?:$attr)*>/);
push(@{$item->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)});
}
# parse pages
if ($content_pages and $content_pages =~ /(.*\QÁ´¤Æ¤òɽ¼¨\E.*)\Q [\E(.*?)\Q] \E(.*\QºÇ¿·¤Î10·ï¤òɽ¼¨\E.*)/) {
my @pages = ($1, $2, $3);
splice(@pages, 1, 1, ($pages[1] =~ /(<a(?:$attr)*>.*?<\/a>|\d+)/gi));
foreach my $page (@pages) {
if ($page =~ /<a(?:$attr)*href=["']?([^"'<>]*)["']?(?:$attr)*>(.*?)<\/a>/) {
push(@{$item->{'pages'}}, { 'current' => 0, 'link' => $self->absolute_url($1, $base), 'subject' => $2});
} else {
push(@{$item->{'pages'}}, { 'current' => 1, 'link' => $url, 'subject' => $page});
}
}
}
# parse comments
if ($content_comments) {
my @comments = split(/<td(?:$attr)*rowspan=2(?:$attr)*>/i, $content_comments);
foreach my $comment (@comments) {
next unless ($comment =~ /
^$s(\d{4})ǯ(\d{2})·î(\d{2})Æü$str(\d{1,2}):(\d{2})$str<\/$td>$s
<$td>$str<b>$s(\d+)$s<\/b>$s:($str)<\/$td>$s<\/$tr>
/isx);
my $time = sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5);
my ($subj, $name) = ($6, $7);
my @images = ($1, $2, $3) if ($comment =~ s/<$table>$s<$tr>$s<$td>($str<img(?:$attr)*>$str)<\/$td>(?:$s<$td>($str<img(?:$attr)*>$str)<\/$td>)?(?:$s<$td>($str<img(?:$attr)*>$str)<\/$td>)?$s<\/tr><\/table>//is);
my $desc = $self->rewrite($1) if ($comment =~ /<$tr>$s<$td>$s<$table>$s<$tr>$s<$td>($str)<\/$td>$s<\/$tr>$s<\/$table>$s<\/$td>$s<\/$tr>/is);
@images = grep { $_ } map {
($_ and /<a(?:$attr)*onClick="MM_openBrWindow\('([^']*?)'.*?\)[^""]*"(?:$attr)*>$s<img(?:$attr)*src=["']?([^"'\s]*)["']?.*?>/)
? {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)} : undef
} @images;
($name, my $link) = ($name =~ /<a(?:$attr)*href=["']?([^"'<> ]*)["'](?:$attr)*>(.*?)<\/a>/is) ? ($2, $self->absolute_url($1, $base)) : (undef, undef);
push(@{$item->{'comments'}}, {'subject' => $subj, 'name' => $name, 'link' => $link, 'time' => $time, 'description' => $desc, 'images' => [@images]});
}
}
push(@items, $item);
return @items;
}
sub parse_view_message {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->request->uri->as_string;
my $content = $res->content;
# make regex for table parsing
my $attr = qr/\s+(?:"[^""]*"|'[^'']*'|[^<>]+)?/;
my ($table, $tr, $td) = (qr/table(?:$attr)*/, qr/tr(?:$attr)*/, qr/td(?:$attr)*/);
my $char = qr/(?!<\/?(?:table|th|tr|td)(?:$attr)*>)[\s\S]/;
my $str = qr/(?:$char)*/;
my $s = qr/(?:\s+|\Q \E)*/;
# get request list part
my $content_from = "\Q<b>¥á¥Ã¥»¡¼¥¸¤Î¾ÜºÙ</b>\E";
my $content_till = "<[^<>]*\Qhttp://img.mixi.jp/img/q_brown3.gif\E[^<>]*>";
return $self->log("[warn] Detail part is missing.\n") unless ($content =~ /$content_from(.+?)$content_till/s);
$content = $1;
# parse message
my $item = {};
my $label_time = "(?:\QÆü¡¡ÉÕ\E|\QÆü ÉÕ\E)";
my $label_name = "(?:\Qº¹½Ð¿Í\E|\Q°¸ Àè\E)";
my $label_subj = "(?:\Q·ï¡¡Ì¾\E|\Q·ï ̾\E)";
my $time = sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5) if ($content =~ /<$td>$s<font(?:$attr)*>$label_time<\/font>$s:$s(\d{4})ǯ(\d{2})·î(\d{2})Æü$s(\d{2})»þ(\d{2})ʬ$s$s<\/td>/is);
my $subj = $self->rewrite($1) if ($content =~ /<$td>$s<font(?:$attr)*>$label_subj<\/font>$s:$s($str)<\/td>/is);
my $desc = $self->rewrite($1) if ($content =~ /<td(?:$attr)*CLASS=h120(?:$attr)*>$s($str)<\/td>/is);
my $image = $self->absolute_url($1, $base) if ($content =~ /<$td><a(?:$attr)*><img(?:$attr)*src=["']?([^"'\s<>]+)["'](?:$attr)*><\/a><\/td>/is);
my $name = $1 if ($content =~ /<$td>$s<font(?:$attr)*>$label_name<\/font>$s:$s($str)<\/td>/is);
($name, my $link) = ($name =~ /<a(?:$attr)*href=["']?([^"'<> ]*)["'](?:$attr)*>(.*?)(?:<\/a>)?$/is) ? ($self->rewrite($2), $self->absolute_url($1, $base)) : ($self->rewrite($name), undef);
$item = { 'subject' => $subj, 'time' => $time, 'name' => $name, 'link' => $link, 'image' => $image, 'description' => $desc };
return $item;
}
sub parse_view_message_form {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->request->uri->as_string;
my $content = $res->content;
my @items = ();
while ($content =~ s/<form action="(.*?)"[^<>]*>(.*?)<\/form>//s) {
my $action = $1;
my $submit = $2;
$submit = ($submit =~ /<input TYPE=submit VALUE="(.*?)".*?>/) ? $1 : undef;
my $command = $1 if ($action =~ /([^\/\?]+)\.pl(\?[^\/]*)?$/);
my $item = {
'action' => $self->absolute_url($action),
'submit' => $submit,
'command' => $command,
};
push(@items, $item);
}
return @items;
}
sub parse_add_diary_preview {
my $self = shift;
my @items = grep { $_ and $_->{'__action__'} =~ /\Qadd_diary.pl\E/ } $self->parse_standard_form();
return @items;
}
sub parse_add_diary_confirm {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my $succeed = 'ºîÀ®¤¬´°Î»¤·¤Þ¤·¤¿¡£';
if ($content =~ /<table BORDER=0 CELLSPACING=0 CELLPADDING=5>(.*?)<\/form>/s) {
$content = $1;
if (index($content, $succeed) != -1) {
my $link = ($content =~ /<form action="(.*?)">/) ? $self->absolute_url($1, $base) : undef;
my $subj = $self->rewrite($content);
$subj =~ s/[\r\n]+//g;
push(@items, {'subject' => $subj, 'result' => 1, 'link' => $link });
}
}
return @items;
}
sub parse_delete_diary_preview {
my $self = shift;
my @items = grep { $_ and $_->{'__action__'} =~ /\Q_diary.pl\E/ } $self->parse_standard_form();
return @items;
}
sub parse_delete_diary_confirm {
my $self = shift;
return $self->parse_list_diary(@_);
}
sub parse_edit_diary_preview {
my $self = shift;
my @items = grep { $_ and $_->{'__action__'} =~ /\Q_diary.pl\E/ } $self->parse_standard_form();
return @items;
}
sub parse_edit_diary_image {
my $self = shift;
my @items = ();
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
foreach my $photo ($content =~ /<td bgcolor="#f2ddb7">.*?<\/tr>/gs) {
my $subj = ($photo =~ /<font color="#996600">(.*?)<\/td>/) ? $1 : next;
my ($thumb, $link) = ($photo =~ /<img src="([^\n]*?)"><br>\n<a href="([^\n]*?)">ºï½ü<\/a>/) ? ($1, $2) : next;
my $item = {
'subject' => $self->rewrite($subj),
'link' => $self->absolute_url($link, $base),
'thumb_link' => $self->absolute_url($thumb, $base),
};
push(@items, $item);
}
return @items;
}
sub parse_edit_diary_confirm {
my $self = shift;
return $self->parse_list_diary(@_);
}
sub parse_send_message_preview {
my $self = shift;
my @items = grep { $_ and $_->{'__action__'} =~ /\Qsend_message.pl\E/ } $self->parse_standard_form();
return @items;
}
sub parse_send_message_confirm {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my $succeed = '<b>Á÷¿®´°Î»</b>¤·¤Þ¤·¤¿¡£';
if ($content =~ /<tr>[^\n]*?<img src=[^ ]*?\/mail_send.gif WIDTH=25 HEIGHT=28>(.*?)<\/tr>/s) {
$content = $1;
if (index($content, $succeed) != -1) {
my $item = { 'subject' => $self->rewrite($succeed), 'result' => 1 };
if ($content =~ /<a href=(banner.pl\?[^ ]*) class="img"><img src=([^ ]*?) [^<>]*? alt='([^']*)'>/) { #'{
$item->{'banner'} = {
'link' => $self->absolute_url($1, $base),
'image' => $self->absolute_url($2, $base),
'subject' => $self->rewrite($3),
};
}
push(@items, $item)
}
}
return @items;
}
sub parse_list_news_category {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
if ($content =~ /<ul class="menu_news">(.+?)<\/ul>/s) {
while ($content =~ s/<li><a href="(list_news_(category|ranking)\.pl.*?)".*?><img src="http:\/\/img.mixi.jp\/.*?>(.*?)<\/a>.*?<\/li>//is) {
my $item = {};
$item->{'link'} = $self->absolute_url($1, $base);
$item->{'subject'} = $self->rewrite($3);
$item->{'category'} = $self->rewrite($1);
$item->{'category'} = $2 if ($item->{'category'} =~ /\?(id|type)=([A-Za-z0-9]+)/);
push(@items, $item);
}
}
return @items;
}
sub parse_list_news {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
if ($content =~ /<table BORDER=0 CELLSPACING=0 CELLPADDING=3 WIDTH=524>(.+?)<\/table>/s) {
$content = $1;
$content =~ s/\x0D\x0A//g;
$content =~ s/\x0D//g;
$content =~ s/\x0A//g;
while ($content =~ s/<td WIDTH="97%" CLASS="h120"><A HREF="(.*?)".*?>(.*?)<\/A>(.*?)<\/td><td WIDTH="1%" nowrap CLASS="f08"><A HREF="(.*?)".*?>(.*?)<\/A><\/td><td WIDTH="1%" nowrap CLASS="f08">(.*?)<\/td><\/tr>//is) {
my $item = {};
$item->{'link'} = $self->absolute_url($1, $base);
$item->{'subject'} = $self->rewrite($2);
$item->{'media_code'} = $self->absolute_url($4, $base);
$item->{'media_title'} = $self->rewrite($5);
$item->{'time'} = $self->rewrite($6);
$item->{'time'} = $self->rewrite(sprintf('%02d/%02d %02d:%02d', $1, $2, $3, $4)) if ($item->{'time'} =~ /(\d{2})·î(\d{2})Æü (\d{2}):(\d{2})/s);
my $image = $3;
while ($image =~ s/<IMG SRC="(.*?)"\s.*?>//is) {
my $imageurl = $1;
if ($imageurl =~ /news_new/) {
$item->{'new_image'} = $self->rewrite($imageurl);
} elsif ($imageurl =~ /news_camera/) {
$item->{'camera_image'} = $self->rewrite($imageurl);
}
}
push(@items, $item);
}
}
return @items;
}
sub parse_list_news_next {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5>.*?<a href=([^<>]*?list_news_category.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_list_news_previous {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5><a href=([^<>]*?list_news_category.pl[^<>]*?)>([^<>]*?)<\/a>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_list_news_ranking {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
if ($content =~ /<table BORDER=0 CELLSPACING=0 CELLPADDING=3 WIDTH=524>(.+?)<\/table>/s) {
$content = $1;
$content =~ s/\x0D\x0A//g;
$content =~ s/\x0D//g;
$content =~ s/\x0A//g;
while ($content =~ s/<td WIDTH="4%".*?nowrap>(.*?)<\/td><td WIDTH="94%" CLASS="h120"><A HREF="(.*?)".*?>(.*?)<\/A>(.*?)<\/td><td WIDTH="1%" nowrap CLASS="f08"><A HREF="(.*?)".*?>(.*?)<\/A><\/td><td WIDTH="1%" nowrap CLASS="f08">(.*?)<\/td><\/tr>//is) {
my $item = {};
$item->{'count'} = $self->rewrite($1);
$item->{'link'} = $self->absolute_url($2, $base);
$item->{'subject'} = $self->rewrite($3);
$item->{'media_code'} = $self->absolute_url($5, $base);
$item->{'media_title'} = $self->rewrite($6);
$item->{'time'} = $self->rewrite($7);
$item->{'time'} = $self->rewrite(sprintf('%02d/%02d %02d:%02d', $1, $2, $3, $4)) if ($item->{'time'} =~ /(\d{2})·î(\d{2})Æü (\d{2}):(\d{2})/s);
push(@items, $item);
}
}
return @items;
}
sub get_main_menu {
my $self = shift;
my $url = (@_) ? shift : undef;
if ($url) {
$self->set_response($url, @_) or return;
} else {
return unless ($self->response);
return unless ($self->response->is_success);
}
return $self->parse_main_menu();
}
sub get_banner {
my $self = shift;
my $url = (@_) ? shift : undef;
if ($url) {
$self->set_response($url, @_) or return;
} else {
return unless ($self->response);
return unless ($self->response->is_success);
}
return $self->parse_banner();
}
sub get_tool_bar {
my $self = shift;
my $url = (@_) ? shift : undef;
if ($url) {
$self->set_response($url, @_) or return;
} else {
return unless ($self->response);
return unless ($self->response->is_success);
}
return $self->parse_tool_bar();
}
sub get_information { my $self = shift; return $self->get_standard_data('parse_information', 'home.pl', @_); }
sub get_home_new_album { my $self = shift; return $self->get_standard_data('parse_home_new_album', 'home.pl', @_); }
sub get_home_new_bbs { my $self = shift; return $self->get_standard_data('parse_home_new_bbs', 'home.pl', @_); }
sub get_home_new_comment { my $self = shift; return $self->get_standard_data('parse_home_new_comment', 'home.pl', @_); }
sub get_home_new_friend_diary { my $self = shift; return $self->get_standard_data('parse_home_new_friend_diary', 'home.pl', @_); }
sub get_home_new_review { my $self = shift; return $self->get_standard_data('parse_home_new_review', 'home.pl', @_); }
sub get_ajax_new_diary {
my $self = shift;
my $url = 'ajax_new_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'friend_id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'friend_id'}) and length($param{'friend_id'}) and $url !~ /[\?\&]friend_id=/) {
$url .= ($url =~ /\?/) ? "&friend_id=$param{'friend_id'}" : "?friend_id=$param{'friend_id'}";
}
return $self->get_standard_data('parse_ajax_new_diary', qr/ajax_new_diary\.pl/, $url, $refresh);
}
sub get_community_id {
my $self = shift;
return $self->get_standard_data('parse_community_id', qr/view_community\.pl/, @_);
}
sub get_edit_member {
my $self = shift;
my $url = 'edit_member.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if ($url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}" if (defined($param{'id'}) and length($param{'id'}));
$url .= ($url =~ /\?/) ? "&page=$param{'page'}" : "?id=$param{'page'}" if (defined($param{'page'}) and length($param{'page'}));
}
return $self->get_standard_data('parse_edit_member', qr/edit_member\.pl/, $url, $refresh);
}
sub get_edit_member_pages {
my $self = shift;
my $url = 'edit_member.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if ($url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}" if (defined($param{'id'}) and length($param{'id'}));
$url .= ($url =~ /\?/) ? "&page=$param{'page'}" : "?id=$param{'page'}" if (defined($param{'page'}) and length($param{'page'}));
}
return $self->get_standard_data('parse_edit_member_pages', qr/edit_member\.pl/, $url, $refresh);
}
sub get_list_bbs {
my $self = shift;
my $url = 'list_bbs.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}";
}
return $self->get_standard_data('parse_list_bbs', qr/list_bbs\.pl/, $url, $refresh);
}
sub get_list_bbs_next {
my $self = shift;
my $url = 'list_bbs.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}";
}
$self->set_response($url, $refresh) or return;
return $self->parse_list_bbs_next();
}
sub get_list_bbs_previous {
my $self = shift;
my $url = 'list_bbs.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}";
}
$self->set_response($url, $refresh) or return;
return $self->parse_list_bbs_previous();
}
sub get_list_bookmark {
my $self = shift;
my $url = 'list_bookmark.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_bookmark();
}
sub get_list_comment {
my $self = shift;
my $url = 'list_comment.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_comment();
}
sub get_list_community {
my $self = shift;
my $url = 'list_community.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_community();
}
sub get_list_community_next {
my $self = shift;
my $url = 'list_community.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_community_next();
}
sub get_list_community_previous {
my $self = shift;
my $url = 'list_community.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_community_previous();
}
sub get_list_diary {
my $self = shift;
my $url = 'list_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_diary();
}
sub get_list_diary_capacity {
my $self = shift;
my $url = 'list_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_diary_capacity();
}
sub get_list_diary_next {
my $self = shift;
my $url = 'list_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_diary_next();
}
sub get_list_diary_previous {
my $self = shift;
my $url = 'list_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_diary_previous();
}
sub get_list_diary_monthly_menu {
my $self = shift;
my $url = 'list_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_diary_monthly_menu();
}
sub get_list_friend {
my $self = shift;
my $url = 'list_friend.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_friend();
}
sub get_list_friend_next {
my $self = shift;
my $url = 'list_friend.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_friend_next();
}
sub get_list_friend_previous {
my $self = shift;
my $url = 'list_friend.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_friend_previous();
}
sub get_list_member {
my $self = shift;
my $url = 'list_member.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}";
}
return $self->get_standard_data('parse_list_member', qr/list_member\.pl/, $url, $refresh);
}
sub get_list_member_next {
my $self = shift;
my $url = 'list_member.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}";
}
$self->set_response($url, $refresh) or return;
return $self->parse_list_member_next();
}
sub get_list_member_previous {
my $self = shift;
my $url = 'list_member.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}";
}
$self->set_response($url, $refresh) or return;
return $self->parse_list_member_previous();
}
sub get_list_message {
my $self = shift;
my $url = 'list_message.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_message();
}
sub get_list_outbox {
my $self = shift;
my $url = 'list_message.pl?box=outbox';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_outbox();
}
sub get_list_request {
my $self = shift;
my $url = 'list_request.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_list_request();
}
sub get_new_album {
my $self = shift;
my $url = 'new_album.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_new_album();
}
sub get_new_bbs {
my $self = shift;
my $url = 'new_bbs.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_new_bbs();
}
sub get_new_bbs_next {
my $self = shift;
my $url = 'new_bbs.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_new_bbs_next();
}
sub get_new_bbs_previous {
my $self = shift;
my $url = 'new_bbs.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_new_bbs_previous();
}
sub get_new_comment {
my $self = shift;
my $url = 'new_comment.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_new_comment();
}
sub get_new_friend_diary {
my $self = shift;
my $url = 'new_friend_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_new_friend_diary();
}
sub get_new_friend_diary_next {
my $self = shift;
my $url = 'new_friend_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_new_friend_diary_next();
}
sub get_new_friend_diary_previous {
my $self = shift;
my $url = 'new_friend_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_new_friend_diary_previous();
}
sub get_new_review {
my $self = shift;
my $url = 'new_review.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_new_review();
}
sub get_release_info {
my $self = shift;
my $url = 'release_info.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_release_info();
}
sub get_self_id {
my $self = shift;
$self->login unless ($self->is_logined);
return $self->parse_self_id();
}
sub get_search_diary {
my $self = shift;
my $url = 'search_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'keyword');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'keyword'}) and length($param{'keyword'}) and $url !~ /[\?\&]keyword=/) {
$param{'keyword'} =~ s/([^\w ])/'%' . unpack('H2', $1)/eg;
$param{'keyword'} =~ tr/ /+/;
$url .= ($url =~ /\?/) ? "&keyword=$param{'keyword'}" : "?keyword=$param{'keyword'}";
}
@_ = grep { defined($_) } ($url, $refresh);
$self->set_response(@_) or return;
return $self->parse_search_diary();
}
sub get_search_diary_next {
my $self = shift;
my $url = 'search_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'keyword');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'keyword'}) and length($param{'keyword'}) and $url !~ /[\?\&]keyword=/) {
$param{'keyword'} =~ s/([^\w ])/'%' . unpack('H2', $1)/eg;
$param{'keyword'} =~ tr/ /+/;
$url .= ($url =~ /\?/) ? "&keyword=$param{'keyword'}" : "?keyword=$param{'keyword'}";
}
$self->set_response($url, $refresh) or return;
return $self->parse_search_diary_next();
}
sub get_search_diary_previous {
my $self = shift;
my $url = 'search_diary.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'keyword');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'keyword'}) and length($param{'keyword'}) and $url !~ /[\?\&]keyword=/) {
$param{'keyword'} =~ s/([^\w ])/'%' . unpack('H2', $1)/eg;
$param{'keyword'} =~ tr/ /+/;
$url .= ($url =~ /\?/) ? "&keyword=$param{'keyword'}" : "?keyword=$param{'keyword'}";
}
$self->set_response($url, $refresh) or return;
return $self->parse_search_diary_previous();
}
sub get_show_calendar {
my $self = shift;
my $url = 'show_calendar.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_show_calendar();
}
sub get_show_calendar_term {
my $self = shift;
my $url = 'show_calendar.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_show_calendar_term();
}
sub get_show_calendar_next {
my $self = shift;
my $url = 'show_calendar.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_show_calendar_next();
}
sub get_show_calendar_previous {
my $self = shift;
my $url = 'show_calendar.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_show_calendar_previous();
}
sub get_show_intro {
my $self = shift;
my $url = 'show_intro.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_show_intro();
}
sub get_show_log {
my $self = shift;
my $url = 'show_log.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_show_log();
}
sub get_show_log_count {
my $self = shift;
my $url = 'show_log.pl';
$url = shift if (@_ and $_[0] ne 'refresh');
$self->set_response($url, @_) or return;
return $self->parse_show_log_count();
}
sub get_show_friend_outline {
my $self = shift;
my $url = shift or return undef;
$self->set_response($url, @_) or return undef;
return $self->parse_show_friend_outline();
}
sub get_show_friend_profile {
my $self = shift;
my $url = shift or return undef;
$self->set_response($url, @_) or return undef;
return $self->parse_show_friend_profile();
}
sub get_view_album {
my $self = shift;
my $url = 'view_album.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}";
}
return $self->get_standard_data('parse_view_album', qr/view_album\.pl/, $url, $refresh);
}
sub get_view_album_comment {
my $self = shift;
my $url = 'view_album.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}&mode=comment";
}
return $self->get_standard_data('parse_view_album_comment', qr/view_album\.pl/, $url, $refresh);
}
sub get_view_album_photo {
my $self = shift;
my $url = 'view_album.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}";
}
return $self->get_standard_data('parse_view_album_photo', qr/view_album\.pl/, $url, $refresh);
}
sub get_view_bbs {
my $self = shift;
my $url = shift or return;
$self->set_response($url, @_) or return undef;
return $self->parse_view_bbs();
}
sub get_view_community {
my $self = shift;
my $url = 'view_community.pl';
$url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id');
my $refresh = shift if (@_ and $_[0] eq 'refresh');
my %param = @_;
if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) {
$url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}";
}
return $self->get_standard_data('parse_view_community', qr/view_community\.pl/, $url, $refresh);
}
sub get_view_diary {
my $self = shift;
my $url = shift or return;
$self->set_response($url, @_) or return undef;
return $self->parse_view_diary();
}
sub get_view_event {
my $self = shift;
my $url = shift or return;
$self->set_response($url, @_) or return undef;
return $self->parse_view_event();
}
sub get_view_message {
my $self = shift;
my $url = shift or return undef;
$self->set_response($url, @_) or return undef;
return $self->parse_view_message();
}
sub get_view_message_form {
my $self = shift;
my $url = shift or return;
$self->set_response($url, @_) or return;
return $self->parse_view_message_form();
}
sub get_add_diary_preview {
my $self = shift;
my %form = @_;
$form{'submit'} = 'main';
my $response = $self->post_add_diary(%form);
return if ($@ or not $response);
return $self->parse_add_diary_preview();
}
sub get_add_diary_confirm {
my $self = shift;
my %form = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
my $url = 'add_diary.pl';
my @files = qw(photo1 photo2 photo3);
# POST¥¡¼Ì¤¼èÆÀ¡¢¤Þ¤¿¤Ï¼Ì¿¿¤¬¤¢¤ì¤Ð¥×¥ì¥Ó¥å¡¼Åê¹Æ
if (not $form{'post_key'} or grep { $form{$_} } @files) {
my @forms = grep {$_->{'submit'} eq 'confirm'} $self->get_add_diary_preview(%form);
return 0 if ($self->response->is_error);
return 0 unless (@forms);
%form = %{$forms[0]};
$self->log("[info] ¥×¥ì¥Ó¥å¡¼¥Ú¡¼¥¸¤ò¼èÆÀ¤·¤Þ¤·¤¿¡£\n");
$self->dumper_log(\%form);
}
# Åê¹Æ
$form{'submit'} = 'confirm';
$self->post_add_diary(%form) or return;
return $self->parse_add_diary_confirm();
}
sub get_delete_diary_preview {
my $self = shift;
my %form = @_;
$self->post_delete_diary(%form) or return;
return $self->parse_delete_diary_preview();
}
sub get_delete_diary_confirm {
my $self = shift;
my %form = @_;
# Åê¹Æ
$form{'submit'} = 'confirm';
$self->post_delete_diary(%form) or return;
return $self->parse_delete_diary_confirm();
}
sub get_edit_diary_preview {
my $self = shift;
my $url = shift or return undef;
$url =~ s/view_diary.pl\?(?:.*&)?(id=\d+).*?$/edit_diary.pl?$1/;
$self->set_response($url, @_) or return undef;
return $self->parse_edit_diary_preview();
}
sub get_edit_diary_image {
my $self = shift;
my $url = shift or return undef;
$self->set_response($url, @_) or return undef;
return $self->parse_edit_diary_image();
}
sub get_edit_diary_confirm {
my $self = shift;
my %form = @_;
# Åê¹Æ
$form{'submit'} = 'main';
$self->post_edit_diary(%form) or return;
return $self->parse_edit_diary_confirm();
}
sub get_send_message_preview {
my $self = shift;
my %form = @_;
$form{'submit'} = 'main';
$self->post_send_message(%form) or return;
return $self->parse_send_message_preview();
}
sub get_send_message_confirm {
my $self = shift;
my %form = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
$form{'submit'} = 'confirm';
$form{'yes'} = '¡¡Á÷¡¡¿®¡¡' unless ($form{'yes'});
#post key̤¼èÆÀ¤Ê¤é¥×¥ì¥Ó¥å¡¼Åê¹Æ
if (not $form{'post_key'} or not $form{'yes'}) {
my @forms = grep {$_->{'submit'} eq 'confirm'} $self->get_send_message_preview(%form);
return 0 if ($self->response->is_error);
return 0 unless (@forms);
%form = %{$forms[0]};
$self->log("[info] ¥×¥ì¥Ó¥å¡¼¥Ú¡¼¥¸¤ò¼èÆÀ¤·¤Þ¤·¤¿¡£\n");
$self->dumper_log(\%form);
}
# Á÷¿®
$self->post_send_message(%form) or return;
return $self->parse_send_message_confirm();
}
sub parse_parser_params {
my $self = shift;
my @params = @_;
my $response = undef;
my $content = undef;
foreach my $param (@params) {
if (UNIVERSAL::isa($param, 'HTTP::Response')) {
$response = $param;
} elsif (not ref($param)) { # File or Content
if ($param !~ /\t\r\n/ and -f $param) {
if (open(IN, $param)) { # Slurp file
local $/;
$content = <IN>;
close(IN);
}
} else {
$content = $param;
}
}
}
$response = ($content or not $self->response) ? HTTP::Response->new(200) : $self->response unless ($response);
$response->content($content) if ($content);
$content = $response->content if (not $content);
my $base = eval { $response->base->as_string } || 'http://mixi.jp/';
my $url = eval { $response->request->uri->as_string };
return ($response, $content, $url, $base);
}
sub absolute_url {
my $self = shift;
my $url = shift;
my $base = (@_) ? shift : $self->{'mixi'}->{'base'};
return undef unless (length($url));
$url =~ s/(^["']*|['"]*$)//g;
$url .= '.pl' if ($url and $url !~ /[\/\.]/);
return URI->new($url)->abs($base)->as_string;
}
sub absolute_linked_url {
my $self = shift;
my $url = shift;
return $url unless ($url and $self->response());
my $base = $self->response->base->as_string;
return $self->absolute_url($url, $base);
}
sub query_sorted_url {
my $self = shift;
my $url = shift;
return undef unless ($url);
if ($url =~ s/\?(.*)$//) {
my $qurey_string = join('&', map {join('=', @{$_})}
map { $_->[1] =~ s/%20/+/g if @{$_} == 2; $_; }
sort {$a->[0] cmp $b->[0]}
map {[split(/=/, $_, 2)]} split(/&/, $1));
$url = "$url?$qurey_string";
}
return $url;
}
sub enable_cookies {
my $self = shift;
unless ($self->cookie_jar) {
my $cookie = sprintf('cookie_%s_%s.txt', $$, time);
$self->cookie_jar(HTTP::Cookies->new(file => $cookie, ignore_discard => 1));
$self->log("[info] Cookie¤ò͸ú¤Ë¤·¤Þ¤·¤¿¡£\n");
}
return $self;
}
sub save_cookies {
my $self = shift;
my $file = shift;
my $info = '';
my $result = 0;
if (not $self->cookie_jar) {
$info = "[error] Cookie¤¬Ìµ¸ú¤Ç¤¹¡£\n";
} elsif (not $file) {
$info = "[error] Cookie¤òÊݸ¤¹¤ë¥Õ¥¡¥¤¥ë̾¤¬»ØÄꤵ¤ì¤Þ¤»¤ó¤Ç¤·¤¿¡£\n";
} else {
$info = "[info] Cookie¤ò\"${file}\"¤ËÊݸ¤·¤Þ¤¹¡£\n";
$result = eval "\$self->cookie_jar->save(\$file)";
$info .= "[error] $@\n" if ($@);
}
return $result;
}
sub load_cookies {
my $self = shift;
my $file = shift;
my $info = '';
my $result = 0;
if (not $file){
$info = "[error] Cookie¤òÆɤ߹þ¤à¥Õ¥¡¥¤¥ë̾¤¬»ØÄꤵ¤ì¤Þ¤»¤ó¤Ç¤·¤¿¡£\n";
} elsif (not $file) {
$info = "[error] Cookie¥Õ¥¡¥¤¥ë\"${file}\"¤¬Â¸ºß¤·¤Þ¤»¤ó¡£\n";
} else {
$info = "[info] Cookie¤ò\"${file}\"¤«¤éÆɤ߹þ¤ß¤Þ¤¹¡£\n";
$self->enable_cookies;
$result = eval "\$self->cookie_jar->load(\$file)";
$info .= "[error] $@\n" if ($@);
}
return $result;
}
sub log {
my $self = shift;
my $logger = $self->{'mixi'}->{'log'} or return;
if (ref($logger) eq 'CODE') { &{$logger}($self, @_); }
elsif (ref($logger) eq '' and $logger =~ /^[1-9]\d*$/) { $self->callback_log(@_); }
return;
}
sub callback_log {
my $self = shift;
my @logs = @_;
my $jconv = $self->{'mixi'}->{'ref_convert'};
my $level = (ref($self->{'mixi'}->{'log'}) eq '') ? $self->{'mixi'}->{'log'} : 1;
my $error = 0;
foreach my $log (@logs) {
my $log_level = 0;
if ($log !~ /^(\s|\[.*?\])/) { $log_level = 1; }
elsif ($log =~ /^\[error\]/) { $log_level = 1; $error = 1; }
elsif ($log =~ /^\[usage\]/) { $log_level = 2; }
elsif ($log =~ /^\[warn\]/) { $log_level = 2; }
elsif ($log =~ /^\[info\]/) { $log_level = 3; }
elsif ($log =~ /^\s/) { $log_level = 4; }
else { $log_level = 5; }
if ($log_level and $log_level <= $level) {
$log = $self->jconv_log($log);
print $log;
}
}
$self->abort if ($error);
return;
}
sub jconv_log {
my $self = shift;
my $log = shift;
my $code = $self->{'mixi'}->{'logcode'};
return $log unless ($code);
return $log if ($log =~ /(?:\QCan't use Jcode module\E|\QJcode can't handle\E)/);
# initialize Jcode
if (not exists($self->{'mixi'}->{'ref_convert'})) {
$self->log("[info] Initialize Jcode for logging with '$code'.\n");
eval "use Jcode";
if ($@) { $self->log("[warn] Can't use Jcode module.\n"); }
elsif (not Jcode->can($code)) { $self->log("[warn] Jcode can't handle '$code'.\n"); }
else { $self->{'mixi'}->{'ref_convert'} = Jcode->can('convert'); }
}
return $log if (ref($self->{'mixi'}->{'ref_convert'}) ne 'CODE');
# convert
my $jconv = $self->{'mixi'}->{'ref_convert'};
$log = &{$jconv}($log, $code, 'euc') if ($jconv);
return $log;
}
sub dumper_log {
my $self = shift;
my @logs = @_;
if (not defined($self->{'mixi'}->{'dumper'})) {
$self->log("Data::Dumper¤ò½é´ü²½¤·¤Þ¤¹¡£\n");
eval "use Data::Dumper";
if ($@) {
$self->{'mixi'}->{'dumper'} = 0;
$self->log("[warn] Data::Dumper¤Ï»ÈÍѤǤ¤Þ¤»¤ó : $@\n");
} else {
$self->{'mixi'}->{'dumper'} = Data::Dumper->new([]);
eval { $self->{'mixi'}->{'dumper'}->Indent(1); $self->{'mixi'}->{'dumper'}->Sortkeys(1); };
}
}
if ($self->{'mixi'}->{'dumper'}) {
my $log = $self->{'mixi'}->{'dumper'}->Reset->Values([@logs])->Dump;
$log =~ s/(?:\x0D\x0A?|\x0A)/\n /gs;
$log =~ s/\s*$/\n/s;
return $self->log(" $log");
} else {
@logs = map { s/\s*$/\n/s; s/(?:\x0D\x0A?|\x0A)/\n /gs; $_ = " [dumper] $_"; } @logs;
return $self->log(@logs);
}
}
sub abort {
my $self = shift;
return &{$self->{'mixi'}->{'abort'}}($self, @_);
}
sub callback_abort {
die @_;
}
sub rewrite {
my $self = shift;
return &{$self->{'mixi'}->{'rewrite'}}($self, @_);
}
sub callback_rewrite {
my $self = shift;
my $str = shift;
$str = $self->remove_tag($str);
$str = $self->unescape($str);
$str =~ s/\x0d\x0a?|\x0a/\n/g;
$str =~ s/\s+$//s;
return $str;
}
sub escape {
my $self = shift;
my $str = shift;
my %escaped = ('&' => '&', '"' => '"', '>' => '>', '<' => '<');
my $re_target = join('|', keys(%escaped));
$str =~ s/($re_target)/$escaped{$1}/g;
return $str;
}
sub unescape {
my $self = shift;
my $str = shift;
my %unescaped = ('amp' => '&', 'quot' => '"', 'gt' => '>', 'lt' => '<', 'nbsp' => ' ', 'apos' => "'", 'copy' => '(c)');
my $re_target = join('|', keys(%unescaped));
$str =~ s/&($re_target|#x([0-9a-z]+));/defined($unescaped{$1}) ? $unescaped{$1} : defined($2) ? chr(hex($2)) : "&$1;"/ige;
return $str;
}
sub remove_tag {
my $self = shift;
my $html = shift;
my $text = '';
my $indent = '';
my $blockquote = 0;
my $re_standard_tag = q{[^"'<>]*(?:"[^"]*"[^"'<>]*|'[^']*'[^"'<>]*)*(?:>|(?=<)|$(?!\n))};
my $re_comment_tag = '<!(?:--[^-]*-(?:[^-]+-)*?-(?:[^>-]*(?:-[^>-]+)*?)??)*(?:>|$(?!\n)|--.*$)';
my $re_html_tag = qq{$re_comment_tag|<$re_standard_tag};
while ($html =~ /([^<]*)($re_html_tag)?/gso) {
last if ($1 eq '' and $2 eq '');
my ($tmp_text, $tmp_tag) = ($1, $2);
$tmp_text =~ s/\n/\n$indent/go if ($indent);
$text .= $tmp_text;
if ($tmp_tag =~ /^<(\/?)blockquote[ >]/i) {
$blockquote += ($1) ? -1 : 1;
$indent = ($blockquote > 0) ? '>' x $blockquote . ' ' : '';
$text .= ($1) ? "\n\n" : "\n\n$indent";
}
}
return $text;
}
sub remove_diary_tag {
my $self = shift;
my $str = shift;
my $re_diary_tag = join('|',
q{<a HREF="[^"]*" target="_blank">},
q{<a href="[^"]*" onClick="MM_openBrWindow\([^"]*\)">},
q{<img alt=¼Ì¿¿ src=\S* border=0>},
q{<span (?:class|style)="[^"]*">},
q{<(?:blockquote|u|em|strong)>},
q{<\/(?:a|blockquote|u|em|span|strong)>}
);
$str =~ s/$re_diary_tag//g;
return $str;
}
sub redirect_ok {
return 1;
}
sub get_standard_data {
# default url is pased, so url is not necessary.
my $self = shift;
my $parser = shift;
my $def_url = shift; # defined url
my $url = shift if (@_ and $_[0] ne 'refresh'); # specified url
if (defined($def_url) and ref($def_url) eq 'Regexp') {
return unless (defined($url) and length($url));
return unless ($url =~ $def_url);
} elsif (not (ref($url) eq '' and length($url))) {
$url = $def_url;
}
$self->abort("url \"$url\" is invalid.") unless (defined($url) and length($url)); # invalid url
$self->can($parser) or $self->abort("parser \"$parser\" is not available."); # invalid method
$self->set_response($url, @_) or $self->abort("set_response failed."); # request can not processed
return $self->$parser();
}
sub parse_standard_history {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
my $re_date = '(?:(\d{4})ǯ)?(\d{2})·î(\d{2})Æü (\d{1,2}):(\d{2})';
my $re_link = '<a [^<>]*href="?([^<> ]*?)"?(?: [^<>]*)?>(.*?)<\/a>';
my $re_name = '\(([^<>]*)\)';
my @today = reverse((localtime)[3..5]);
$today[0] += 1900;
$today[1] += 1;
# get standard history part
my $content_from = qq(\Q<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=630>\E);
my $content_till = qq(\Q<\/table>\E);
return $self->log("[warn] standard history part is missing.\n") unless ($content =~ /$content_from(.*?)$content_till/s);
$content = $1;
# parse standard history part
foreach my $row ($content =~ /<tr bgcolor=#FFFFFF>(.*?)<\/tr>/isg) {
$row =~ s/\s*[\r\n]\s*//gs;
my @cols = ($row =~ /<td[^<>]*>(.*?)<\/td>/gs);
my $item = {};
next unless ($cols[0] =~ s/$re_date//);
my @date = ($1, $2, $3, $4, $5);
next unless ($cols[1] =~ /${re_link}\s*$re_name/);
$item->{'link'} = $self->absolute_url($1, $base);
$item->{'subject'} = (defined($2) and length($2)) ? $self->rewrite($2) : '(ºï½ü)';
$item->{'name'} = $self->rewrite($3);
$date[0] = ($date[1] > $today[1]) ? $today[0] - 1 : $today[0] if (not defined($date[0]));
$item->{'time'} = sprintf('%04d/%02d/%02d %02d:%02d', @date);
map { $item->{$_} =~ s/^\s+|\s+$//gs } (keys(%{$item}));
if ($cols[1] =~ /(<a [^>]*>)\s*(<img [^>]*>)\s*<\/a>/is) {
my $image = {};
my @tags = ($1, $2);
if ($_ = $self->parse_standard_tag($tags[0]) and $_->{'attr'}->{'href'} or $_->{'attr'}->{'onclick'}) {
# $_ = ($_->{'attr'}->{'onclick'}) ? $_->{'attr'}->{'onclick'} : $_->{'attr'}->{'href'};
$_ = $_->{'attr'}->{'href'};
$_ = $1 if ($_ =~ /MM_openBrWindow\('(.*?)'/);
$item->{'image'}->{'link'} = $self->absolute_url($_, $base);
}
$item->{'image'}->{'src'} = $self->absolute_url($_, $base) if ($_ = $self->parse_standard_tag($tags[1]) and $_ = $_->{'attr'}->{'src'});
}
push(@items, $item);
}
return @items;
}
sub parse_standard_history_next {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5>[^\r\n]*?<a href=["']?([^>]+?)['"]?>([^<>]+)<\/a><\/td><\/tr>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $next = {'link' => $link, 'subject' => $2};
return $next;
}
sub parse_standard_history_previous {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->request->uri->as_string;
my $content = $res->content;
return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5><a href=["']?(.+?)['"]?>([^<>]+)<\/a>[^\r\n]*?<\/td><\/tr>/);
my $subject = $2;
my $link = $self->absolute_url($1, $base);
my $previous = {'link' => $link, 'subject' => $2};
return $previous;
}
sub parse_standard_form {
my $self = shift;
my $res = (@_) ? shift : $self->response();
return unless ($res and $res->is_success);
my $base = $res->base->as_string;
my $content = $res->content;
my @items = ();
if ($res->is_success and $content =~ /<tr>.*?<img src=["']?http:\/\/[^<> ]*\/alt.gif['" ].*?>(.*?)<\/tr>/s) {
my $message = $1;
$message =~ s/\n//g;
$message =~ s/<br>|<br ?\/>|<\/br>/\n/g;
$res->code(400);
$res->message($self->rewrite($message));
return;
}
while ($content =~ s/(<form (?:"[^"]*"|'[^']*'|[^'"<>]*)*>)(.*?)<\/form>//is) {
my $tag = $1;
my $form = $2;
my $action = ($tag =~ /\baction=("[^"]*"|'[^']*'|[^'"<> ]*)/) ? $1 : "";
$action =~ s/^"(.*)"$/$1/s or $action =~ s/^'(.*)'$/$1/s;
my $item = {'__action__' => $self->absolute_url($action, $base)};
foreach my $tag ($form =~ /<input (?:"[^"]*"|'[^']*'|[^'"<>]*)*>/g) {
my $name = ($tag =~ /\bname=("[^"]*"|'[^']*'|[^'"<> ]*)/) ? $1 : "";
my $value = ($tag =~ /\bvalue=("[^"]*"|'[^']*'|[^'"<> ]*)/) ? $1 : "";
($name, $value) = map { s/^"(.*)"$/$1/s or s/^'(.*)'$/$1/s; $_ } ($name, $value);
$item->{$name} = $self->rewrite($value) if (length($name));
}
while ($form =~ s/<textarea ((?:"[^"]*"|'[^']*'|[^'"<>]*)*)>(.*?)<\/textarea.*?>//s) {
my ($attrs, $value) = ($1, $2);
my $name = ($attrs =~ /\bname=("[^"]*"|'[^']*'|[^'"<> ]*)/) ? $1 : "";
($name) = map { s/^"(.*)"$/$1/s or s/^'(.*)'$/$1/s; $_ } ($name);
$item->{$name} = $self->rewrite($value) if (length($name));
}
push(@items, $item);
}
return @items;
}
sub parse_standard_tag {
my $self = shift;
my $str = shift;
return undef unless ($str =~ s/^\s*<(.*)>\s*$/$1/s);
return undef if ($str =~ /^\!--/);
my $re_word = q{[^"'<>\s=]+}; #"]}
my $re_quote = q{(?:"[^"]*"|'[^']*')}; #")}
my $re_pair = qq{$re_word\\s*=\\s*(?:$re_quote|$re_word\\((?:[^)]*|$re_quote)*\\)|[^"'<>\\s]+)?};
my $re_parse = qq{$re_pair|$re_word|$re_quote};
my @parsed = ($str =~ /$re_parse/gs);
my $tag = lc(shift(@parsed));
@parsed = map { /^($re_word)\s*=\s*(.*)$/ ? (lc($1) => $2) : (lc($_) => '') } @parsed;
@parsed = map { /^\s*=\s*$/ ? '=' :/^"(.*)"$/ ? $1 : /^'(.*)'$/ ? $1 : $_ } @parsed;
return { 'tag' => $tag, , 'attr' => {@parsed} };
}
sub parse_standard_anchor {
my $self = shift;
my $str = shift;
my $parsed = $self->parse_standard_tag($str);
my $link = undef;
return undef unless ($parsed);
if ($parsed->{'attr'}->{'onclick'}) {
if ($parsed->{'attr'}->{'onclick'} =~ /MM_openBrWindow\(("[^""]*"|'[^'']*'|[^\s\)]*)/) { $link = $1; }
elsif ($parsed->{'attr'}->{'onclick'} =~ /window.opener.location.href=("[^""]*"|'[^'']*'|[^\s\)]*)/i) { $link = $1; }
1 if (defined($link) and ($link =~ s/^"(.*?)"/$1/ or $link =~ s/^'(.*?)'/$1/));
}
$link = $parsed->{'attr'}->{'href'} if (not defined($link));
return $link;
}
sub set_response {
my $self = shift;
my $url = shift;
my $refresh = (@_ and defined($_[0]) and $_[0] eq 'refresh') ? 1 : 0;
my $latest = ($self->response) ? $self->response->request->uri->as_string : undef;
$url = $self->query_sorted_url($self->absolute_url($url));
return 0 unless ($url);
return 1 if ($url eq $latest and not $refresh and $self->response->is_success);
$self->get($url);
return 0 unless ($self->response);
return 0 unless ($self->response->is_success);
return 1;
}
sub post_add_diary {
my $self = shift;
my %values = @_;
my $url = 'add_diary.pl';
my @fields = qw(submit diary_title diary_body photo1 photo2 photo3 orig_size packed post_key id news_id);
my @required = qw(submit diary_title diary_body id);
my @files = qw(photo1 photo2 photo3);
my %label = ('diary_title' => 'Æüµ¤Î¥¿¥¤¥È¥ë', 'diary_body' => 'Æüµ¤ÎËÜʸ', 'photo1' => '¼Ì¿¿1', 'photo2' => '¼Ì¿¿2', 'photo3' => '¼Ì¿¿3', orig_size => '°µ½Ì»ØÄê', packed => 'Á÷¿®¥Ç¡¼¥¿', 'post_key' => 'Á÷¿®¥¡¼', 'id' => 'mixi¥æ¡¼¥¶¡¼ID');
my @errors;
# ¥Ç¡¼¥¿¤ÎÀ¸À®¤È¥Á¥§¥Ã¥¯
my %form = map { $_ => $values{$_} } @fields;
$form{'id'} = $self->parse_self_id;
push @errors, map { "$label{$_}¤ò»ØÄꤷ¤Æ¤¯¤À¤µ¤¤¡£" } grep { not $form{$_} } @required;
if ($form{'submit'} eq 'main') {
# ¥×¥ì¥Ó¥å¡¼ÍѤÎÄɲýèÍý
foreach my $file (@files) {
next unless ($form{$file});
if (not -f $form{$file}) {
push @errors, "[info] $label{$file}¤Î¥Õ¥¡¥¤¥ë\"$form{$file}\"¤¬¤¢¤ê¤Þ¤»¤ó¡£\n" ;
} else {
$form{$file} = [$form{$file}];
}
}
}
if (@errors) {
$self->log(join('', @errors));
return undef;
}
return $self->post($url, %form);
}
sub post_edit_diary {
my $self = shift;
my %values = @_;
$self->dumper_log(\%values);
my $url = exists($values{'__action__'}) ? $values{'__action__'} : 'edit_diary.pl?id=' . $values{'id'};
my @fields = qw(submit diary_title diary_body form_date photo1 photo2 photo3 orig_size post_key);
my @required = qw(submit diary_title diary_body post_key);
my @files = qw(photo1 photo2 photo3);
my %label = ('id' => 'ÆüµID', 'diary_title' => 'Æüµ¤Î¥¿¥¤¥È¥ë', 'diary_body' => 'Æüµ¤ÎËÜʸ', 'photo1' => '¼Ì¿¿1', 'photo2' => '¼Ì¿¿2', 'photo3' => '¼Ì¿¿3', 'post_key' => 'Á÷¿®¥¡¼');
my @errors;
# ¥Ç¡¼¥¿¤ÎÀ¸À®¤È¥Á¥§¥Ã¥¯
my %form = map { $_ => $values{$_} } @fields;
push @errors, "[error] $label{'id'}¤ò»ØÄꤷ¤Æ¤¯¤À¤µ¤¤¡£\n" if ($url !~ /[\?&]id=\d+/);
push @errors, map { "[error] $label{$_}¤ò»ØÄꤷ¤Æ¤¯¤À¤µ¤¤¡£\n" } grep { not $form{$_} } @required;
# ¥Õ¥¡¥¤¥ëÄɲýèÍý
foreach my $file (@files) {
next unless ($form{$file});
if (not -f $form{$file}) {
push @errors, "[info] $label{$file}¤Î¥Õ¥¡¥¤¥ë\"$form{$file}\"¤¬¤¢¤ê¤Þ¤»¤ó¡£\n" ;
} else {
$form{$file} = [$form{$file}];
}
}
if (@errors) {
$self->log(join('', @errors));
return undef;
}
return $self->post($url, %form);
}
sub post_delete_diary {
my $self = shift;
my %values = @_;
my $url = 'delete_diary.pl';
my @fields = qw(submit id post_key);
my @required = qw(id post_key);
my %label = ('id' => 'ÆüµID', 'post_key' => 'Á÷¿®¥¡¼');
# ¥Ç¡¼¥¿¤ÎÀ¸À®¤È¥Á¥§¥Ã¥¯
my %form = map {$_ => $values{$_}} @fields;
$form{'id'} = $1 if ($values{'__action__'} and $values{'__action__'} =~ /delete_diary.pl?id=(\d+)/);
my @errors = map { "$label{$_}¤ò»ØÄꤷ¤Æ¤¯¤À¤µ¤¤¡£" } grep { not $form{$_} } @required;
if (@errors) {
$self->log(map { "[warn] $_\n" } @errors);
return undef;
}
$url .= "?id=" . delete($form{'id'});
return $self->post($url, %form);
}
sub post_send_message {
my $self = shift;
my %values = @_;
my $url = exists($values{'__action__'}) ? $values{'__action__'} : 'send_message.pl?id=' . $values{'id'};
my @fields = qw(submit subject body post_key yes no);
my @required = qw(submit subject body);
my %label = ('id' => '¼õ¿®¼Ô¤ÎID', 'subject' => '¥á¥Ã¥»¡¼¥¸¤Î¥¿¥¤¥È¥ë', 'body' => '¥á¥Ã¥»¡¼¥¸¤ÎËÜʸ', 'post_key' => 'Á÷¿®¥¡¼');
my %form = map { $_ => $values{$_} } @fields;
my @errors = map { "$label{$_}¤ò»ØÄꤷ¤Æ¤¯¤À¤µ¤¤¡£" } grep { not $form{$_} } @required;
push(@errors, "$label{'id'}¤ò»ØÄꤷ¤Æ¤¯¤À¤µ¤¤¡£") if ($url !~ /[\?&]id=\d+/);
if (@errors) {
$self->log(map { "[warn] $_\n" } @errors);
return undef;
}
delete($form{'no'}) if ($form{'yes'} and $form{'no'}); # ¥×¥ì¥Ó¥å¡¼¤ò²òÀϤ¹¤ë¤È'yes'¡¢'no'¤¬Î¾ÊýÆþ¤ë¤¿¤á¡¢Âò°ì
return $self->post($url, %form);
}
sub convert_login_time {
my $self = shift;
my $time = @_ ? shift : 0;
$time =~ s/(^\s+|\s+$)//gs;
if ($time =~ /^\d+$/) { 1; }
elsif ($time =~ /^(\d+)ʬ/) { $time = $1 * 60; }
elsif ($time =~ /^(\d+)»þ´Ö/) { $time = $1 * 60 * 60; }
elsif ($time =~ /^(\d+)Æü/) { $time = $1 * 60 * 60 * 24; }
else { $self->log("[error] ¥í¥°¥¤¥ó»þ¹ï\"$time\"¤ò²òÀϤǤ¤Þ¤»¤ó¤Ç¤·¤¿¡£\n"); }
$time = time() - $time;
my @date = localtime($time);
$time = sprintf('%04d/%02d/%02d %02d:%02d', $date[5] + 1900, $date[4] + 1, $date[3], $date[2], $date[1]);
return $time;
}
sub test {
$| = 1;
my $mail = (@_) ? shift : $ENV{'MIXI_MAIL'};
my $pass = (@_) ? shift : $ENV{'MIXI_PASS'};
my $log = (@_) ? shift : "WWW-Mixi-${VERSION}-test.log";
open(OUT, ">$log");
my $logger = &test_logger;
my $error = undef;
my @items = ();
unless ($mail and $pass) {
&{$logger}("mixi¤Ë¥í¥°¥¤¥ó¤Ç¤¤ë¥á¡¼¥ë¥¢¥É¥ì¥¹¤È¥Ñ¥¹¥ï¡¼¥É¤ò»ØÄꤷ¤Æ¤¯¤À¤µ¤¤¡£\n");
&{$logger}("[usage] perl -MWWW::Mixi -e \"WWW::Mixi::test('mail\@address', 'password');\"\n");
exit 1;
}
my ($result, $response) = ();
# ¥ª¥Ö¥¸¥§¥¯¥È¤ÎÀ¸À®
my $mixi = &test_new($mail, $pass, $logger); # ¥ª¥Ö¥¸¥§¥¯¥È¤ÎÀ¸À®
$mixi->test_login; # ¥í¥°¥¤¥ó
$mixi->test_get; # GET¡Ê¥È¥Ã¥×¥Ú¡¼¥¸¡Ë
$mixi->test_scenario; # ¼çÍץǡ¼¥¿¤Î¼èÆÀ¤È²òÀÏ
$mixi->test_get_add_diary_preview; # Æüµ¤Î¥×¥ì¥Ó¥å¡¼
$mixi->test_save_and_read_cookies; # Cookie¤ÎÆɤ߽ñ¤
# ½ªÎ»
$mixi->log("½ªÎ»¤·¤Þ¤·¤¿¡£\n");
$mixi->dumper_log({'¥Æ¥¹¥È¥ì¥³¡¼¥É' => $mixi->{'__test_record'}, '¥Æ¥¹¥È¥ê¥ó¥¯' => $mixi->{'__test_link'}});
exit 0;
}
sub test_logger {
return sub {
eval "use Jcode";
my $use_jcode = ($@) ? 0 : 1;
my $self = shift if (ref($_[0]));
my @logs = @_;
my $error = 0;
foreach my $log (@logs) {
my $log_level = 0;
if ($log !~ /^(\s|\[.*?\])/) { $log_level = 1; }
elsif ($log =~ /^\[error\]/) { $log_level = 1; $error = 1; }
elsif ($log =~ /^\[usage\]/) { $log_level = 1; }
elsif ($log =~ /^\[warn\]/) { $log_level = 1; }
elsif ($log =~ /^\[info\]/) { $log_level = 1; }
elsif ($log =~ /^\s/) { $log_level = 2; }
else { $log_level = 2; }
if ($log_level) {
eval '$log = jcode($log, "euc")->sjis' if ($use_jcode);
print OUT $log;
print $log if ($log_level <= 1);
}
}
return $self;
};
}
sub test_new {
my ($mail, $pass, $logger) = @_;
my $error = '';
&{$logger}("¥ª¥Ö¥¸¥§¥¯¥È¤òÀ¸À®¤·¤Þ¤¹¡£\n");
my $mixi = eval "WWW::Mixi->new('$mail', '$pass', '-log' => \$logger)";
if ($@) {
$error = "[error] $@\n";
} elsif (not $mixi) {
$error = "[error] ÉÔÌÀ¤Ê¥¨¥é¡¼¤Ç¤¹¡£\n";
} elsif (not $mixi->{'mixi'}) {
$error = "[error] mixi´ØÏ¢¾ðÊó¤òÀßÄê¤Ç¤¤Þ¤»¤ó¤Ç¤·¤¿¡£\n";
}
if ($error) {
&{$logger}({}, "¥ª¥Ö¥¸¥§¥¯¥È¤òÀ¸À®¤Ç¤¤Þ¤»¤ó¤Ç¤·¤¿¡£\n", $error);
exit 8;
}
$mixi->delay(0);
$mixi->env_proxy;
return $mixi;
}
sub test_login {
my $mixi = shift;
my $error = '';
$mixi->log("mixi¤Ë¥í¥°¥¤¥ó¤·¤Þ¤¹¡£\n");
my ($result, $response) = eval '$mixi->login';
if ($@) {
$error = "[error] $@\n";
} elsif (not $result) {
if (not $response->is_success) {
$error = sprintf("[error] %d %s\n", $response->code, $response->message);
$error .= "[info] Web¥¢¥¯¥»¥¹¤Ë¥×¥í¥¥·¤¬É¬Íפʻþ¤Ï¡¢´Ä¶ÊÑ¿ôHTTP_PROXY¤ò¥»¥Ã¥È¤·¤Æ¤«¤éºÆ»î¹Ô¤·¤Æ¤¯¤À¤µ¤¤¡£\n" unless($ENV{'HTTP_PROXY'});
} elsif ($mixi->is_login_required($response)) {
$error = "[error] " . $mixi->is_login_required($response) . "\n";
} elsif (not $mixi->session) {
$error = "[error] ¥»¥Ã¥·¥ç¥óID¤ò¼èÆÀ¤Ç¤¤Þ¤»¤ó¤Ç¤·¤¿¡£\n";
} elsif (not $mixi->stamp) {
$error = "[error] ¥»¥Ã¥·¥ç¥ó¥¹¥¿¥ó¥×¤ò¼èÆÀ¤Ç¤¤Þ¤»¤ó¤Ç¤·¤¿¡£\n";
} elsif (not $mixi->session) {
$error = "[error] ¥ê¥Õ¥ì¥Ã¥·¥åURL¤ò¼èÆÀ¤Ç¤¤Þ¤»¤ó¤Ç¤·¤¿¡£\n";
}
}
if ($error) {
$mixi->log("¥í¥°¥¤¥ó¤Ç¤¤Þ¤»¤ó¤Ç¤·¤¿¡£\n", $error);
$mixi->dumper_log($response);
exit 8;
} else {
$mixi->log('[info] ¥»¥Ã¥·¥ç¥óID¤Ï"' . $mixi->session . "\"¤Ç¤¹¡£\n");
}
}
sub test_get {
my $mixi = shift;
my $error = '';
$mixi->log("¥È¥Ã¥×¥Ú¡¼¥¸¤ò¼èÆÀ¤·¤Þ¤¹¡£\n");
my $response = eval '$mixi->get("home")';
if ($@) {
$error = "[error] $@\n";
} elsif (not $response->is_success) {
$error = sprintf("[error] %d %s\n", $response->code, $response->message);
$error .= "[info] Web¥¢¥¯¥»¥¹¤Ë¥×¥í¥¥·¤¬É¬Íפʻþ¤Ï¡¢´Ä¶ÊÑ¿ôHTTP_PROXY¤ò¥»¥Ã¥È¤·¤Æ¤«¤éºÆ»î¹Ô¤·¤Æ¤¯¤À¤µ¤¤¡£\n" unless($ENV{'HTTP_PROXY'});
} elsif ($mixi->is_login_required($response)) {
$error = "[error] " . $mixi->is_login_required($response) . "\n";
}
if ($error) {
$mixi->log("¥È¥Ã¥×¥Ú¡¼¥¸¤Î¼èÆÀ¤Ë¼ºÇÔ¤·¤Þ¤·¤¿¡£\n", $error);
$mixi->dumper_log($response);
exit 8;
}
}
sub test_record {
my $mixi = shift;
$mixi->{'__test_record'} = {} unless (ref($mixi->{'__test_record'}) eq 'HASH');
if (@_ == 0) {
return sort { $a cmp $b } (keys(%{$mixi->{'__test_record'}}));
} elsif (@_ == 1) {
my $key = shift;
return $mixi->{'__test_record'}->{$key};
} else {
my %args = @_;
map { $mixi->{'__test_record'}->{$_} = $args{$_} } keys(%args);
return 1;
}
}
sub test_link {
my $mixi = shift;
$mixi->{'__test_link'} = {} unless (ref($mixi->{'__test_link'}) eq 'HASH');
if (@_ == 0) {
return sort { $a cmp $b } (keys(%{$mixi->{'__test_link'}}));
} elsif (@_ == 1) {
my $key = shift;
return $mixi->{'__test_link'}->{$key};
} else {
my $key = shift;
foreach my $item (grep { ref($_) eq 'HASH' } @_) {
foreach (values(%{$item})) {
foreach my $value (ref($_) eq 'HASH' ? values(%{$_}) : $_) {
next if (ref($value) ne '' or $value =~ /\s/);
next if ($value !~ /^https?:\/\/(?:[^\/]*].)?mixi.jp\/(?:[^\?]*\/)?([^\/\?]+).*$/);
next if ($mixi->{'__test_link'}->{$1});
$mixi->{'__test_link'}->{$1} = $value;
}
}
}
return 1;
}
}
sub test_scenario {
my $mixi = shift;
my @tests = (
# °ú¿ôÉÔÍפΤâ¤Î
'main_menu' => {'label' => '¥á¥¤¥ó¥á¥Ë¥å¡¼'},
'banner' => {'label' => '¥Ð¥Ê¡¼'},
'tool_bar' => {'label' => '¥Ä¡¼¥ë¥Ð¡¼'},
'information' => {'label' => '´ÉÍý¼Ô¤«¤é¤Î¤ªÃΤ餻'},
'home_new_album' => {'label' => '¥Û¡¼¥à¤Î¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·¥¢¥ë¥Ð¥à'},
'home_new_bbs' => {'label' => '¥Û¡¼¥à¤Î¥³¥ß¥å¥Ë¥Æ¥£ºÇ¿·½ñ¤¹þ¤ß'},
'home_new_comment' => {'label' => '¥Û¡¼¥à¤ÎÆüµ¥³¥á¥ó¥ÈµÆþÍúÎò'},
'home_new_friend_diary' => {'label' => '¥Û¡¼¥à¤Î¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·Æüµ'},
'home_new_review' => {'label' => '¥Û¡¼¥à¤Î¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·¥ì¥Ó¥å¡¼'},
'list_bookmark' => {'label' => '¤ªµ¤¤ËÆþ¤ê'},
'list_comment' => {'label' => 'ºÇ¶á¤Î¥³¥á¥ó¥È'},
'list_community' => {'label' => '¥³¥ß¥å¥Ë¥Æ¥£°ìÍ÷'},
'list_community_next' => {'label' => '¥³¥ß¥å¥Ë¥Æ¥£°ìÍ÷(¼¡)'},
'list_community_previous' => {'label' => '¥³¥ß¥å¥Ë¥Æ¥£°ìÍ÷(Á°)', 'url' => sub { return $_[0]->test_record('list_community_next')}},
'list_diary' => {'label' => 'Æüµ'},
'list_diary_capacity' => {'label' => 'ÆüµÍÆÎÌ'},
'list_diary_next' => {'label' => 'Æüµ(¼¡)'},
'list_diary_previous' => {'label' => 'Æüµ(Á°)', 'url' => sub { return $_[0]->test_record('list_diary_next')}},
'list_diary_monthly_menu' => {'label' => 'Æüµ·îÊÌ¥Ú¡¼¥¸'},
'list_friend' => {'label' => 'ͧ¿Í¡¦ÃοͰìÍ÷'},
'list_friend_next' => {'label' => 'ͧ¿Í¡¦ÃοͰìÍ÷(¼¡)'},
'list_friend_previous' => {'label' => 'ͧ¿Í¡¦ÃοͰìÍ÷(Á°)', 'url' => sub { return $_[0]->test_record('list_friend_next')}},
'list_message' => {'label' => '¼õ¿®¥á¥Ã¥»¡¼¥¸'},
'list_outbox' => {'label' => 'Á÷¿®¥á¥Ã¥»¡¼¥¸'},
'list_request' => {'label' => '¾µÇ§ÂÔ¤Á¤Îͧ¿Í'},
'new_album' => {'label' => '¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·¥¢¥ë¥Ð¥à'},
'new_bbs' => {'label' => '¥³¥ß¥å¥Ë¥Æ¥£ºÇ¿·½ñ¤¹þ¤ß'},
'new_bbs_next' => {'label' => '¥³¥ß¥å¥Ë¥Æ¥£ºÇ¿·½ñ¤¹þ¤ß(¼¡)'},
'new_bbs_previous' => {'label' => '¥³¥ß¥å¥Ë¥Æ¥£ºÇ¿·½ñ¤¹þ¤ß(Á°)', 'url' => sub { return $_[0]->test_record('new_bbs_next')}},
'new_comment' => {'label' => 'Æüµ¥³¥á¥ó¥ÈµÆþÍúÎò'},
'new_friend_diary' => {'label' => '¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·Æüµ'},
'new_friend_diary_next' => {'label' => '¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·Æüµ(¼¡)'},
'new_friend_diary_previous' => {'label' => '¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·Æüµ(Á°)', 'url' => sub { return $_[0]->test_record('new_friend_diary_next')}},
'ajax_new_diary' => {'label' => '¥Þ¥¤¥ß¥¯¥·¥£¤ÎºÇ¿·Æüµ¡ÊAjaxÈÇ¡Ë', 'url' => sub { return $_[0]->test_link('ajax_new_diary.pl') }},
'new_review' => {'label' => '¥Þ¥¤¥ß¥¯¥·¥£ºÇ¿·¥ì¥Ó¥å¡¼'},
'release_info' => {'label' => '¥ê¥ê¡¼¥¹¥¤¥ó¥Õ¥©¥á¡¼¥·¥ç¥ó'},
'self_id' => {'label' => '¼«Ê¬¤ÎID'},
'search_diary' => {'label' => '¿·ÃåÆüµ¸¡º÷', 'arg' => ['keyword' => 'Mixi']},
'search_diary_next' => {'label' => '¿·ÃåÆüµ¸¡º÷(¼¡)', 'arg' => ['keyword' => 'Mixi']},
'search_diary_previous' => {'label' => '¿·ÃåÆüµ¸¡º÷(Á°)', 'url' => sub { return $_[0]->test_record('search_diary_next')}},
'show_calendar' => {'label' => '¥«¥ì¥ó¥À¡¼'},
'show_calendar_term' => {'label' => '¥«¥ì¥ó¥À¡¼¤Î´ü´Ö'},
'show_calendar_next' => {'label' => '¥«¥ì¥ó¥À¡¼(¼¡)'},
'show_calendar_previous' => {'label' => '¥«¥ì¥ó¥À¡¼(Á°)', 'url' => sub { return $_[0]->test_record('show_calendar_next')}},
'show_intro' => {'label' => '¥Þ¥¤¥ß¥¯¥·¥£¤«¤é¤Î¾Ò²ðʸ'},
'show_log' => {'label' => '¤¢¤·¤¢¤È'},
'show_log_count' => {'label' => '¤¢¤·¤¢¤È¿ô'},
# ¥³¥ó¥Æ¥ó¥Ä
'view_album' => {'label' => '¥Õ¥©¥È¥¢¥ë¥Ð¥à', 'url' => sub { return $_[0]->test_record('new_album')}},
'view_album_photo' => {'label' => '¥Õ¥©¥È¥¢¥ë¥Ð¥à¤Î¼Ì¿¿', 'url' => sub { $_ = $_[0]->test_record('new_album'); return ref($_) eq 'HASH' ? $_->{'link'} : undef }},
'view_album_comment' => {'label' => '¥Õ¥©¥È¥¢¥ë¥Ð¥à¤Î¥³¥á¥ó¥È', 'url' => sub { $_ = $_[0]->test_record('new_album'); return ref($_) eq 'HASH' ? $_->{'link'} . '&mode=comment' : undef }},
'view_diary' => {'label' => 'Æüµ(¾ÜºÙ)', 'url' => sub { return $_[0]->test_record('list_diary')}},
'view_event' => {'label' => '¥¤¥Ù¥ó¥È', 'url' => sub { return $_[0]->test_link('view_event.pl')}},
'view_message' => {'label' => '¥á¥Ã¥»¡¼¥¸(¾ÜºÙ)', 'url' => sub { return $_[0]->test_record('list_message')}},
# ¥³¥ß¥å¥Ë¥Æ¥£´ØÏ¢
'community_id' => {'label' => '¥³¥ß¥å¥Ë¥Æ¥£ID', 'url' => sub { return $_[0]->test_record('list_community')}},
'list_bbs' => {'label' => '¥È¥Ô¥Ã¥¯°ìÍ÷', 'arg' => ['id' => 43735]},
'list_bbs_next' => {'label' => '¥È¥Ô¥Ã¥¯°ìÍ÷(¼¡)', 'arg' => ['id' => 43735]},
'list_bbs_previous' => {'label' => '¥È¥Ô¥Ã¥¯°ìÍ÷(Á°)', 'url' => sub { return $_[0]->test_record('list_bbs_next')}},
'list_member' => {'label' => '¥á¥ó¥Ð¡¼°ìÍ÷', 'arg' => ['id' => 43735]},
'list_member_next' => {'label' => '¥á¥ó¥Ð¡¼°ìÍ÷(¼¡)', 'arg' => ['id' => 43735]},
'list_member_previous' => {'label' => '¥á¥ó¥Ð¡¼°ìÍ÷(Á°)', 'url' => sub { return $_[0]->test_record('list_member_next')}},
'edit_member' => {'label' => '¥á¥ó¥Ð¡¼´ÉÍý', 'arg' => ['id' => 43735]},
'edit_member_pages' => {'label' => '¥á¥ó¥Ð¡¼´ÉÍý(¥Ú¡¼¥¸°ìÍ÷)', 'arg' => ['id' => 43735]},
'view_bbs' => {'label' => '¥È¥Ô¥Ã¥¯', 'url' => sub { return $_[0]->test_record('list_bbs')}},
# 'view_community' => {'label' => '¥³¥ß¥å¥Ë¥Æ¥£', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]},
# Æüµ¤ÎÊÔ½¸
'edit_diary_preview' => {'label' => 'Æüµ(ÊÔ½¸)', 'url' => sub { return $_[0]->test_record('list_diary')}},
);
while (@tests >= 2) {
my ($test, $opt) = splice(@tests, 0, 2);
my $method = "get_$test";
my $label = $opt->{'label'};
my $url = defined($opt->{'url'}) ? $opt->{'url'} : '';
if (ref($url) eq 'CODE') {
$url = &{$url}($mixi);
unless ($url) {
$mixi->log("$label¤ò¥¹¥¥Ã¥×¤·¤Þ¤¹¡£\n", "[warn] »²¾È¥ì¥³¡¼¥É¤Ê¤·\n");
next;
}
}
$url = $url->{'link'} if (ref($url) eq 'HASH');
my @arg = (defined($opt->{'arg'}) and ref($opt->{'arg'})) eq 'ARRAY' ? @{$opt->{'arg'}} : ();
@arg = map { ref($_) eq 'CODE' ? &{$_}($mixi) : $_ } @arg;
unshift(@arg, $url) if (defined($url) and ref($url) eq '' and length($url));
$mixi->log("$label¤Î¼èÆÀ¤È²òÀÏ¡Ê$method¡Ë¤ò¤·¤Þ¤¹¡£\n");
$mixi->log(qq([info] ¥¿¡¼¥²¥Ã¥ÈURL¤Ï"$url"¤Ç¤¹¡£\n)) if ($url);
my @items = eval { $mixi->$method(@arg); };
my $error = ($@) ? $@ : ($mixi->response->is_error) ? $mixi->response->status_line : undef;
if (defined $error) {
$mixi->log("$label¤Î¼èÆÀ¤È²òÀϤ˼ºÇÔ¤·¤Þ¤·¤¿¡£\n", "[error] $error\n");
$mixi->dumper_log($mixi->response);
exit 8;
} else {
if (@items) {
$mixi->dumper_log([@items]);
$mixi->test_link($test => @items);
$mixi->test_record($test => $items[0]);
$mixi->test_record($test => {'link' => 'http://mixi.jp/view_album.pl?id=150828'}) if ($test eq 'new_album');
} else {
$mixi->log("[warn] ¥ì¥³¡¼¥É¤¬¸«¤Ä¤«¤ê¤Þ¤»¤ó¤Ç¤·¤¿¡£\n");
$mixi->dumper_log($mixi->response);
}
}
}
}
sub test_get_add_diary_preview {
my $mixi = shift;
my %diary = (
'diary_title' => 'Æüµ¥¿¥¤¥È¥ë',
'diary_body' => 'ÆüµËÜʸ',
'photo1' => '../logo.jpg',
'orig_size' => 1,
);
$mixi->log("Æüµ¤ÎÅê¹Æ¤È³Îǧ²èÌ̤βòÀϤò¤·¤Þ¤¹¡£\n");
my @items = eval '$mixi->get_add_diary_preview(%diary)';
my $error = ($@) ? "[error] $@\n" : ($mixi->response->is_error) ? "[error] " . $mixi->response->status_line ."\n" : '';
if ($error) {
$mixi->log("Æüµ¤ÎÅê¹Æ¤È³Îǧ²èÌ̤βòÀϤ˼ºÇÔ¤·¤Þ¤·¤¿¡£\n", $error);
exit 8;
} else {
if (@items) {
$mixi->dumper_log([@items]);
} else {
$mixi->log("[info] ³Îǧ²èÌ̤Υե©¡¼¥à¤¬¸«¤Ä¤«¤ê¤Þ¤»¤ó¤Ç¤·¤¿¡£\n");
$mixi->dumper_log($mixi->response);
}
}
}
sub test_save_and_read_cookies {
my $mixi = shift;
my $error = '';
# Cookie¤ÎÊݸ
$mixi->log("Cookie¤òÊݸ¤·¤Þ¤¹¡£\n");
my $saved_str = $mixi->cookie_jar->as_string;
my $loaded_str = '';
my $cookie_file = sprintf('cookie_%s_%s.txt', $$, time);
$_ = eval '$mixi->save_cookies($cookie_file)';
if ($@) {
$error = "[error] $@\n";
} elsif (not $_) {
$error = "[error] cookie¤ÎÊݸ¤¬¼ºÇÔ¤·¤Þ¤·¤¿¡£\n";
}
if ($error) {
$mixi->log("Cookie¤òÊݸ¤Ç¤¤Þ¤»¤ó¤Ç¤·¤¿¡£\n", $error);
exit 8;
}
# Cookie¤ÎÆɹþ
$mixi->log("Cookie¤ÎÆɹþ¤ò¤·¤Þ¤¹¡£\n");
$mixi->cookie_jar->clear;
$_ = eval '$mixi->load_cookies($cookie_file)';
if ($@) {
$error = "[error] $@\n";
} elsif (not $_) {
$error = "[error] cookie¤ÎÆɹþ¤¬¼ºÇÔ¤·¤Þ¤·¤¿¡£\n";
} else {
$loaded_str = $mixi->cookie_jar->as_string;
$error = "[error] Êݸ¤·¤¿Cookie¤ÈÆɤ߹þ¤ó¤ÀCookie¤¬°ìÃפ·¤Þ¤»¤ó¡£\n" if ($saved_str ne $loaded_str);
}
if ($error) {
$mixi->log("Cookie¤òÆɹþ¤á¤Þ¤»¤ó¤Ç¤·¤¿¡£\n", $error);
exit 8;
}
unlink($cookie_file);
}
package WWW::Mixi::RobotRules;
use vars qw($VERSION @ISA);
require WWW::RobotRules;
@ISA = qw(WWW::RobotRules::InCore);
$VERSION = sprintf("%d.%02d", q$Revision: 0.01 $ =~ /(\d+)\.(\d+)/);
sub allowed {
return 1;
}
1;