view release on metacpan or  search on metacpan

grab/de_tvtoday/tv_grab_de_tvtoday.in  view on Meta::CPAN

    undef($grab->{url});
    return;
}



#-- read_popup($url, %$show) -- read the popup file and add the retrieved data into the %show hash
my $warned_discarding_fsk = 0;
my $warned_discarding_two_channel = 0;
sub read_popup($$) {
    my $tb = HTML::TreeBuilder->new();
    my $url = shift;
    my $show = shift;
    $tb->parse(get_page($url));
    
    #-- scan the "data" column at the left first ...
    my $col = $tb->look_down('_tag' => 'table', 'width' => '170');
    #die "cannot find left column in retrieved popup data:\n$got\n" unless ($col);
    #
    # we mustn't assume that this table is actually there, there was at
    # least one popup yet, that didn't provide it (okay, don't know what
    # an empty popup window is good for, but who knows ...)
    $tb->delete(), return unless($col);

    foreach ($col->content_list()) {
	warn "something else but tr-tag found below table-tag, he?", next 
	  unless(ref($_) eq "HTML::Element" and $_->tag eq "tr");
	
	my @td;
	@td = ($_->content_list());
	
	warn "below <tr> there should be a <td>, no here :(", next 
	  unless(ref($td[0]) eq "HTML::Element" and $td[0]->tag eq "td");
	@td = ($td[0]->content_list());

	warn "content found below <td>, tag expected, ignoring", next 
	  unless(ref($td[0]) eq "HTML::Element");
	next unless ($td[0]->tag eq "span");

	#-- okay, we've got a span!
	warn "first span's not of headline-class", next 
	  unless($td[0]->attr('class') eq 'headline');

	#FIX: td[1] doesn't have to be <br>, it may also be just some whitespace !!
	#warn "expected <br> as td[1], not found, ignoring this span", next unless($td[1]->tag eq "br");
	warn "td[2] should be a span of text-class, couldn't be found here, sorry.", next unless($td[2]->tag eq "span" and $td[2]->attr('class') eq 'text');

	my $headline = ($td[0]->content_list())[0];
	my $content = ($td[2]->content_list())[0];
	$content =~ s/(^\s|\s$)//g;
	
	if ($headline =~ m/ShowView:/) {
	    die unless($content =~ m/ShowView ([0-9\-]+)/);
	    $show->{"showview"} = $1 unless($1 eq "99-999-999");
	} 
	elsif ($headline =~ m/Genre:/) {
	    $show->{"category"} = [[ $content, $lang ]];
	} 
	elsif ($headline =~ m/Regie:/) {
	    my @tmp = split m/\s*,\s*/, $content;
	    add_credits($show, 'director', @tmp);
	} 
	elsif ($headline =~ m/Darsteller:/) {
	    my @tmp = split m/\s*,\s*/, $content;
	    add_credits($show, 'actor', @tmp);
	} 
	elsif ($headline =~ m/FSK:/) {
	    die unless($content =~ m/ab ([0-9]+)/);
	    warn "discarding fsk's age recommendations"
	      unless $warned_discarding_fsk++;
	} 
	else {
	    warn "haven't heard of headline $headline yet, adding to description";
	    my $add = "$headline: $content";
	    if ($show->{desc}) {
		$show->{desc}->[0]->[0] .= " $add";
	    } 
	    else {
		$show->{desc} = [ [ $add, $lang ] ];
	    }
	}
    }

    #-- well, now let's have a look for the main column
    $col = $tb->look_down('_tag' => 'td', 'width' => '270');
    die "cannot find main column in retrieved popup data" unless ($col);
    foreach ($col->content_list()) {
	next unless(ref($_) eq "HTML::Element");
	next unless($_->tag eq "span");
	die unless($_->attr('class') eq "text");

	(my $add = ($_->content_list())[0]) =~ s/\s+$//;
	if ($show->{desc}) {
	    $show->{desc}->[0]->[0] .= " * $add";
	} 
	else {
	    $show->{desc} = [ [ $add, $lang ] ];
	}
	last;
    }

    #-- write feature defaults
    $show->{"video"} = { present => 1, colour => 1 };
    $show->{"audio"} = { present => 1, stereo => "mono" };


    #-- last but not least: care for flags that might be available
    foreach ($tb->look_down('_tag' => 'span', 'class' => 'text-mini')) {
	$_ = ($_->content_list())[0];
	if (m/Untertitel für Hörgeschädigte/) {
	    $show->{"subtitles"} = [{ type => 'teletext' }];
	} 
	elsif (m/schwarzweiß/) {
	    $show->{"video"}->{"colour"} = 0;
	} 
	elsif (m/Stereoton/) {
	    $show->{"audio"}->{"stereo"} = "stereo";
	} 
	elsif (m/Zweikanalton/) {
	    warn "discarding two-channel sound flag"
		unless $warned_discarding_two_channel++;
	    #-- show is broadcast in two languages, but we don't
	    #-- know in which ones ... how to store that?
	} 
	else {
	    warn "unknown show feature: $_";
	}
    }


    #-- okay, refine category attribute
    my @newdesc;
    refine_category_attr(\@newdesc, $show);
    if (scalar(@newdesc) > 0) { 
	my $haddesc = ($show->{"desc"} ? $show->{"desc"}->[0][0] . " * " : "");
	my $newdesc = join " * ", (grep $_, @newdesc);

	unless(index($haddesc, $newdesc) > -1) { 
	    $show->{"desc"} = [[ "$haddesc$newdesc", $lang ]];
	}
    }


    #-- okay, we're done, delete what we don't need and return ...
    $tb->delete();
}


