root/lang/perl/WWW-DMM-Adult/trunk/lib/WWW/DMM/Adult.pm @ 13568

Revision 13568, 2.4 kB (checked in by yusukebe, 6 years ago)

moved from v*gina repos

Line 
1package WWW::DMM::Adult;
2
3use warnings;
4use strict;
5use Carp;
6use LWP::UserAgent;
7use Encode;
8use Web::Scraper;
9use WWW::DMM::Adult::Item;
10use YAML;
11
12our $VERSION = '0.0.1';
13
14sub new {
15    my $class = shift;
16    bless {
17           ua => LWP::UserAgent->new,
18           sleep_time => 1,
19       }, $class;
20}
21
22sub search {
23    my ( $self, $query, $opt ) = @_;
24    utf8::encode($query) if utf8::is_utf8($query);
25    Encode::from_to( $query, "utf-8", "euc-jp" );
26    $query = $self->_uri_escape($query);
27   
28    my $url =
29      "http://www.dmm.co.jp/search/?searchstr=$query&redirect=1&sort=rank_asc";
30    $url = $url . "&category=" . $opt->{category} if $opt->{category};
31    my $res     = $self->{ua}->get($url);
32    my $redirect_url = $res->base;
33    my $uri     = URI->new( $redirect_url );
34    my $scraper = scraper {
35        process '/html/body/table/tr/td[3]/table[2]/tr/td/table[2]/tr/td[2]/a',
36          'list[]' => '@href';
37        process '/html/body/table/tr/td[3]/table[3]/tr/td/table[2]/tr/td[2]/a',
38          'list[]' => '@href';
39    };
40    my $result = $scraper->scrape($uri);
41    my @items;
42    @{ $result->{list} } = splice( @{ $result->{list} }, 0, $opt->{num} )
43      if $opt->{num};
44    my $sleep_time = $opt->{sleep_time} || $self->{sleep_time};
45    foreach my $url ( @{ $result->{list} } ) {
46        $url =~ s!searchstr=(.*?)/!!;
47        push( @items, WWW::DMM::Adult::Item->new( url => $url ) );
48        sleep( $sleep_time );
49    }
50    $redirect_url =~ s!sort=rank_asc/!mode=package/!;
51    return { url => $redirect_url ,
52             items => \@items };
53}
54
55sub _uri_escape {
56    my ( $self, $str ) = @_;
57    $str =~ s/(\W)/'%' . unpack('H2', $1)/eg;
58    return $str;
59}
60
611;
62
63__END__
64
65=head1 NAME
66
67WWW::DMM::Adult - [One line description of module's purpose here]
68
69
70=head1 VERSION
71
72This document describes WWW::DMM::Adult version 0.0.1
73
74
75=head1 SYNOPSIS
76
77    use WWW::DMM::Adult;
78    use Encode;
79    use utf8;
80    my $dmm   = WWW::DMM::Adult->new;
81    my $result = $dmm->search("及川奈央", { num => 3 });
82    my @items = @{$result->{items}};
83    foreach my $item (@items) {
84        print Encode::encode( "utf-8", $item->title ) . "\n";
85    }
86
87=head1 DESCRIPTION
88
89=head1 AUTHOR
90
91Yusuke Wada  C<< <yusuke@kamawada.com> >>
92
93
94=head1 LICENCE AND COPYRIGHT
95
96Copyright (c) 2008, Yusuke Wada C<< <yusuke@kamawada.com> >>. All rights reserved.
97
98This module is free software; you can redistribute it and/or
99modify it under the same terms as Perl itself. See L<perlartistic>.
100
Note: See TracBrowser for help on using the browser.