xmltv-util 0.5.63-2 / usr / bin / tv_grab_dk_dr

#!/usr/bin/perl -w

eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell

eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell

# $Id: tv_grab_dk_dr,v 1.8 2010/10/04 20:54:13 dekarl Exp $

=pod

=head1 NAME

tv_grab_dk_dr - Grab TV listings for Denmark.

=head1 SYNOPSIS

tv_grab_dk_dr --help

tv_grab_dk_dr --configure [--config-file FILE] [--gui OPTION]

tv_grab_dk_dr [--config-file FILE] [--output FILE] [--days N]
[--offset N] [--quiet]

tv_grab_dk_dr --capabilities

tv_grab_dk_dr --version

=head1 DESCRIPTION

Output TV listings for several channels available in Denmark.  The
data comes from dr.dk. The grabber relies on parsing HTML so it might
stop working at any time.

First run B<tv_grab_dk_dr --configure> to choose, which channels you want
to download. Then running B<tv_grab_dk_dr> with no arguments will output
listings in XML format to standard output.

B<--configure> Prompt for which channels, and write the configuration file.

B<--config-file FILE> Set the name of the configuration file, the
default is B<~/.xmltv/tv_grab_dk_dr.conf>.  This is the file written by
B<--configure> and read when grabbing.

B<--gui OPTION> Use this option to enable a graphical interface to be used.
OPTION may be 'Tk', or left blank for the best available choice.
Additional allowed values of OPTION are 'Term' for normal terminal output
(default) and 'TermNoProgressBar' to disable the use of Term::ProgressBar.

B<--output FILE> Write to FILE rather than standard output.

B<--days N> Grab N days.  The default is one week.

B<--offset N> Start N days in the future.  The default is to start
from today.

B<--quiet> Suppress the progress messages normally written to standard
error.

B<--capabilities> Show which capabilities the grabber supports. For more
information, see L<http://wiki.xmltv.org/index.php/XmltvCapabilities>

B<--version> Show the version of the grabber.

B<--help> Print a help message and exit.

=head1 SEE ALSO

L<xmltv(5)>.

=head1 AUTHOR

This version of tv_grab_dk_dr was written by Thomas Horsten <thomas at horsten dot com>

=cut

use strict;
use warnings;

use XMLTV;
use XMLTV::ProgressBar;
use XMLTV::Options qw/ParseOptions/;
use XMLTV::Configure::Writer;

use Data::Dumper;
use IO::Scalar;
use Parse::RecDescent;
use LWP;

use DateTime;

my $ua = LWP::UserAgent->new;
$ua->agent("xmltv/$XMLTV::VERSION");

my $grabber_name = 'tv_grab_dk_dr';
my $id_prefix = '.dr.dk';

my $default_root_url = 'http://www.dr.dk/tjenester/programoversigt/';

my %grabber_tags = ( 'source-info-url'	   =>
		     'http://www.dr.dk/tjenester/programoversigt/',
		     'source-info-name'	   =>
		     'DR TV Oversigt',
		     'generator-info-name' =>
		     'XMLTV',
		     'generator-info-url'  =>
		     'http://niels.dybdahl.dk/xmltvdk/',
    );

# Time zone the server uses
my $server_tz = 'Europe/Copenhagen';

# Language ID's used in the channel info's country_code field,
# we use it to choose default language of program titles etc.
my %dr_language_codes = (
    '1' => 'da',
    '2' => 'sv',
    '3' => 'no',
    '4' => 'fr',
    '6' => 'en',
    '7' => 'de'
    );

my $warnings = 0;

my $opt;
my $conf;

