File Coverage

blib/lib/WWW/Search/MelcerCZ.pm
Criterion Covered Total %
statement 27 89 30.3
branch 0 12 0.0
condition 0 3 0.0
subroutine 9 16 56.2
pod 2 2 100.0
total 38 122 31.1


line stmt bran cond sub pod time code
1             package WWW::Search::MelcerCZ;
2              
3             # Pragmas.
4 3     3   30542 use base qw(WWW::Search);
  3         5  
  3         2430  
5 3     3   303655 use strict;
  3         6  
  3         117  
6 3     3   15 use warnings;
  3         11  
  3         119  
7              
8             # Modules.
9 3     3   2075 use Encode qw(decode_utf8 encode_utf8);
  3         26127  
  3         297  
10 3     3   26 use LWP::UserAgent;
  3         4  
  3         69  
11 3     3   1603 use Readonly;
  3         7383  
  3         166  
12 3     3   1376 use Text::Iconv;
  3         6501  
  3         145  
13 3     3   1482 use Web::Scraper;
  3         118769  
  3         22  
14 3     3   194 use WWW::Search qw(generic_option);
  3         5  
  3         2235  
15              
16             # Constants.
17             Readonly::Scalar our $MAINTAINER => 'Michal Spacek ';
18             Readonly::Scalar my $MELCER_CZ => 'http://melcer.cz/';
19             Readonly::Scalar my $MELCER_CZ_ACTION1 => 'index.php?akc=hledani&s=0&kos=0'.
20             '&hltext=$hltex&kateg=';
21              
22             # Version.
23             our $VERSION = 0.01;
24              
25             # Setup.
26             sub native_setup_search {
27 0     0 1   my ($self, $query) = @_;
28             $self->{'_def'} = scraper {
29 0     0     process '//meta[@http-equiv="Content-Type"]', 'encoding' => [
30             '@content',
31             \&_get_encoding,
32             ];
33 0           process '//table[@width="100"]/tr/td[5]/a',
34             'next_url' => '@href';
35 0           process '//td[@height="330"]/node()[3]', 'records' => 'RAW';
36             process '//td[@height="330"]/table[@width="560"]', 'books[]'
37             => scraper {
38              
39 0           process '//tr/td/font/a', 'title' => 'RAW',
40             'url' => '@href';
41 0           process '//tr/td[@width="136"]/font[2]',
42             'price' => 'RAW';
43 0           process '//tr[2]/td/font/strong', 'author' => 'RAW';
44 0           process '//tr[3]/td/font/div', 'info' => 'RAW';
45 0           process '//tr[4]/td/div/a', 'cover_url' => '@href';
46 0           process '//tr[5]/td[1]/font[2]', 'publisher' => 'RAW';
47 0           process '//tr[5]/td[2]/font[2]', 'year' => 'RAW';
48 0           return;
49 0           };
50 0           return;
51 0           };
52 0           $self->{'_offset'} = 0;
53 0           $self->{'_query'} = $query;
54 0           return 1;
55             }
56              
57             # Get data.
58             sub native_retrieve_some {
59 0     0 1   my $self = shift;
60              
61             # Query.
62 0           my $i = Text::Iconv->new('utf-8', 'windows-1250');
63 0           my $query = $i->convert(decode_utf8($self->{'_query'}));
64              
65             # Get content.
66 0           my $ua = LWP::UserAgent->new(
67             'agent' => "WWW::Search::MelcerCZ/$VERSION",
68             );
69 0           my $response = $ua->post($MELCER_CZ.$MELCER_CZ_ACTION1,
70             'Content' => {
71             'hltex' => $query,
72             'hledani' => 'Hledat',
73             },
74             );
75              
76             # Process.
77 0 0         if ($response->is_success) {
78 0           my $content = $response->content;
79              
80             # Get books structure.
81 0           my $books_hr = $self->{'_def'}->scrape($content);
82              
83             # Iconv.
84 0 0 0       if (! $self->{'_iconv'} && $books_hr->{'encoding'}) {
85 0           $self->{'_iconv'} = Text::Iconv->new(
86             $books_hr->{'encoding'}, 'utf-8');
87             }
88              
89             # Process each book.
90 0           foreach my $book_hr (@{$books_hr->{'books'}}) {
  0            
91 0           _fix_url($book_hr, 'cover_url');
92 0           _fix_url($book_hr, 'url');
93 0           push @{$self->{'cache'}}, $self->_process($book_hr);
  0            
94             }
95              
96             # Next url.
97 0           _fix_url($books_hr, 'next_url');
98 0           $self->next_url($books_hr->{'next_url'});
99             }
100              
101 0           return;
102             }
103              
104             # Get enconding from Content-Type string.
105             sub _get_encoding {
106 0     0     my $content_type = shift;
107 0 0         if ($content_type =~ m/.*charset=(.*)$/ms) {
108 0           return $1;
109             } else {
110 0           return;
111             }
112             }
113              
114             # Fix URL to absolute path.
115             sub _fix_url {
116 0     0     my ($book_hr, $url) = @_;
117 0 0         if (exists $book_hr->{$url}) {
118 0           $book_hr->{$url} = $MELCER_CZ.$book_hr->{$url};
119             }
120 0           return;
121             }
122              
123             # Process each parameter of structure.
124             sub _process {
125 0     0     my ($self, $book_hr) = @_;
126 0           $self->_process_one($book_hr, 'author');
127 0           $self->_process_one($book_hr, 'info');
128 0           $self->_process_one($book_hr, 'publisher');
129 0           $self->_process_one($book_hr, 'price');
130 0           $self->_process_one($book_hr, 'title');
131 0           return $book_hr;
132             }
133              
134             # Process string to right output:
135             # - Encode to utf8.
136             # - Remove trailing whitespace.
137             sub _process_one {
138 0     0     my ($self, $book_hr, $key) = @_;
139              
140             # No value.
141 0 0         if (! exists $book_hr->{$key}) {
142 0           return;
143             }
144              
145             # Encode to utf8.
146 0 0         if ($self->{'_iconv'}) {
147 0           $book_hr->{$key} = $self->{'_iconv'}->convert(
148             $book_hr->{$key});
149             }
150              
151             # Encode to perl internal form.
152 0           $book_hr->{$key} = decode_utf8($book_hr->{$key});
153              
154             # Remove trailing whitespace.
155 0           $book_hr->{$key} =~ s/^\s+//gms;
156 0           $book_hr->{$key} =~ s/\s+$//gms;
157              
158             # Encode to octets for output.
159 0           $book_hr->{$key} = encode_utf8($book_hr->{$key});
160              
161 0           return;
162             }
163              
164             1;
165              
166             __END__