#-- squeeze_out_desc($$desc, %$show)
sub squeeze_out_desc($$) {
    my $desc = shift;
    my $show = shift;
    my @newdesc;

    #push(@newdesc, $show->{"desc"}->[0][0]) if($show->{"desc"});

    if(my @parts = ($$desc =~ m/^\s*(\(([^\)]*)\))?\s+([^,;]+)(,\s+([^,;]+)\s+([12][09][0-9]{2}(?:[\/-][0-9]{2})?))?\s*(?:; (Buch\/Regie|R): ([^;]+))?(; D: (.+))?\s*$/)) {
	$$desc = "";

	#-- $parts[1] is the show title in English (doesn't have to be available)
	#-- second title doesn't have to be Enlish, if you've got a French
	#-- movie, $parts[1] will be in French! => undef
	$show->{"title"}->[1] = [ $parts[1], undef ] if($parts[1]);

	#-- $parts[2] is the show's genre in German
	$show->{"category"} = [[ $parts[2], $lang ]];

	if ($parts[3]) {
	    #-- $parts[4] specifies where the film was made, [5] when
	    $show->{"country"} = [[ $parts[4], $lang ]];
	    $show->{"date"} = parse_date_data($parts[5]);
	}

	#-- $parts[7] specifies the director (German: Regisseur)
	if (defined($parts[7])) {
	    $parts[7] =~ s/\s*u.a.\s*$//;
	    $parts[7] =~ s/\([^\(\)]+\)//g; 
	    $parts[7] =~ s/&amp;/&/g;

	    my @people = split m/(?:\s+und\s+|\s*[,;]\s*)/, $parts[7];
	    my @jobs;
	    if ($parts[6] eq 'R') {
		@jobs = qw(director);
	    }
	    elsif ($parts[6] eq 'Buch/Regie') {
		@jobs = qw(director writer);
	    }
	    else {
		warn "don't understand 'director' type $parts[6]";
	    }
	    
	    push @{$show->{credits}{$_}}, @people
	      foreach @jobs;
	}

	if (defined($parts[9])) {
	    #-- $parts[9] specifies the actors (German: Darsteller)
	    $parts[9] =~ s/\s*u.a.\s*$//;
	    $parts[9] =~ s/\([^\(\)]+\)//g; 
	    $parts[9] =~ s/&amp;/&/g;

	    my @actor = split m/(?:\s+und\s+|\s*[,;]\s*)/, $parts[9];
	    push @{$show->{"credits"}{"actor"}}, @actor;
	}
    } 
    else {
	my @data = split "·", $$desc;
	s/(^\s|\s$)//g foreach(@data); #CHG#

	if(scalar(@data) == 3 
	   && not($data[1] =~ m/[\wäöüßÄÖÜ]+:/) #- FIX false positive: tvtoday.de seems to publish "guests: <names>" here some (rare) times :-(  
	   && $data[2] =~ m/^Mit (.*?)$/) {
	    my $actors = $1; #- BUGFIX, cache $1 as $actors

	    # $data[0] --> sub title of show
	    # $data[1] --> genre, may be "<genre>, <country> <year" 
	    # $data[2] --> actors

	    #for ($data[0]) { s/^\s+//; s/\s+$// }
	    s/(^\s|\s$)//g foreach(@data); 
	    $show->{"sub-title"} = [[ $data[0], $lang ]];

	    if($data[1] =~ m/([^,;]+)(?:,\s+([^,;]*)\s+([12][09][0-9]{2}(?:[\/-][0-9]{2})?))?/) {
		my ($cat, $country, $date) = ($1, $2, $3);
		if ($cat =~ /\S/) {
		    $show->{"category"} = [[ $cat, $lang ]];
		}
		else { warn "bad category '$cat'" }

		if (defined $country) {
		    if ($country =~ /\S/) {
			    $show->{"country"} = [[ $country, $lang ]];
		    }
		    else { warn "bad country '$country'" }
		}

		$show->{"date"} = parse_date_data($date) if(defined($date));
	    } 
	    else {
		warn "<genre>(, <country> <year>)? expection not met, THIS SHOULD NOT HAPPEN";
		#-- try to get out here ...
		push @newdesc, $data[1];
	    }

	    my @actors = split(",", $actors); #- BUGFIX: relied on $1, which get's destroyed by insertions above
	    push @{$show->{"credits"}{"actor"}}, @actors;
	} 
	else {
	    foreach (@data) {
		if (m/^Thema: (.*)$/) {
		    push @newdesc, $_, next if($show->{"sub-title"});
		    $show->{"sub-title"} = [[ $1, $lang ]];
		    next;
		}
		    
		if (m/^\(Live\s*(.*)?\)$/) {
		    #-- it's a live show, location: $1 (if defined)
		    push @newdesc, $_; #- xmltv.dtd doesn't support it (yet) -- copy to desc field
		    #undef $_;
		    next;
		}