sub main()
{
    ( $opt, $conf ) = ParseOptions( {
	grabber_name => $grabber_name,
	capabilities => [qw/baseline manualconfig tkconfig apiconfig/],
	stage_sub => \&config_stage,
	listchannels_sub => \&list_channels,
	#load_old_config_sub => \&load_old_config,
	version => '$Id: tv_grab_dk_dr,v 1.8 2010/10/04 20:54:13 dekarl Exp $',
	description => "TV Oversigten fra Danmarks Radios ".
	    "(www.dr.dk/tjenester/programoversigt)",
				      } );

    if (not defined( $conf->{'root-url'} )) {
	print STDERR "Root URL not defined in configfile " .
	    $opt->{'config-file'} . "\n" .
	    "Please run the grabber with --configure.\n";
	exit 1;
    }

    if (not defined( $conf->{'accept-copyright-disclaimer'} )) {
	print STDERR "Copyright disclaimer not defined in configfile " .
	    $opt->{'config-file'} . "\n" .
	    "Please run the grabber with --configure.\n";
	exit 1;
    }

    if ($conf->{'accept-copyright-disclaimer'}[0] ne 'accept') {
	print STDERR
	    "You have to accept the copyright disclaimer " .
	    "if you want to use this\n" .
	    "program. Please run the grabber with " .
	    "--configure to change options.\n";
	exit 1;
    }

    if (not defined( $conf->{'channel'} )) {
	print STDERR "No channels selected in configfile " .
	    $opt->{'config-file'} . "\n" .
	    "Please run the grabber with --configure.\n";
	exit 1;
    }

    my %writer_args = ( encoding => 'utf-8' );
    if (defined $opt->{'output'}) {
	my $fh = new IO::File ">".$opt->{'output'};
	die "Cannot write to $opt->{'output'}" if not $fh;
	$writer_args{'OUTPUT'} = $fh;
    }
    my $writer = new XMLTV::Writer(%writer_args);

    $writer->start(\%grabber_tags);

    #print "Grabbing channel list\n";
    my $chanlist = &get_channel_list($conf) || die "Couldn't get channel list";

    # Check channels specified are valid
    my @channels = ();
    foreach my $cid (@{$conf->{'channel'}}) {
	my $chan = $chanlist->{$cid};
	if (!$chan) {
	    &warning("Unknown channel ".$cid." in config file\n");
	} else {
	    $writer->write_channel($chan);
	    push (@channels, $cid);
	}
    }

    my $date = DateTime->today('time_zone'=>$server_tz);
    $date->add(days=>$opt->{'offset'});

    my $dates_available = &get_available_dates();

    for (my $c=0; $c<$opt->{'days'}; $c++) {
	my $fmtdate = $date->strftime("%Y-%m-%d");

	if (!$dates_available->{$fmtdate}) {
	    &warning("No data for $fmtdate\n");
	} else {
	    #print "Grabbing data for: $fmtdate\n";
	    #print Dumper $conf->{'channel'};
	    foreach my $cid (@channels) {
		my $chan = $chanlist->{$cid};
		if (!$chan) {
		    &warning("Unknown channel $cid\n");
		} else {
		    #print "ID: $cid Name: " .
		    	#$chan->{'display-name'}[0][0]."\n";
		    my $schedules = get_schedules($chan, $fmtdate);
		    if ("ARRAY" ne ref($schedules)) {
			&warning("Schedules for $cid on $fmtdate not valid - empty?\n");
			next;
		    }
		    foreach my $s (@$schedules) {
			#print Dumper $s;
			if ("HASH" ne ref($s)) {
			    warn("Weird listing:\n");
			    print STDERR Dumper $s;
			} else {
			    $writer->write_programme($s);
			}
		    }
		}
	    }
	}

	$date->add(days=>1);
    }
    $writer->end();
    exit 0 unless $warnings != 0;
    print STDERR "$warnings warnings\n";
    exit 1;
}

sub warning($)
{
    print STDERR "WARNING: " . join(' ',@_);
    $warnings++;
}

sub geturl($)
{
    my( $url ) = @_;

    my $request = HTTP::Request->new('GET');
    $request->url($url);
    my $response = $ua->request($request);
    return $response->content;
}

