File Coverage

blib/lib/IMDB/BaseClass.pm

Criterion	Covered	Total	%
statement	59	272	21.6
branch	0	98	0.0
condition	0	44	0.0
subroutine	20	52	38.4
pod	7	10	70.0
total	86	476	18.0

=head1 NAME

IMDB::BaseClass - a base class for IMDB::Film and IMDB::Persons.

=head1 SYNOPSIS

  use base qw(IMDB::BaseClass);

=head1 DESCRIPTION

IMDB::BaseClass implements a base functionality for IMDB::Film
and IMDB::Persons.

=cut

package IMDB::BaseClass;

use strict;
use warnings;

use HTML::TokeParser;
use LWP::Simple qw($ua get);
use Cache::FileCache;
use Text::Unidecode qw(unidecode);
use HTML::Entities;
use Carp;

use Data::Dumper;

use constant MAIN_TAG	=> 'h4';
use constant ID_LENGTH	=> 6;

use vars qw($VERSION %FIELDS $AUTOLOAD %STATUS_DESCR);

BEGIN {
	$VERSION = '0.53';

	%STATUS_DESCR = (
		0 => 'Empty',
		1 => 'Filed',
		2 => 'Fresh',
		3 => 'Cached',
	);
}

use constant FORCED 		=> 1;
use constant CLASS_NAME 	=> 'IMDB::BaseClass';

use constant FROM_FILE		=> 1;
use constant FROM_INTERNET	=> 2;
use constant FROM_CACHE		=> 3;

use fields qw(	content
				parser
				matched
				proxy
				error
				cache
				host
				query
				search
				cacheObj
				cache_exp
				cache_root
				clear_cache
				debug
				status
				file
				timeout
				user_agent
				decode_html
				exact
				_code
	);

=head2 Constructor and initialization

=over 4

=item new()

Object's constructor. You should pass as parameter movie title or IMDB code.

	my $imdb = new IMDB::Film(crit => );

or

	my $imdb = new IMDB::Film(crit => );

Also, you can specify following optional parameters:

	- proxy - define proxy server name and port;
	- debug	- switch on debug mode (on by default);
	- cache - cache or not of content retrieved pages.

=cut

sub new {
	my $caller = shift;
	my $class = ref($caller) || $caller;
	my $self = fields::new($class);
	$self->_init(@_);
	return $self;
}

=item _init()

Initialize object. It gets list of service class properties and assign value to them from input
parameters or from the hash with default values.

=cut

sub _init {
	my CLASS_NAME $self = shift;
	my %args = @_;

	no warnings 'deprecated';

	for my $prop ( keys %{ $self->fields } ) {
		unless($prop =~ /^_/) {
			$self->{$prop} = defined $args{$prop} ? $args{$prop} : $self->_get_default_value($prop);
		}
	}

	if($self->_cache()) {
		$self->_cacheObj( new Cache::FileCache( { 	default_expires_in 	=> $self->_cache_exp,
													cache_root 			=> $self->_cache_root } ) );

		$self->_cacheObj->clear() if $self->_clear_cache;
	}

	if($self->_proxy) { $ua->proxy(['http', 'ftp'], $self->_proxy()) }
	else { $ua->env_proxy() }

	$ua->timeout($self->timeout);
	$ua->agent($self->user_agent);

	$self->_content( $args{crit} );
	$self->_parser();
}

=item user_agent()

Define an user agent for HTTP request. It's 'Mozilla/5.0' by default.
For more information refer to LWP::UserAgent.

=cut

sub user_agent {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{user_agent} = shift }
	return $self->{user_agent}
}

=item timeout()

Define a timeout for HTTP request in seconds. By default it's 10 sec.
For more information refer to LWP::UserAgent.

=cut

sub timeout {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{timeout} = shift }
	return $self->{timeout}
}

=item code()

Get IMDB film code.

	my $code = $film->code();

=cut

sub code {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{_code} = shift }
	return $self->{_code};
}

=item id()

Get IMDB film id (actually, it's the same as code).

	my $id = $film->id();

=cut

sub id {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{_code} = shift }
	return $self->{_code};
}

=item _proxy()

Store address of proxy server. You can pass a proxy name as parameter into
object constructor:

	my $imdb = new IMDB::Film(code => 111111, proxy => 'my.proxy.host:8080');

or you can define environment variable 'http_host'. For exanple, for Linux
you shoud do a following:

	export http_proxy=my.proxy.host:8080

=cut

sub _proxy {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{proxy} = shift }
	return $self->{proxy};
}

sub _decode_html {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{decode_html} = shift }
	return $self->{decode_html};
}

=item _cache()

Store cache flag. Indicate use file cache to store content page or not:

	my $imdb = new IMDB::Film(code => 111111, cache => 1);

=cut

