File Coverage

blib/lib/WWW/Search/Tv/Sweden/TvDotNu.pm

Criterion	Covered	Total	%
statement	56	79	70.8
branch	7	14	50.0
condition	3	15	20.0
subroutine	18	21	85.7
pod	4	5	80.0
total	88	134	65.6

# $Id: TvDotNu.pm,v 1.2 2004/03/31 20:28:08 claes Exp $

package WWW::Search::Tv::Sweden::TvDotNu;

use 5.008;
use strict;
use warnings;

use LWP::UserAgent;
use HTTP::Request;
use HTML::Parser;
use WWW::Search::Tv::Sweden::TvDotNu::DB;
use WWW::Search::Tv::Sweden::TvDotNu::Entry;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use WWW::Search::Tv::Sweden::TvDotNu ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '1.01';

# Always use this user agent
my $UserAgent = LWP::UserAgent->new();

# Month names
my @Months = qw(jan feb mar apr may jun jul aug sep oct nov dec);

# Preloaded methods go here.

sub new {
  my ($class, %args) = @_;
  $class = ref($class) || $class;
  bless {
	 cache => 1,
	 %args
	}, $class;
}

sub get_today {
  my ($self) = @_;
  return $self->get("http://www.tv.nu");
}

sub get_tomorrow {
  my ($self) = @_;
  my ($day, $mon) = (localtime(time))[3,4];
  my $url = "http://show.tv.nu/" . $Months[$mon] . "/" . ($day + 1) . "/";
  return $self->get($url);
}

sub get_full_entry {
  my ($self, $entry) = @_;

  my $request = HTTP::Request->new(GET => $entry->url);
  my $response = $UserAgent->request($request);

  if($response->is_success) {
    $self->_parse_entry($response->content(), $entry);
  }
}

sub get {
  my ($self, $url) = @_;

  my $request = HTTP::Request->new(GET => $url);
  my $response = $UserAgent->request($request);

  if($response->is_success) {
    return $self->_parse_toc($response->content());
  }
}

sub _parse_toc {
  my ($self, $content) = @_;

  my $db = WWW::Search::Tv::Sweden::TvDotNu::DB->new();

  my $start_h = $self->_toc_start_h($db);
  my $end_h = $self->_toc_end_h($db);
  my $text_h = $self->_toc_text_h($db);

  my $toc_parser = HTML::Parser->new(api_version => 3,
				     start_h => [$start_h, "tagname, attr"],
				     text_h => [$text_h, "dtext"],
				     end_h => [$end_h, "tagname"],
				    );

  $toc_parser->parse($content);

  return $db;
}

sub _parse_entry {
  my ($self, $content, $entry) = @_;

  my $start_h = $entry->_entry_start_h();
  my $end_h = $entry->_entry_end_h();
  my $text_h = $entry->_entry_text_h();

  my $entry_parser = HTML::Parser->new(api_version => 3,
				       start_h => [$start_h, "tagname, attr"],
				       text_h => [$text_h, "dtext"],
				       end_h => [$end_h, "tagname"],
				      );

  $entry_parser->unbroken_text(1);
  $entry_parser->parse($content);
}

sub _toc_start_h {
  my ($self, $db) = @_;

  return sub {
    my ($tagname, $attr) = @_;

    if($tagname eq 'a') {
      if(exists $attr->{href} && $attr->{href} =~ /^javascript:p(.*)$/) {
	my ($url, $channel,
	    $start_hour, $start_min,
	    $end_hour, $end_min) = $1 =~ m{
					   ^\(\'
					   (.*)\/
					   (.*)\/
					   (\d\d)(\d\d)-(\d\d)(\d\d)
					   \.html\'}x;

	next unless($url && $channel && "$start_hour$start_min" && "$end_hour$end_min");
	$url = join("", $url, "/", $channel, "/", $start_hour, $start_min, "-", $end_hour, $end_min, ".html");

	my $entry = WWW::Search::Tv::Sweden::TvDotNu::Entry->new(url => $url,
								 channel => $channel,
								 start_time => [
										$start_hour + 0,
										$start_min + 0
									       ],
								 end_time => [
									    $end_hour + 0,
									      $end_min + 0
									     ],
								 title => "",
								);

	$db->add($entry);
	$self->{open_a} = 1;
      }
    }
  };
}

sub _toc_text_h {
  my ($self, $db) = @_;

  return sub {
    my ($text) = @_;

    if($self->{open_a}) {
      $db->last->title($text);
    }
  }
}
sub _toc_end_h {
  my ($self) = @_;

  return sub {
    my ($tagname) = @_;
    if($tagname eq 'a') {
      $self->{open_a} = 0;
    }
  }
}

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__