sub config_stage
{
    my( $stage, $conf ) = @_;
    my $result;

    $stage eq "start" || die "Unknown stage $stage";

    my $writer = new XMLTV::Configure::Writer( OUTPUT => \$result,
					       encoding => 'utf-8' );
    if( $stage eq 'start' ) {
	$writer->start( { grabber => $grabber_name } );
	$writer->start_selectone( {
	    id => 'accept-copyright-disclaimer',
	    title => [ [ 'Acceptér ansvarsfraskrivelse', 'da'],
		       [ 'Accept disclaimer', 'en'] ],
	    description => [ [ "Data fra DR's programoversigt er " .
			       "beskyttet af loven om ophavsret, " .
			       "og må kun anvendes til personlige, " .
			       "ikke-kommercielle formål. " .
			       "Dette programs forfatter(e) kan ikke " .
			       "holdes ansvarlig for evt. misbrug.", 'da' ],
			     [ "Data from DR's program guide is " .
			       "protected by copyright law and may " .
			       "only be used for personal, non-commercial " .
			       "purposes. The author(s) " .
			       "of this program accept no responsibility " .
			       "for any mis-use.",
			       'en' ] ] } );
	$writer->write_option( {
	    value=>'reject',
	    text=> [ [ 'Jeg accepterer IKKE betingelserne', 'da'],
		     [ 'I do NOT accept these conditions', 'en'] ] } );
	$writer->write_option( {
	    value=>'accept',
	    text=> [ [ 'Jeg accepterer betingelserne', 'da'],
		     [ 'I accept these conditions', 'en'] ] } );
	$writer->end_selectone();
	$writer->start_selectone( {
	    id => 'include-radio',
	    title => [ [ 'Medtag radio-kanaler', 'da'],
		       [ 'Include radio channels', 'en'] ],
	    description => [ [ "DR's programoversigt indeholder " .
			       "radiokanaler, du kan her vælge " .
			       "om de skal medtages i listen.", 'da' ],
			     [ "DR's program guide includes radio " .
			       "channels, here you can choose whether " .
			       "to include them.", 'en' ] ] } );
	$writer->write_option( {
	    value=>'0',
	    text=> [ [ 'Udelad radio-kanaler', 'da'],
		     [ 'Exclude radio channels', 'en'] ] } );
	$writer->write_option( {
	    value=>'1',
	    text=> [ [ 'Medtag radio-kanaler', 'da'],
		     [ 'Include radio channels', 'en'] ] } );
	$writer->end_selectone();
	$writer->write_string( {
	    id => 'root-url',
	    title => [ [ 'Root URL for grabbing data', 'en' ],
		       [ 'Grund-URL for grabberen', 'da' ] ],
	    description => [ [ 'Provide the URL of DR\'s program guide ' .
			       'data data engine, ' .
			       'including the trailing slash.', 'en' ],
			     [ 'Indtast URL\'en på DR\'s tv-oversigs data ' .
			       'engine, inklusive den ' .
			       'efterfølgende skråstreg.', 'da' ] ],
	    default => $default_root_url } );
    }
    $writer->end( 'select-channels' );

    return $result;
}

sub list_channels($$)
{
    my( $conf, $opt ) = @_;
    my $chanlist = &get_channel_list($conf);
    #print Dumper $chanlist;
    my $result="";
    my $fh = new IO::Scalar \$result;
    my $oldfh = select( $fh );
    my $writer = new XMLTV::Writer(OUTPUT => $fh, encoding => 'utf-8');
    $writer->start(\%grabber_tags);
    $writer->write_channels($chanlist);
    $writer->end();
    select( $oldfh );
    $fh->close();

    #print "RESULT:\n$result\n";
    return $result;
}

sub get_available_dates()
{
    my ( $chan, $date ) = @_;

    my @schedules = ();

    my $url = $conf->{'root-url'}->[0] .
	'DBService.ashx/availableBroadcastDates';
    #print "Get: $url\n";
    my $content = geturl($url) || return 0;
    #print STDERR $content. "\n";
    my $parsed = &parse(\$content) || die "Error parsing date list";
     #print Dumper $parsed;
     my %available_dates = ();
     for (@{$parsed->{'result'}})
     {
	#print "Date: $_\n";
	m/^([0-9]+-[0-9]+-[0-9]+).*/;
	$available_dates{$1} = 1;
     }
     return \%available_dates;
}

