File Coverage

blib/lib/WWW/Amazon/BestSeller.pm
Criterion Covered Total %
statement 24 56 42.8
branch 0 10 0.0
condition 0 4 0.0
subroutine 8 12 66.6
pod 2 2 100.0
total 34 84 40.4


line stmt bran cond sub pod time code
1             package WWW::Amazon::BestSeller;
2              
3 1     1   20004 use 5.006;
  1         3  
  1         43  
4 1     1   3 use strict;
  1         2  
  1         36  
5 1     1   4 use warnings;
  1         7  
  1         36  
6 1     1   671 use LWP::UserAgent;
  1         37095  
  1         32  
7 1     1   804 use HTML::TreeBuilder;
  1         25335  
  1         13  
8 1     1   729 use WWW::UserAgent::Random;
  1         674  
  1         66  
9              
10 1     1   5 use Exporter; # 'import';
  1         1  
  1         32  
11 1     1   4 use vars qw/@EXPORT @EXPORT_OK @ISA $DEBUG $ua/;
  1         2  
  1         391  
12             @ISA = qw/Exporter/;
13              
14             @EXPORT = qw/get_top_category get_sub_category/; # symbols to export on request
15             @EXPORT_OK = @EXPORT; # symbols to export on request
16              
17             =head1 NAME
18              
19             WWW::Amazon::BestSeller - The great new WWW::Amazon::BestSeller!
20              
21             =head1 VERSION
22              
23             Version 0.01
24              
25             =cut
26              
27             our $VERSION = '0.01';
28              
29              
30             =head1 SYNOPSIS
31              
32             抓取 Amazon Best Seller 类别列表, 默认是 com 站,
33             可以通过指定完整的url去获得其它网站的 Best Seller
34              
35              
36             use WWW::Amazon::BestSeller;
37              
38             my $top_categorys = get_top_category();
39             my $top_sub_categorys = get_sub_category( $up_level_url );
40              
41             =head1 EXPORT
42              
43             默认导出 get_top_category 和 get_sub_category 函数
44              
45             =head1 SUBROUTINES/METHODS
46              
47             =head2 get_top_category
48              
49             如果不指定 url, 则默认去取 US 的 Top Selles
50              
51             =cut
52              
53             sub get_top_category {
54 0     0 1   my $top_url = shift;
55 0   0       $top_url ||= 'http://www.amazon.com/Best-Sellers/zgbs/ref=zg_bs_unv_la_0_la_1';
56              
57 0           return _get_with_retry( $top_url );
58             }
59              
60             =head2 get_sub_category
61              
62             获得指定 url 类别的子类别
63              
64             =cut
65              
66             sub get_sub_category {
67 0     0 1   my $sub_url = shift;
68 0 0         return [] unless $sub_url;
69              
70 0           return _get_with_retry( $sub_url );
71             }
72              
73             sub _get_ua {
74 0 0   0     return $ua if $ua;
75 0           $ua = LWP::UserAgent->new( agent => rand_ua("") );
76 0           return $ua;
77             }
78              
79             sub _get_with_retry {
80 0     0     my ( $url, $retry ) = @_;
81 0   0       $retry ||= 20;
82              
83 0           my $ua = _get_ua();
84 0           $ua->default_header( referer => $url );
85              
86 0           my @cs; # 保存得到的 sub category
87              
88 0           while ( $retry > 0 ) {
89 0 0         print "GETING: $url\n" if $DEBUG;
90 0           my $res = $ua->get( $url );
91 0 0         if ( $res->is_success ) {
92 0           my $t = HTML::TreeBuilder->new_from_content( $res->content );
93              
94 0           my @cates = $t->look_down( _tag => 'ul', id => 'zg_browseRoot' );
95 0           @cates = map { $_->look_down( _tag => 'a' ) } @cates;
  0            
96              
97 0           my $index = 1;
98 0           foreach ( @cates ) {
99 0           push @cs, {
100             index => $index,
101             name => $_->as_trimmed_text,
102             url => $_->attr( 'href' )
103             };
104 0           $index++;
105             }
106 0           last;
107             } else {
108 0 0         print "Retry: $retry\tGet fails: " . $res->code. "\n" if $DEBUG;
109 0           $ua->default_header( agent => rand_ua("") );
110 0           sleep( 2 );
111 0           $retry--;
112             }
113             }
114 0           return \@cs;
115             }
116              
117              
118             =head1 AUTHOR
119              
120             MC Cheung, C<< >>
121              
122             =head1 BUGS
123              
124             Please report any bugs or feature requests to C, or through
125             the web interface at L. I will be notified, and then you'll
126             automatically be notified of progress on your bug as I make changes.
127              
128              
129              
130              
131             =head1 SUPPORT
132              
133             perldoc WWW::Amazon::BestSeller
134              
135             =over 4
136              
137             =item * RT: CPAN's request tracker (report bugs here)
138              
139             L
140              
141             =item * AnnoCPAN: Annotated CPAN documentation
142              
143             L
144              
145             =item * CPAN Ratings
146              
147             L
148              
149             =item * Search CPAN
150              
151             L
152              
153             =back
154              
155             =cut
156              
157             1; # End of WWW::Amazon::BestSeller