root/trunk/grabbers/sbsweb

Revision 1390, 15.6 kB (checked in by max, 8 months ago)

shepherd 1.6.0: Change shebang lines from '/usr/bin/perl' to '/usr/bin/env perl', which is more portable (i.e. works on OSX).
  • Property svn:executable set to *
Line 
1#!/usr/bin/env perl
2#
3# sbsweb TV guide grabber
4#
5# Good data, usually 14-21 days, but has a lot of variability
6# in titles & subtitles.
7#
8# Currently only good for the main SBS channel, not SBS News, but
9# has been coded to make adding any future channels easy.
10#
11# to test this file run like this:
12# perl -I /var/lib/mythtv/.shepherd/references/ ~mythtv/.shepherd/grabbers/sbsweb/sbsweb  --channels_file /var/lib/mythtv/.shepherd/channels.conf
13
14my $version = '4.04';
15
16use strict;
17use warnings;
18use Getopt::Long;
19use POSIX;
20use Data::Dumper;
21use IO::File;
22use XMLTV;
23use HTML::TreeBuilder;
24use Shepherd::Common;
25use Encode;
26
27# ---------------------------------------------------------------------------
28# --- Global Variables
29
30my $progname = "sbsweb";
31
32my $DATASOURCE = "sbs.com.au";
33my $URLS = {    'SBS ONE' => "http://www.$DATASOURCE/schedule/SBSONE",
34                'SBS TWO' => "http://www.$DATASOURCE/schedule/SBSTWO" };
35my $lang = 'en';
36my $debug = 0;
37my $channels;
38my $opt_channels;
39my $opt = { };
40my %stats;
41my $shows;
42my $runtime = time;
43my $zerohr;
44my $loc;
45
46# ---------------------------------------------------------------------------
47# --- Setup
48
49print "$progname $version\n";
50
51$| = 1;
52
53&get_command_line_options;
54
55exit 0 if ($opt->{version});
56
57&help if ($opt->{help});
58
59&set_defaults;
60
61&read_channels_file;
62
63unless ($channels)
64{
65    print "ERROR: No channels requested. Please use --channels_file.\n";
66    exit 33;
67}
68
69&set_region;
70
71foreach (keys %$channels)
72{
73    &get_guide_data($_);
74}
75
76&tidy_data;
77
78# print Dumper($shows) if ($debug);
79
80&write_xml;
81
82&Shepherd::Common::print_stats($progname, $version, $runtime, %stats);
83
84&log("Done.");
85exit;
86
87
88# ---------------------------------------------------------------------------
89# --- Subs
90
91sub get_guide_data
92{
93    my $chan = shift;
94
95    &log("Grabbing data for days " . $opt->{offset} .
96         " - " . ($opt->{days} - 1) .
97         ($opt->{output} ? " into " . $opt->{output} : '') .
98         " for channel $chan.");
99
100    # Calculate midnight on day zero in epoch time
101    my @today = localtime($runtime); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
102    $zerohr = $runtime - (($today[0]) + ($today[1]*60) + ($today[2]*60*60));
103
104    my $startday = $opt->{offset};
105    unless (!$startday and $today[2] > 5)
106    {
107        $startday--;
108        &log("Fetching previous day's page for pre-5AM shows.");
109    }
110
111    for my $day ($startday .. ($opt->{days} - 1))
112    { 
113        my $daystr = &POSIX::strftime("%Y-%m-%d", localtime($runtime + ($day * 86400)));
114        &log("Day $day: $daystr");
115
116        my $url = $URLS->{$chan} . "/$daystr/$loc";
117        my $guidedata = &Shepherd::Common::get_url($url);
118        exit 11 unless ($guidedata);
119
120        Encode::from_to($guidedata, "UTF-8", "iso-8859-1");
121
122        &parse_guide($guidedata, $day, $chan);
123    }
124    &log("Found " . &num_items($shows) . " shows on " . scalar(keys %$shows) . " channels.");
125}
126
127sub parse_guide
128{
129    my ($guidedata, $day, $chan) = @_;
130
131    &log("Parsing guide page (Day $day).") if ($debug);
132
133    my $chanid = $channels->{$chan};
134
135    my $tree = HTML::TreeBuilder->new;
136    $tree->no_space_compacting(1);
137    $tree->parse($guidedata);
138    $tree->eof;
139
140    my $last_hr = 0;
141    my $am_pm = 0;
142    my $content = $tree->look_down(_tag => 'div', id => 'content');
143    foreach my $block ($content->look_down(_tag => 'ul', class => 'tv_schedule'))
144    {
145        my $show;
146        foreach my $li ($block->look_down(_tag => 'li'))
147        {
148            my $start = $li->look_down(_tag => 'span', class => 'tv_schedule_time');
149            if ($start)
150            {
151                if ($show->{start})
152                {
153                    $shows->{$chanid}->{$show->{start}} = $show;
154                    $stats{'shows'}++;
155                    $show = undef;
156                }
157
158                my ($hr, $min) = split(/:/, $start->as_text);
159
160                # Times are 12hr clocks: if this hour is less than the last hour
161                # we saw, we must have rolled over AM/PM. So add 12 hours to
162                # the actual time.
163                $am_pm += 12 if ($hr + $am_pm < $last_hr);
164                $hr += $am_pm;
165                $last_hr = $hr;
166
167                $show->{start} = $zerohr + ($day * 86400) + ($hr * 3600) + ($min * 60);
168                $show->{channel} = $chanid;
169            }
170            my $title = $li->look_down(_tag => 'a', class => 'leftpad');
171            if ($title)
172            {
173                $show->{title} = $title->as_text;
174                push (@{$show->{category}}, 'News') if ($show->{title} =~ /News/);
175            }
176            my $desc = $li->look_down(_tag => 'div', class => 'tv_schedule_item_description');
177            if ($desc)
178            {
179                $desc = $desc->look_down(_tag => 'p')->as_text;
180                $desc =~ s/ +$//; # Remove trailing spaces
181                if ($desc =~ /\(Rpt\)/)
182                {
183                    $show->{'previously-shown'} = { };
184                }
185                if ($desc =~ /\bCC\b/)
186                {
187                    push @{$show->{'subtitles'}}, 'teletext';
188                }
189                if ($desc =~ /\bWS\b/)
190                {
191                    $show->{video}->{aspect} = '16:9';
192                }
193                if ($desc =~ s/^Movie: //)
194                {
195                    push @{$show->{category}}, 'movie';
196                }
197                if ($desc =~ /\(Sport\)/)
198                {
199                    push @{$show->{category}}, 'sports';
200                }
201                if ($desc =~ /\((Thriller|Documentary|Drama|[^\(]+ Series)\)/)
202                {
203                    my $cat = $1;
204                    $cat =~ s/ Series$//;
205                    push @{$show->{category}}, $cat;
206                }
207                if ($desc =~ / \(([12]\d\d\d)\) /)
208                {
209                    $show->{date} = $1;
210                }
211                if ($desc =~ /\b(G|PG|M|MA)\b/)
212                {
213                    $show->{rating} = $1;
214                }
215                if ($desc =~ /Directed by (.*?)(?: and| \(|[,\.])/)
216                {
217                    $show->{credits}{director} = [ $1 ];
218                }
219                if ($desc =~ / [sS]tar(?:s|ring) (.*?),? and (.*?)\./)
220                {
221                    $show->{credits}{actor} = [ split(/, /, $1), $2 ];
222                }
223                if ($desc =~ / \(From (.*?), in (.*?)\) /)
224                {
225                    my ($country, $language) = ($1, $2);
226
227                    $country = 'USA' if ($country eq 'the US');
228                    $country = 'UK' if ($country eq 'the UK');
229                    $show->{country} = $country;
230
231                    my @parts = split (/,/, $language);
232                    $show->{language} = $parts[0];
233                    my $lastpart = $parts[scalar(@parts)-1];
234                    if ($lastpart =~ /^ *(.*) subtitles$/)
235                    {
236                        push @{$show->{'subtitles'}}, split(/ and /, $1);
237                    }
238                }
239                $desc =~ s/ +$//; # Remove trailing spaces
240
241                $show->{desc} = $desc;
242            }
243        }
244        $shows->{$chanid}->{$show->{start}} = $show;
245        $stats{'shows'}++;
246    }
247    $tree->delete;
248}
249
250# 1. Calculate stop times
251# 2. Fix errors in title
252# 3. Figure out likely subtitles
253sub tidy_data
254{
255    &log("Tidying data.") if ($debug);
256    foreach my $ch (keys %$shows)
257    {
258        my $last_start_time;
259        foreach my $s (reverse sort keys %{$shows->{$ch}})
260        {
261            # 1. Calculate stop times
262           
263            $shows->{$ch}->{$s}->{stop} = $last_start_time if ($last_start_time);
264            $last_start_time = $shows->{$ch}->{$s}->{start};
265
266            # 2. Guess subtitles.
267
268            # Movies don't have subtitles
269            unless (grep ($_ eq 'movie', @{$shows->{$ch}->{$s}->{category}}))
270            {
271                if ($shows->{$ch}->{$s}->{title} =~ /(.*) (Ep \d+)/i)
272                {
273                    &log("Splitting title for Ep (" .
274                        $shows->{$ch}->{$s}->{title} .
275                        ")") if ($debug);
276
277                    $shows->{$ch}->{$s}->{title} = $1;
278                    $shows->{$ch}->{$s}->{'sub-title'} = $2;
279                }
280                if ($shows->{$ch}->{$s}->{title} =~ /(.*) (?:Series|[12]\d\d\d) \d+/i)
281                {
282                    &log("Stripping series from title (" .
283                         $shows->{$ch}->{$s}->{title} .
284                         ")") if ($debug);
285                    $shows->{$ch}->{$s}->{title} = $1;
286                }
287                if ($shows->{$ch}->{$s}->{title} =~ /(.*) [12]\d\d\d$/i)
288                {
289                    my $title = $1;
290                    if ($title =~ / News/)
291                    {
292                        &log("Stripping year from title (" .
293                            $shows->{$ch}->{$s}->{title} .
294                            ")") if ($debug);
295                        $shows->{$ch}->{$s}->{title} = $title;
296                    }
297                }
298                unless (($shows->{$ch}->{$s}->{'sub-title'}))
299                {
300                    if ($shows->{$ch}->{$s}->{title} =~ /(.*)(?::| -) (.*)/
301                            and
302                        length($1) > 5)
303                    {
304                        &log("Splitting title (" .
305                            $shows->{$ch}->{$s}->{title} .
306                            ")") if ($debug);
307                        $shows->{$ch}->{$s}->{title} = $1;
308                        $shows->{$ch}->{$s}->{'sub-title'} = $2;
309                    }
310                    elsif ($shows->{$ch}->{$s}->{desc} =~ /^(.*?) - (.*)/
311                            and
312                        length($1) < 36
313                            and
314                        grep(/^[A-Z]/, split(/ /, $2)))
315                    {
316                        my ($subtitle, $rest) = ($1, $2);
317
318                        # strip parentheses if they contain entire subtitle
319                        $subtitle = $1 if ($subtitle =~ /^\((.*)\)$/);
320
321                        &log("Splitting desc of " .
322                             $shows->{$ch}->{$s}->{title} .
323                             " (" .
324                             substr($shows->{$ch}->{$s}->{desc}, 0, 38) .
325                             "...)") if ($debug);
326
327                        $shows->{$ch}->{$s}->{desc} = $rest;
328
329                        # Drop subtitle if it's the same as the show name.
330                        # Kinda unfortunate in that occasionally this will
331                        # lead to incorrect dropping, but otherwise we get
332                        # lots of bad subtitles.
333                        unless ($shows->{$ch}->{$s}->{title} =~ /^\Q$subtitle\E$/i)
334                        {
335                            if ($subtitle =~ /^movie\b/i)
336                            {
337                                push @{$shows->{$ch}->{$s}->{category}}, 'movie';
338                            }
339                            else
340                            {
341                                $shows->{$ch}->{$s}->{'sub-title'} = $subtitle;
342                            }
343                        }
344                    }
345                    # Set "Part x of y" as subtitle if nothing better
346                    elsif ($shows->{$ch}->{$s}->{desc} =~ /\((part \d+(?: of \d+))\)/i)
347                    {
348                        $shows->{$ch}->{$s}->{'sub-title'} = $1;
349                    }
350                }
351            }
352
353            # 3. Fix title errors
354
355            if ($shows->{$ch}->{$s}->{title} =~ /(.*) \(([A-Z]{1,2})\)$/)
356            {
357                &log("Dropping rating from title (" .
358                    $shows->{$ch}->{$s}->{title} .
359                    ")") if ($debug);
360                $shows->{$ch}->{$s}->{title} = $1;
361            }
362
363            if ($shows->{$ch}->{$s}->{title} =~ /(.*), (the|le|les|la|l')$/i)
364            {
365                &log("Correcting title (" .
366                     $shows->{$ch}->{$s}->{title} .
367                     ")") if ($debug);
368                $shows->{$ch}->{$s}->{title} = "$2 $1";
369            }
370            if ($shows->{$ch}->{$s}->{title} =~ /(.*) +\(?\*.*\*\)?/)
371            {
372                &log("Stripping title \"" .
373                     $shows->{$ch}->{$s}->{title} .
374                     '"') if ($debug);
375                $shows->{$ch}->{$s}->{title} = $1;
376            }
377
378            # 4. Title & sub-title whitespace tidy
379            $shows->{$ch}->{$s}->{title} = strip_whitespace($shows->{$ch}->{$s}->{title});
380            if ($shows->{$ch}->{$s}->{'sub-title'})
381            {
382                $shows->{$ch}->{$s}->{'sub-title'} = strip_whitespace($shows->{$ch}->{$s}->{'sub-title'});
383            }
384        }
385    }
386}
387
388sub write_xml
389{
390    my %writer_args = ( encoding => 'ISO-8859-1' );
391
392    &log("Writing " . &num_items($shows) . " shows to XML.");
393
394    if ($opt->{output})
395    {
396        my $fh = new IO::File(">" . $opt->{output})
397            or die "Can't open " . $opt->{output} . ": $!";
398        $writer_args{OUTPUT} = $fh;
399    }
400
401    my $writer = new XMLTV::Writer(%writer_args);
402
403    $writer->start
404        ( { 'source-info-url'    => $DATASOURCE,
405            'source-info-name'   => $progname,
406            'generator-info-name' => "$progname $version"} );
407
408    for my $channel (sort keys %$channels)
409    {
410        $writer->write_channel( { 
411                'display-name' => [ [ $channel, $lang ] ],
412                'id' => $channels->{$channel} } );
413    }
414
415    foreach my $ch (sort keys %$shows)
416    {
417        foreach my $s (sort keys %{$shows->{$ch}})
418        {
419            # Don't return shows with no stop time
420            unless ($shows->{$ch}->{$s}->{stop})
421            {
422                &log("-- No stop time: dropping " . 
423                     $shows->{$ch}->{$s}->{title}) if ($debug);
424                next;
425            }
426
427            # Format for XMLTV-compliance
428            my %p = %{$shows->{$ch}->{$s}};
429            foreach my $field ('title', 'sub-title', 'desc', 'country')
430            {
431                $p{$field} = [[ $p{$field}, $lang ]] if ($p{$field});
432            }
433            $p{language} = [ $p{language}, $lang ] if ($p{language});
434            $p{start} = &POSIX::strftime("%Y%m%d%H%M", localtime($p{start}));
435            $p{stop} = &POSIX::strftime("%Y%m%d%H%M", localtime($p{stop}));
436            $p{rating} = [[ $p{rating}, 'ABA', undef ]] if ($p{rating});
437            if ($p{category} && ref($p{category}) eq "ARRAY"
438                    && $p{category}[0] && ref($p{category}[0]) ne "ARRAY") # obsolete 14/10/2007
439            {
440                foreach (@{$p{category}})
441                {
442                    $_ = [ &Shepherd::Common::translate_category($_), $lang ];
443                }
444            }
445            if ($p{subtitles})
446            {
447                my @s;
448                foreach (@{$p{subtitles}})
449                {
450                    push @s, { type => $_ };
451                }
452                $p{subtitles} = [ @s ];
453            }
454            $p{desc} = [ ] unless ($p{desc});
455            delete $p{pid};
456            delete $p{details};
457
458            if ($debug)
459            {
460                &log("-> " . $shows->{$ch}->{$s}->{title} .
461                     ($shows->{$ch}->{$s}->{'sub-title'} ?
462                      ' ("' . $shows->{$ch}->{$s}->{'sub-title'} . '")' : ''));
463            }
464#           print Dumper(\%p);
465            $shows->{$ch}->{$s}->{start} = &POSIX::strftime("%Y%m%d%H%M", localtime($s));
466            if(length($shows->{$ch}->{$s}->{title})) {
467               $writer->write_programme(\%p);
468            }else{
469                &log( "ignoring bad title data for program with start time" . $shows->{$ch}->{$s}->{start} ."\n");
470            }
471           
472        }
473    }
474
475    $writer->end();
476}
477
478# ---------------------------------------------------------------------
479# Helper subs
480
481sub num_items
482{
483    my $hash = shift;
484    my $count = 0;
485    foreach my $ch (keys %$hash)
486    {
487        $count += scalar keys %{$hash->{$ch}};
488    }
489    return $count;
490}
491
492sub strip_whitespace 
493{
494    $_[0] =~ /^\s*(.*?)\s*$/ ? $1 : $_[0];
495}
496
497# ---------------------------------------------------------------------
498# Setup subs
499
500sub set_region
501{
502    # Not totally sure about these regions... is regional NSW 'Sydney'
503    # or 'Regional'?
504    my $state = Shepherd::Common::which_state($opt->{region});
505    $loc = 'SBS Sydney'     if ($state eq 'NSW' or $state eq 'ACT');
506    $loc = 'SBS Melbourne'  if ($state eq 'VIC');
507    $loc = 'SBS Brisbane'   if ($state eq 'QLD');
508    $loc = 'SBS Adelaide'   if ($state eq 'SA');
509    $loc = 'SBS Darwin'     if ($state eq 'NT');
510    $loc = 'SBS Tasmania'   if ($state eq 'TAS');
511    $loc = 'SBS Perth'      if ($state eq 'WA');
512
513    unless ($loc)
514    {
515        &log("Error: No valid location? Using default/national times.");
516        $loc = '';
517    }
518
519    &log("Location: $loc") if ($debug);
520}
521
522
523sub get_command_line_options
524{
525    &Getopt::Long::Configure('pass_through');
526    &GetOptions($opt, qw(
527                            help
528                            debug
529                            output=s
530                            do-extra-days
531                            days=i
532                            offset=i
533                            region=i
534                            channels_file=s
535                            version
536                        ));
537    $debug = $opt->{debug};
538
539    if (@ARGV)
540    {
541        &log("\nUnknown option(s): @ARGV\n");
542    }
543}
544
545sub set_defaults
546{
547    my $defaults = {
548        'days' => 7,
549        'offset' => 0,
550        'region' => 94,
551        'output' => &getcwd . '/output.xmltv',
552        'channels_file' => &getcwd . '/channels.conf'
553    };
554
555    if (defined $opt->{'do-extra-days'}) {
556    $opt->{'days'} = 21;
557    }
558
559    foreach (keys %$defaults)
560    {
561        unless (defined $opt->{$_})
562        {
563            $opt->{$_} = $defaults->{$_};
564        }
565    }
566
567    $opt->{'days'} = 31 if ($opt->{'days'} > 31);
568
569    &Shepherd::Common::set_defaults(
570        stats => \%stats,
571        delay => "1-5",
572        debug => $debug,
573        webwarper => $opt->{warper}
574        );
575
576    # Initialize stats
577    %stats = ( );
578    foreach (qw( shows ))
579    {
580        $stats{$_} = 0;
581    }
582}
583
584sub read_channels_file 
585{
586    &read_config_file('channels', 'channels_file');
587    unless ($channels)
588    {
589        print "ERROR: No channels requested. Please use --channels_file.\n";
590        exit 33;
591    }
592    foreach (keys %$channels)
593    {
594        unless ($_ eq 'SBS ONE' or $_ eq 'SBS TWO')
595        {
596            &log("Ignoring unsupported channel $_.");
597            delete $channels->{$_};
598        }
599    }
600    unless (keys %$channels)
601    {
602        &log("ERROR: No supported channels requested. Exiting.");
603        exit 22;
604    }
605
606}
607
608sub read_config_file
609{
610    my ($name, $arg) = @_;
611
612    return unless ($opt->{$arg});
613    &log("Reading $name file: $opt->{$arg}");
614    if (-r $opt->{$arg})
615    {
616        local (@ARGV, $/) = ($opt->{$arg});
617        no warnings 'all';
618        eval <>;
619        die "Can't parse $name file: $@" if ($@);
620    }
621    else
622    {
623        &log("Unable to read $name file.");
624    }
625}
626
627sub log
628{
629    &Shepherd::Common::log(@_);
630}
631
632sub help
633{
634    print q{
635Command-line options:
636  --help                 Print this message
637  --version              Show current version
638
639  --output <file>        Write XML into the specified file
640  --channels_file <file> Read channel subscriptions from file
641
642  --region <n>           Grab data for region code <n>
643  --days <n>             Grab <n> days of data (today being day 1)
644  --do-extra-days        Grab up to 21 days of data
645
646  --offset <n>           Skip the first <n> days
647
648  --debug                Print lots of debugging output
649};
650    exit 0;
651}
Note: See TracBrowser for help on using the browser.