sub get_schedules($$)
{
    my ( $chan, $date ) = @_;

    my @schedules = ();

    my $src = $chan->{'_source_url'};
    $src =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
    my $url = $conf->{'root-url'}->[0] .
	'DBService.ashx/getSchedule?channel_source_url=' .
	$src . '&broadcastDate=' .$date . "&random=".rand();
    #print "Get: $url\n";
    my $content = geturl($url) || return 0;
    my @results = ();
    my $parsed = &parse($content);
    if ((!$parsed) || ("HASH" ne ref ($parsed)) )  { # ||
		#	("ARRAY" ne ref(@$parsed->{'result'})))) {
	&warning("(BUG?) Parser barfed while processing channel " .
		 $chan->{'_name'}. " date ". $date . " (empty result?) URL: $url\n");
	print STDERR "Content: $content\n";
	print STDERR Dumper $parsed;
	return \@results;
    } elsif ( ("ARRAY" ne ref ($parsed->{'result'} )) ) {
	    &warning("(BUG?) Parser barfed while processing channel " .
		    $chan->{'_name'}. " date ". $date . " (empty result?) URL: $url\n");
	    &warning("Result type: " . ref ($parsed) . "\n");
	    print STDERR "Content: $content\n";
	    print STDERR Dumper $parsed;
	return \@results;
    }
    if ( !@{$parsed->{'result'}} ) {
	&warning("Empty result for \"".
	       $chan->{'_name'}. "\" (".$chan->{'id'}.") date ". $date . "\n");
	return \@results;
    }
    foreach my $listing (@{$parsed->{'result'}}) {
	my %p = ();
	# Delete things that we don't want to use before dumping
	# This way we can see if we're missing something useful..
	#delete $listing->{'ppu_islive'}; # Always "1"..
	#delete $listing->{'prd_is_own_production'}; # Always "true"..
	#print STDERR Dumper $listing;
	# attributes
	$p{'channel'} = $chan->{'id'};
	$p{'start'} = dr_date_to_xml($listing->{'pg_start'});
	$p{'stop'} = dr_date_to_xml($listing->{'pg_stop'});
	# elements

	########################################
	# Episode
	# $episode_match fjerner (x:y) eller (x)
	# fra titler hvor episode nummeret allerede
	# er gemt i det dertil indrettede felt
	my $episode_match = '';
	if ($listing->{'prd_episode_total_number'} &&
	    $listing->{'prd_episode_number'}) {
	    $p{'episode-num'} = [ [ " . " .
				    ($listing->{'prd_episode_number'} - 1) .
				    "/" .
				    ($listing->{'prd_episode_total_number'}) .
				    " . ", "xmltv_ns" ] ];
	    $episode_match = " \\(" . $listing->{'prd_episode_number'} . ":" .
		$listing->{'prd_episode_total_number'} . "\\)";

	} elsif ($listing->{'prd_episode_number'}) {
	    $p{'episode-num'} = [ [ " . " .
				    ($listing->{'prd_episode_number'} - 1) .
				    " . ", "xmltv_ns" ] ];
	    $episode_match = " \\(" . $listing->{'prd_episode_number'} . "\\)";
	}

	########################################
	# Titel
	# Sprog gættes fra kanalens landekode.
	# Hvis der er en alternativ titel ser vi om
	# sproget fremgår af undertitlen, ellers gætter
	# vi på engelsk..
	#
	# Rettelse: Der er rent faktisk nogen der har
	# oversat alle TV5's titler til dansk, så den
	# "alternative" titel er dansk for alle disse
	# programmer mens standard titlen er på
	# originalsproget. Weird. Men det gælder kun
	# TV5 så jeg har ikke giddet fixe det når jeg
	# alligevel aldrig kunne finde på at se fransk
	# TV :)
	my @title;
	my $t = $listing->{'ppu_title'};
	if ($episode_match ne '') {
	    #print "EpMatch: $episode_match\n";
	    $t =~ s/$episode_match$//;
	}
	push (@title, [ $t, $chan->{'_lang'} ]);
	if ($listing->{'ppu_title_alt'}) {
	    my $original_lang = guess_original_language($listing);
	    if (!$original_lang) {
		$original_lang = 'en';
	    }
	    push (@title, [ $listing->{'ppu_title_alt'}, $original_lang ]);
	}
	$p{'title'} = \@title;

	########################################
	# Undertitel
	if ($listing->{'ppu_punchline'}) {
	    my $pl = $listing->{'ppu_punchline'};
	    # Der er nogle gange linjeskift i
	    # punchlines, hvilket XMLTV ikke bryder
	    # sig om...
	    $pl =~ s/\s*\n\s*/ - /g;
	    $p{'sub-title'} = [ [ $pl,
				  $chan->{'_lang'} ] ];
	}

	########################################
	# Beskrivelse
	if ($listing->{'ppu_description'}) {
	    $p{'desc'} = [ [ $listing->{'ppu_description'},
				  $chan->{'_lang'} ] ];
	}

	########################################
	# Credits
	#if ($listing->{'ppu_credits'}) {
	#    $p{'desc'} = [ [ $listing->{'ppu_description'},
	#			  $chan->{'_lang'} ] ];
	#}

	########################################
	# Genudsendelse
	if ($listing->{'ppu_isrerun'} eq 'true') {
	    $p{'previously-shown'} = {};
	}

	########################################
	# Genre/kategori
	# Her bruges genre_text, vi kunne også
	# bruge genre_code og have en tabel
	# til at få i det mindste den generelle
	# kategori på engelsk (farver i MythTV!)
	# TODO: Fix engelske kategorier
	if ($listing->{'prd_genre_text'} &&
	    $listing->{'prd_genre_text'} ne 'Ukategoriseret' &&
	    $listing->{'prd_genre_text'} ne 'Andre') {
	    $p{'category'} = [ [ $listing->{'prd_genre_text'}, 'da']];
	}

	########################################
	# URL
	if ($listing->{'ppu_www_url'}) {
	    $p{'url'} = [ $listing->{'ppu_www_url'} ];
	}

	########################################
	# Video info (kun i DR's programmer)
	# 16:9 eller 4:3
	if ($listing->{'ppu_video'}) {
	    if ($listing->{'ppu_video'} eq 'HD') {
		$p{'video'}{'aspect'} = '16:9';
		$p{'video'}{'quality'} = 'HDTV';
	    } else {
		$p{'video'}{'aspect'} = $listing->{'ppu_video'};
	    }
	}

	########################################
	# Undertekster
	if ($listing->{'ppu_subtext_type'}) {
	    if ($listing->{'ppu_subtext_type'} =~ '^TTV' ||
		$listing->{'ppu_subtext_type'} eq 'EXTERN') {
		push @{$p{subtitles}},{type=>'teletext'};
	    } elsif ($listing->{'ppu_subtext_type'} ne 'NOTXT') {
		push @{$p{subtitles}},{type=>'onscreen'};
	    }
	}

	########################################
	# Credits
	if ($listing->{'ppu_credits'}) {
	    my $credits = parse_dr_credits($listing->{'ppu_credits'});
	    if ($credits) {
		$p{'credits'} = $credits;
	    }
	}


	# Sanity checks..
	if (!$p{'start'}) { &warning("No 'START' attribute"); next; }
	if (!$p{'stop'}) { &warning("No 'START' attribute"); next; }
	if (!$p{'title'}) { &warning("No 'TITLE' attribute"); next; }

	#print Dumper \%p;
	push(@results, \%p);
    }
    return \@results;
}

