root/trunk/grabbers/sbsweb @ 1269

Revision 1269, 15.0 kB (checked in by max, 3 years ago)

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