sub _cache {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{cache} = shift }
	return $self->{cache}
}

=item _clear_cache

Store flag clear_cache which is indicated clear exisisting cache or not (false by default):

	my $imdb = new IMDB::Film(code => 111111, cache => 1, clear_cache => 1);

=cut

sub _clear_cache {
	my CLASS_NAME $self = shift;
	if($_) { $self->{clear_cache} = shift }
	return $self->{clear_cache};
}

=item _cacheObj()

In case of using cache, we create new Cache::File object and store it in object's
propery. For more details about Cache::File please see Cache::Cache documentation.

=cut

sub _cacheObj {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{cacheObj} = shift }
	return $self->{cacheObj}
}

=item _cache_exp()

In case of using cache, we can define value time of cache expire.

	my $imdb = new IMDB::Film(code => 111111, cache_exp => '1 h');

For more details please see Cache::Cache documentation.

=cut

sub _cache_exp {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{cache_exp} = shift }
	return $self->{cache_exp}
}

sub _cache_root {
	my CLASS_NAME $self = shift;
	$self->{cache_root} = shift if @_;

	$self->_show_message("CACHE ROOT is " . $self->{cache_root}, 'DEBUG');

	return $self->{cache_root};
}

sub _show_message {
	my CLASS_NAME $self = shift;
	my $msg = shift || 'Unknown error';
	my $type = shift || 'ERROR';

	return if $type =~ /^debug$/i && !$self->_debug();

	if($type =~ /(debug|info|warn)/i) { carp "[$type] $msg" }
	else { croak "[$type] $msg" }
}

=item _host()

Store IMDB host name. You can pass this value in object constructor:

	my $imdb = new IMDB::Film(code => 111111, host => 'us.imdb.com');

By default, it uses 'www.imdb.com'.

=cut

sub _host {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{host} = shift }
	return $self->{host}
}

=item _query()

Store query string to retrieve film by its ID. You can define
different value for that:

	my $imdb = new IMDB::Film(code => 111111, query => 'some significant string');

Default value is 'title/tt'.

B
real case.>

=cut

sub _query {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{query} = shift }
	return $self->{query}
}

=item _search()

Store search string to find film by its title. You can define
different value for that:

	my $imdb = new IMDB::Film(code => 111111, seach => 'some significant string');

Default value is 'Find?select=Titles&for='.

=cut

sub _search {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{search} = shift }
	return $self->{search}
}

sub _exact {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{exact} = shift }
	return $self->{exact};
}

=item _debug()

Indicate to use DEBUG mode to display some debug messages:

	my $imdb = new IMDB::Film(code => 111111, debug => 1);

By default debug mode is switched off.

=cut

sub _debug {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{debug} = shift }
	return $self->{debug}
}

=item _content()

Connect to the IMDB, retrieve page according to crit: by film
IMDB ID or its title and store content of that page in the object
property.
In case using cache, first check if page was already stored in the
cache then retrieve page from the cache else store content of the
page in the cache.

=cut

sub _content {
	my CLASS_NAME $self = shift;
	if(@_) {
		my $crit = shift || '';
		my $page;

		$self->code($crit) if $crit =~ /^\d{6,8}$/;
		$page = $self->_cacheObj()->get($crit) if $self->_cache();

		$self->_show_message("CRIT: $crit", 'DEBUG');

		unless($page) {
			if( -f $crit ) {
				$self->_show_message("Parse IMDB HTML file ...", 'DEBUG');

				local $/;
				undef $/;
				open FILE, $crit or die "Cannot open off-line IMDB file: $!!";
				$page = ;
				close FILE;
				$self->status(FROM_FILE);
			} else {
				$self->_show_message("Retrieving page from internet ...", 'DEBUG');

				my $url = 'http://'.$self->_host().'/'.
						($crit =~ /^\d+$/ && length($crit) >= ID_LENGTH ? $self->_query() : $self->_search()) . $crit;

				$page = $self->_get_page_from_internet($url);
				$self->status(FROM_INTERNET);
			}

			$self->_cacheObj()->set($crit, $page, $self->_cache_exp()) if $self->_cache();
		} else {
			$self->_show_message("Retrieving page from cache ...", 'DEBUG');
			$self->status(FROM_CACHE);
		}

		$self->{content} = \$page;
	}

	$self->{content};
}

sub _get_page_from_internet {
	my CLASS_NAME $self = shift;
	my $url = shift;

	$self->_show_message("URL is [$url]...", 'DEBUG');

	my $page = get($url);

	unless($page) {
		$self->error("Cannot retieve an url: [$url]!");
		$self->_show_message("Cannot retrieve url [$url]", 'CRITICAL');
	}

	return $page;
}

=item _parser()

Setup HTML::TokeParser and store. To have possibility to inherite that class
we should every time initialize parser using stored content of page.
For more information please see HTML::TokeParser documentation.