sub parse_dr_credits($)
{
    my ( $input ) = @_;
    my %c = ();

    #print "\nInput: $input\n";

    my $director;
    ( $director ) = $input =~ m/Instruktion:\s*(.*)/;
    if ($director) {
	$input =~ s/\s*Instruktion:.*//;
	$director =~ s/.?\s*$//;
    }
    #print "Director: " . $director . "\n" if $director;
    $c{'director'} = [ $director ] if $director;
    my @actors = ();
    my ( $actorlist ) = $input =~ /Medvirkende:\s*(.*)\s*/;
    if ($actorlist) {
	for my $entry (split(/\s*(?:og|,)\s*/, $actorlist)) {
	    #print "ENTRY: '$entry'\n";
	    if ($entry =~ m/(.*?)\s*:\s*(.*?)\.?\s*$/) {
		#print "Actor: $2 Role: $1\n";
		# Her smider vi rollenavnet væk selvom
		# XMLTV understøtter det som attribute.
		# Desværre understøtter xmltv.pm det ikke :(
		#push(@actors, [ $2, $1 ]);
		push(@actors, $2);
	    } else {
		#print "Actor: $entry\n";
		push(@actors, $entry);
	    }
	}
    }
    if (@actors) {
	$c{'actor'} = \@actors;
    }
    #print Dumper \%c;
    return \%c;
}

