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__ |