=cut

sub _parser {
	my CLASS_NAME $self = shift;
	my $forced = shift || 0;
	my $page = shift || undef;

	if($forced) {
		my $content = defined $page ? $page : $self->_content();

		my $parser = new HTML::TokeParser($content) or croak "[CRITICAL] Cannot create HTML parser: $!!";
		$self->{parser} = $parser;
	}

	return $self->{parser};
}

=item _get_simple_prop()

Retrieve a simple movie property which surrownded by .

=cut

sub _get_simple_prop {
	my CLASS_NAME $self = shift;
	my $target = shift || '';

	my $parser = $self->_parser(FORCED);

	while(my $tag = $parser->get_tag(MAIN_TAG)) {
		my $text = $parser->get_text;

		$self->_show_message("[$tag->[0]] $text --> $target", 'DEBUG');
		last if $text =~ /$target/i;
	}

	my $end_tag = '/a';
	$end_tag = '/div' if $target eq 'trivia';
	$end_tag = 'span' if $target eq 'Production Co';
	$end_tag = '/div' if $target eq 'aspect ratio';

	my $res = $parser->get_trimmed_text($end_tag);

	$res =~ s/\s+(see )?more$//i;

	$self->_show_message("RES: $res", 'DEBUG');

	$res = $self->_decode_special_symbols($res);

	return $res;
}

sub _search_results {
	my CLASS_NAME $self = shift;
	my $pattern = shift || croak 'Please, specify search pattern!';
	my $end_tag = shift || '/li';
	my $year	= shift;

	my(@matched, @guess_res, %matched_hash);
	my $parser = $self->_parser();

	my $count = 0;
	while( my $tag = $parser->get_tag('a') ) {
		my $href = $tag->[1]{href};
		my $title = $parser->get_trimmed_text('a', $end_tag);

		$self->_show_message("TITLE: " . $title, 'DEBUG');
		next if $title =~ /\[IMG\]/i or !$href or $href =~ /pro.imdb.com/;

		# Remove garbage from the first title
		$title =~ s/(\n|\r)//g;
		$title =~ s/\s*\.media_strip_thumbs.*//m;

		if(my($id) = $href =~ /$pattern/) {
			$matched_hash{$id} = {title => $title, 'pos' => $count++};
			@guess_res = ($id, $title) if $year && $title =~ /$year/ && !@guess_res;
		}
	}

	@matched = map { {title => $matched_hash{$_}->{title}, id => $_} }
				sort { $matched_hash{$a}->{'pos'} <=> $matched_hash{$b}->{'pos'} } keys %matched_hash;

	$self->matched(\@matched);

	$self->_show_message("matched: " . Dumper(\@matched), 'DEBUG');
	$self->_show_message("guess: " . Dumper(\@guess_res), 'DEBUG');

	my($title, $id);
	if(@guess_res) {
		($id, $title) = @guess_res;
	} else {
		$title = $matched[0]->{title};
		$id = $matched[0]->{id};
	}

	$self->_content($id);
	$self->_parser(FORCED);

	return $title;
}

=item matched()

Retrieve list of matched films each element of which is hash reference -
{ id => , title => :

	my @matched = @{ $film->matched() };

Note: if movie was matched by title unambiguously it won't be present in this array!

=cut

sub matched {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{matched} = shift }
	return $self->{matched};
}

sub status {
	my CLASS_NAME $self = shift;
	if(@_) { $self->{status} = shift }
	return $self->{status};
}

sub status_descr {
	my CLASS_NAME $self = shift;
	return $STATUS_DESCR{$self->{status}} || $self->{status};
}

sub retrieve_code {
	my CLASS_NAME $self = shift;
	my $parser = shift;
	my $pattern = shift;
	my($id, $tag);

	while($tag = $parser->get_tag('link')) {
		if($tag->[1]{href} && $tag->[1]{href} =~ m!$pattern!) {
			$self->code($1);
			last;
		}
	}
}

=item error()

Return string which contains error messages separated by \n:

	my $errors = $film->error();

=cut

sub error {
	my CLASS_NAME $self = shift;
	if(@_) { push @{ $self->{error} }, shift() }
	return join("\n", @{ $self->{error} }) if $self->{error};
}

sub _decode_special_symbols {
	my($self, $text) = @_;
	if($self->_decode_html) {
		$text = unidecode(decode_entities($text));
	}
	return $text;
}

sub AUTOLOAD {
 	my $self = shift;
	my($class, $method) = $AUTOLOAD =~ /(.*)::(.*)/;
	my($pack, $file, $line) = caller;

	carp "Method [$method] not found in the class [$class]!\n Called from $pack	at line $line";
}

sub DESTROY {
	my $self = shift;
}

1;

__END__