# Her udnytter vi at der i ppu_punchline tit står
# "Amerikansk serie", "Fransk dokumentar" etc..
# Listen er ikke komplet men jeg har medtaget de
# fleste jeg tror vil forekomme.. Listen er fra
# http://en.wikipedia.org/wiki/List_of_ISO_639-1_codes
sub guess_original_language($)
{
    my ( $listing ) = @_;

    my $s = $listing->{'ppu_punchline'};
    if ($s) {
	return "bg" if $s =~ /^Bulgarsk /;
	return "bs" if $s =~ /^Bosnisk /;
	return "cz" if $s =~ /^Tjekkisk /;
	return "de" if $s =~ /^Tysk /;
	return "el" if $s =~ /^Græsk /;
	return "es" if $s =~ /^Spansk /;
	return "et" if $s =~ /^Estisk /;
	return "fi" if $s =~ /^Finsk /;
	return "fr" if $s =~ /^Fransk /;
	return "fr" if $s =~ /^Fransk-/; # Fransk-Belgisk, Fransk-Canadisk...
	return "hi" if $s =~ /^Indisk /;
	return "hr" if $s =~ /^Kroatisk /;
	return "hu" if $s =~ /^Ungarnsk /;
	return "hy" if $s =~ /^Armensk /;
	return "id" if $s =~ /^Indonesisk /;
	return "is" if $s =~ /^Islandsk /;
	return "it" if $s =~ /^Italiensk /;
	return "ja" if $s =~ /^Japansk /;
	return "ka" if $s =~ /^Georgisk /;
	return "kk" if $s =~ /^Kazakstansk /;
	return "ko" if $s =~ /^Koreansk /;
	return "ku" if $s =~ /^Kurdisk /;
	return "lt" if $s =~ /^Litauisk /;
	return "lv" if $s =~ /^Lettisk /;
	return "my" if $s =~ /^Burmesisk /;
	return "nl" if $s =~ /^Belgisk /;
	return "nl" if $s =~ /^Hollandsk /;
	return "no" if $s =~ /^Norsk /;
	return "pl" if $s =~ /^Polsk /;
	return "pt" if $s =~ /^Portugisisk /;
	return "ru" if $s =~ /^Russisk /;
	return "sk" if $s =~ /^Slovakisk /;
	return "sl" if $s =~ /^Slovensk /;
	return "so" if $s =~ /^Somalisk /;
	return "sq" if $s =~ /^Albansk /;
	return "sr" if $s =~ /^Serbisk /;
	return "sv" if $s =~ /^Svensk /;
	return "tr" if $s =~ /^Tyrkisk /;
	return "ty" if $s =~ /^Tahitiansk /;
	return "uk" if $s =~ /^Ukrainsk /;
	return "vi" if $s =~ /^Vietnamesisk /;
	return "zh" if $s =~ /^Kinesisk /;
    }
    return 0;
}


