File Coverage

blib/lib/WWW/Search/ValentinskaCZ.pm

Criterion	Covered	Total	%
statement	24	63	38.1
branch	0	6	0.0
condition			n/a
subroutine	8	13	61.5
pod	2	2	100.0
total	34	84	40.4

package WWW::Search::ValentinskaCZ;

# Pragmas.
use base qw(WWW::Search);
use strict;
use warnings;

# Modules.
use Encode qw(decode_utf8);
use LWP::UserAgent;
use Readonly;
use Text::Iconv;
use Web::Scraper;

# Constants.
Readonly::Scalar our $MAINTAINER => 'Michal Spacek ';
Readonly::Scalar my $VALENTINSKA_CZ => 'http://valentinska.cz/';
Readonly::Scalar my $VALENTINSKA_CZ_ACTION1 => 'index.php?hledani=Vyhledej&hltex=';

# Version.
our $VERSION = 0.02;

# Setup.
sub native_setup_search {
	my ($self, $query) = @_;
	$self->{'_def'} = scraper {

		# Get list of books.
		process '//table[@class="ProductTable"]/tr/td',
			'books[]' => scraper {

			process '//h2/a', 'title' => 'TEXT';
			process '//h2/a', 'url' => '@href';
			process '//img', 'cover_url' => '@src';
			process '//p[@class="AuthorName"]',
				'author' => 'TEXT';
			process '//p[@class="BookPrice"]/span',
				'price' => 'TEXT';
			return;
		};
		return;
	};
	$self->{'_query'} = $query;
	return 1;
}

# Get data.
sub native_retrieve_some {
	my $self = shift;

	# Query.
	my $i1 = Text::Iconv->new('utf-8', 'windows-1250');
	my $query = $i1->convert(decode_utf8($self->{'_query'}));

	# Get content.
	my $ua = LWP::UserAgent->new(
		'agent' => "WWW::Search::KacurCZ/$VERSION",
	);
	my $response = $ua->get($VALENTINSKA_CZ.
		$VALENTINSKA_CZ_ACTION1.$query,
	);

	# Process.
	if ($response->is_success) {
		my $i2 = Text::Iconv->new('windows-1250', 'utf-8');
		my $content = $i2->convert($response->content);

		# Get books structure.
		my $books_hr = $self->{'_def'}->scrape($content);

		# Process each book.
		foreach my $book_hr (@{$books_hr->{'books'}}) {
			_fix_url($book_hr, 'url');
			_fix_url($book_hr, 'cover_url');
			$self->_remove_tr($book_hr, 'title');
			push @{$self->{'cache'}}, $book_hr;
		}
	}

	return;
}

# Fix URL to absolute path.
sub _fix_url {
	my ($book_hr, $url) = @_;
	if (exists $book_hr->{$url}) {
		$book_hr->{$url} = $VALENTINSKA_CZ.$book_hr->{$url};
	}
	return;
}

# Remove trailing whitespace.
sub _remove_tr {
	my ($self, $book_hr, $key) = @_;
	if (! exists $book_hr->{$key}) {
		return;
	}
	$book_hr->{$key} =~ s/^\s+//gms;
	$book_hr->{$key} =~ s/\s+$//gms;
	return;
}

1;

__END__