File Coverage

blib/lib/Net/Kotonoha/Koto.pm
Criterion Covered Total %
statement 21 91 23.0
branch 0 30 0.0
condition 0 2 0.0
subroutine 7 14 50.0
pod 0 5 0.0
total 28 142 19.7


line stmt bran cond sub pod time code
1             package Net::Kotonoha::Koto;
2              
3 2     2   13 use strict;
  2         5  
  2         75  
4 2     2   10 use warnings;
  2         5  
  2         56  
5 2     2   12 use Encode;
  2         4  
  2         281  
6 2     2   12 use Carp;
  2         4  
  2         124  
7 2     2   11 use URI;
  2         5  
  2         56  
8 2     2   10 use HTML::Selector::XPath qw/selector_to_xpath/;
  2         4  
  2         84  
9 2     2   11 use HTML::TreeBuilder::XPath;
  2         4  
  2         27  
10              
11             sub new {
12 0     0 0   my $class = shift;
13 0           my %args = @_;
14 0           $args{content} = '';
15 0           return bless {%args}, $class;
16             }
17              
18             sub _get_content {
19 0     0     my $self = shift;
20 0           my $koto_no = $self->{koto_no};
21 0           my $limit = $self->{kotonoha}->{limit};
22 0 0         return unless defined $self->{kotonoha}->{loggedin};
23 0 0         unless ($self->{content}) {
24 0           my $res = $self->{kotonoha}->{mech}->get("http://kotonoha.cc/no/$koto_no?limit=$limit");
25 0 0         $self->{content} = $res->content if $res->is_success;
26             }
27 0           return Encode::decode("utf-8", $self->{content});
28             }
29              
30             sub _get_list {
31 0     0     my $self = shift;
32 0           my $xpath = shift;
33 0   0       my $answer = shift || '';
34              
35 0           my @list;
36 0           my $tree = HTML::TreeBuilder::XPath->new;
37 0           $tree->parse( $self->_get_content );
38 0           $tree->eof;
39 0           foreach my $item ($tree->findnodes($xpath)) {
40 0           my $user = $item->findnodes(('.//div[@class="userbox"]//a'))->shift;
41 0           my $comment = $item->findnodes(('.//p[@class="comment"]'));
42 0           my $link = $user->attr('href');
43 0 0         if ($link =~ /^\/user\/(\w+)/) {
44 0 0         push @list, {
45             user => $1,
46             name => $user->attr('title'),
47             comment => $comment ? $comment->shift->as_text : '',
48             answer => $answer,
49             }
50             }
51             }
52              
53 0           foreach my $item ($tree->findnodes('//dl[@id="answeredusers"]//div[@class="userbox"]')) {
54 0           my $user = $item->findnodes(('.//a'))->shift;
55 0           my $comment = $item->findnodes(('.//p'))->shift->as_text;
56 0 0         my $my_answer = $comment =~ '\xe2\x97\x8b' ? 1 : 2;
57 0 0         if ($answer eq $my_answer) {
58 0           my $link = $user->attr('href');
59 0 0         if ($link =~ /^\/user\/(\w+)/) {
60 0           my $userid = $1;
61 0 0         if (!grep($_->{user} eq $userid, @list)) { # no critic
62 0           push @list, {
63             user => $userid,
64             name => $user->attr('title'),
65             comment => '',
66             answer => $my_answer,
67             }
68             }
69             }
70             }
71             }
72 0           $tree->delete;
73 0           return \@list;
74             }
75              
76             sub yesman {
77 0     0 0   shift->_get_list('//dl[@id="commentsyes"]//ul[@class="commentbox"]', 1);
78             }
79              
80             sub noman {
81 0     0 0   shift->_get_list('//dl[@id="commentsno"]//ul[@class="commentbox"]', 2);
82             }
83              
84             sub title {
85 0     0 0   my $self = shift;
86 0           my $tree = HTML::TreeBuilder::XPath->new;
87 0           $tree->parse( $self->_get_content );
88 0           $tree->eof;
89 0           my $t = $tree->findnodes('//title');
90 0 0         $t = $t ? $t->shift->as_text : undef;
91 0           $tree->delete;
92 0           Encode::encode_utf8($t);
93             }
94              
95             sub answer {
96 0     0 0   my $self = shift;
97 0 0         if (@_) {
98 0           my $my_answer = shift;
99 0           my $my_comment = shift;
100 0           my $uri = URI->new('http://kotonoha.cc/');
101 0           $uri->query_form(
102             mode => 'ajax',
103             act => 'set_done_flag',
104             koto_id => $self->{koto_no},
105             flag => $my_answer,
106             );
107 0           my $res = $self->{kotonoha}->{mech}->get($uri->as_string);
108 0 0         if ($res->is_success) {
109             # need to reset
110 0           $self->{content} = '';
111              
112 0 0         if ($my_comment) {
113 0           $my_comment = decode_utf8($my_comment);
114 0           $uri = URI->new('http://kotonoha.cc/');
115 0           $uri->query_form(
116             mode => 'ajax',
117             act => 'post_comment',
118             koto_id => $self->{koto_no},
119             comment => $my_comment,
120             );
121 0           my $res = $self->{kotonoha}->{mech}->get($uri->as_string);
122             }
123 0           return 1;
124             } else {
125 0           croak "couldn't post answer";
126             }
127             } else {
128 0           my @found;
129 0           my $myself = $self->{kotonoha}->{user};
130 0           @found = grep $_->{user} eq $myself, @{$self->yesman}; # no critic
  0            
131 0 0         @found = grep $_->{user} eq $myself, @{@$self->noman} unless @found; # no critic
  0            
132 0 0         @found ? return shift @found : croak "couldn't post answer";
133             }
134             }
135              
136             1;