sub dr_date_to_xml($)
{
    # 2009-06-13T12:34:56.0000000+02:00 ->
    # 20090613123456 +0200
    my ($d) = @_;
    if ($d =~
	m|^([0-9]+)-([0-9]+)-([0-9]+)T([0-9]+):([0-9]+):([0-9]+)\.[0-9]+\+([0-9]+):([0-9]+)|) {
	$d = $1.$2.$3.$4.$5.$6.' +'.$7.$8;
	#print "d: $d\n";
	return $d;
    } else {
	return 0;
    }
}

sub get_channel_list($)
{
    my ( $conf ) = @_;
    my $drlist = get_dr_channel_list($conf);
    #print Dumper $drlist;
    my %chanlist = ();
    foreach my $chan (@$drlist) {
	my $shortid = $chan->{'source_url'};
	$shortid =~ s/^.*\///;
	my $id = $shortid . $id_prefix;
	# tv_validate_file barfs if ID contains + as for d3+.dr.dk
	$id =~ s/\+/plus/g;
	$chanlist{$id}->{'id'} = $id;
	$chanlist{$id}->{'icon'} = [{ 'src'=>$conf->{'root-url'}->[0] .
					 "Images/Logos/" . $shortid .
					 ".gif" }];
	$chanlist{$id}->{'_source_url'} = $chan->{'source_url'};
	my $chan_lang = $dr_language_codes{$chan->{'country_code'}};
	$chan_lang = 'da' unless $chan_lang;
	$chanlist{$id}->{'_lang'} = $chan_lang;
	$chanlist{$id}->{'display-name'} =
	    [ [ $chan->{'name'}, $chan_lang ]];
	$chanlist{$id}->{'_name'} = $chan->{'name'};
    }

    return \%chanlist;
}

sub get_dr_channel_list($)
{
    my ( $conf ) = @_;
    my @types = ('TV');
    if ($conf->{'include-radio'}[0] eq '1') {
	push (@types, 'RADIO');
    }
    my @results = ();
    foreach my $type (@types) {
	#print "TYPE: $type\n";
	my $url = $conf->{'root-url'}->[0] .
	    'DBService.ashx/getChannels?type=' . $type;
	#print STDERR "Get: $url\n";
	my $content = geturl($url) || return 0;
	#print STDERR "Content: $content\n";
	my $parsed = &parse(\$content) || die "Error parsing channel list";
	#print STDERR Dumper $parsed;
	push(@results, @{$parsed->{'result'}});
    }
    return \@results;
}

sub fix_string($)
{
    # \" => "
    # \n => newline
    # \t => tab? har set en enkelt. fjerner.
    my ( $str ) = @_;
    $str =~ s/\\n/\n/g;
    $str =~ s/\\t//g;
    $str =~ s/\\"/"/g;
    if ($str =~ m/\\/) {
	&warning("Weird string: $str\n");
    }
    return $str;
}

sub parse($)
{
    $::RD_HINT = 1;

    my $grammar = <<'EO_GRAMMAR';
    #<autotree>
    # TODO: Parseren fejler hvis serveren returnerer
    # et tomt resultat for en getSchedule. Check
    # output og ret grammar.
	document : object
	object : '{'  field(s? /,/) '}'
	  { $return = { map { %$_ } @{$item{'field(s?)'}} }; }
	field : '"' key '":' value
	  { $return = { $item{'key'} => $item{'value'} }; 1}
	key : /[^"]+/
	  { $return = $item[1]; 1}
	value :  object
	  | list
	  | quotedstring
	    { $return = $item[1]; 1}
	  | literal
	    { $return = $item[1]; 1}
        list :  '[]'
	    { $return = []; 1}
          | '[' value(s? /,/) ']'
	    { $return = $item{'value(s?)'};}
	quotedstring : '"' /(?:[^\\"]|\\.)*/ '"'
	  { $return = ::fix_string($item[2]); 1}
	literal : /[^,]+/
	  { $return = $item[1]; 1}

EO_GRAMMAR

    my $parser = Parse::RecDescent->new($grammar)
    or die "Could not parse grammar: $@";

    return $parser->document($_[0]);
}

&main;