root/shepherd @ 33

Revision 33, 57.3 kB (checked in by lincoln, 7 years ago)

fix language tags in write_channel xml output, fix input_postprocess_file filename
Line 
1#!/usr/bin/perl -w
2
3# "Shepherd"
4
5my $version = '0.2.8';
6
7# A wrapper for various Aussie TV guide data grabbers
8#
9# Use --help for command-line options.
10# See shepherd.txt for details.
11#
12#  A current version of this script, plus a README file, might be here:
13#  http://www.whuffy.com/tv_grab_au/
14#
15# Changelog:
16# 0.1.0   : Basic self-updating and grabber management
17# 0.2.0   : --configure
18# 0.2.1   : Has a home in ~/.shepherd/
19# 0.2.2   : --check
20# 0.2.3   : Bugfix: archives correctly
21# 0.2.5   : Multi-grabber (potentially with partial data)
22# 0.2.6   : Postprocessor support
23# 0.2.7   : Changed online file structure
24# 0.2.8   : Integrated reconciler
25
26BEGIN { *CORE::GLOBAL::die = \&my_die; }
27
28use strict;
29
30use LWP::Simple;
31use Sort::Versions;
32use Cwd;
33use Getopt::Long;
34use Data::Dumper;
35use XMLTV;
36use XMLTV::Ask;
37use DateTime::Format::Strptime;
38use POSIX qw(strftime);
39use Time::HiRes qw(gettimeofday tv_interval);
40
41# ---------------------------------------------------------------------------
42# --- Global Variables
43# ---------------------------------------------------------------------------
44
45my $progname = 'shepherd';
46
47my $HOME = 'http://www.whuffy.com/shepherd';
48
49my $invoked = Cwd::realpath($0);
50
51# By default, Shepherd runs from ~/.shepherd/. If it's not run as a user,
52# it will try /opt/shepherd/ instead.
53my $CWD = ($ENV{HOME} ? $ENV{HOME} . "/." : "/opt/") . $progname;
54-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
55chdir($CWD);
56
57my $GRABBER_DIR = "$CWD/grabbers";
58my $POSTPROCESSOR_DIR = "$CWD/postprocessors";
59my $ARCHIVE_DIR = "$CWD/archive";
60
61
62#### analyzer settings ####
63
64my $timeslot_size = (15 * 60);                  # 15 minute slots
65my $channel_ok_threshold_percent = 90;          # 90% these may need to be
66                                                # tweaked but look ok for now
67my $postprocessor_ok_threshold_percent = 80;    # 80% these may need to be
68                                                # tweaked but look ok for now
69my $postprocessor_disable_failure_threshold = 5;# number of times a
70                                                # postprocessor has to fail
71                                                # in a row before it is
72                                                # automatically disabled
73
74#### reconciler settings ####
75my %reclogic;
76
77# when setting the upper-bounds of a timeslot to look for overlapping
78# programmes between grabbers, cap the upper time window that we are prepared
79# to tolerate programmes ending within.
80# disabled by default (max overrides percent for upper bounds)
81
82$reclogic{compare_overlapping_programmes_extra_overtime_duration_percent} = 5;
83$reclogic{compare_overlapping_programmes_extra_overtime_max} = 0;
84
85# if there is a conflict between two grabbers, choose the grabber
86# with the MOST programmes in the timeslot WITHOUT COUNTING
87# any programmes of <= $reclogic{min_time_override_for_duplicate}
88
89$reclogic{min_time_override_for_duplicate} = (5 * 60);  # default = 5 minutes
90
91# when we've selected one grabber to insert data from, we look at all the other
92# grabbers for overlapping fields we can use to augment our primary grabber
93# set some thresholds for when to consider programming to be the 'same'
94# (with fuzz -/+ 5 mins max), -/+ 2.5mins for programmes <= 15 mins
95
96$reclogic{duplicate_programme_augment_data_short_cutoff} = (15*60); # <=15mins = short, >15mins = long
97$reclogic{duplicate_programme_augment_data_long_duration_threshold} = (5*60); # +/-5 mins
98$reclogic{duplicate_programme_augment_data_short_duration_threshold} = (2.5*60); # +/- 2min30
99
100# for any programmes we didn't choose, reset the starttime up to a maximum
101# window of 5 minutes to the same value as our "chosen" endtime.
102# if can't readjust, then ignore (remove) that programme
103
104$reclogic{readjust_starttime_for_nonmatched_programmes} = (5*60);
105
106#### end reconciler settings ####
107
108my $opt;
109my $pref_order;
110my $mirror_site;
111my $made_changes = 0;
112my $debug = 1;
113my $recdebug = 0;
114my $grabbers = { };
115my $gscore;
116my $preferred; # obsolete but may still exist in shepherd.conf
117my $region;
118my $channels;
119my $config_file =   "$CWD/$progname.conf";
120my $channels_file = "$CWD/channels.conf";
121my $days;
122
123# postprocessing
124my $postprocessors = { };
125my $langs = [ 'en' ];
126my $num_timeslots;
127my $plugin_data = { };
128my $channel_data = { };
129my $starttime, my $endtime;
130my $input_postprocess_file = "$CWD/reconciled_output_pre_postprocessors.xml";
131my $insufficient_grabber_data = 0;
132
133# ---------------------------------------------------------------------------
134# --- Setup
135# ---------------------------------------------------------------------------
136
137print ucfirst($progname) . " v$version\n\n";
138#print "Cwd: $CWD.\n";
139
140# Any options Shepherd doesn't understand, we'll pass to the grabber(s)
141Getopt::Long::Configure(qw/pass_through/);
142
143get_initial_command_line_options();
144
145help() if ($opt->{help});
146
147unless ($opt->{configure})
148{
149    read_config_file();
150    read_channels_file();
151}
152
153get_remaining_command_line_options();
154
155if ($opt->{status})
156{
157    status();
158    exit;
159}
160
161if ($opt->{show_config})
162{
163    show_config();
164    exit;
165}
166
167if ($opt->{enable})
168{
169    enable($opt->{enable});
170}
171
172if ($opt->{disable})
173{
174    disable($opt->{disable});
175}
176
177if ($opt->{setorder})
178{
179    set_order(0, $opt->{setorder}); 
180}
181
182if ($opt->{check})
183{
184    check();
185}
186
187if ($opt->{enable} or
188    $opt->{disable} or
189    $opt->{setorder} or
190    $opt->{check} or
191    $opt->{mirror})
192{
193    set_order(1) if $made_changes;
194    write_config_file() if $made_changes;
195    status();
196    exit;
197}
198
199# ---------------------------------------------------------------------------
200# --- Update
201# ---------------------------------------------------------------------------
202
203unless ($opt->{noupdate})
204{
205    update($progname, $version);
206    set_order(1) if $made_changes;
207    write_config_file() if (($made_changes) && (! $opt->{configure}))
208}
209
210if ($opt->{configure})
211{
212    configure();
213}
214
215# ---------------------------------------------------------------------------
216# --- Go!
217# ---------------------------------------------------------------------------
218
219unless ($opt->{update})
220{
221    calc_date_range();
222    grab_data();
223    reconcile_data();
224    postprocess_data();
225    output_data();
226}
227
228print "Done.\n";
229
230status();
231write_config_file();
232
233# ---------------------------------------------------------------------------
234# --- Subroutines
235# ---------------------------------------------------------------------------
236
237# -----------------------------------------
238# Subs: Grabbing
239# -----------------------------------------
240
241sub grab_data
242{
243    my $used_grabbers = 0;
244    my $need_more_data = 1;
245
246    print "\nGrabber stage:\n";
247
248    my $grabber;
249   
250    while ($grabber = choose_grabber())
251    {
252        $used_grabbers++;
253
254        $grabbers->{$grabber}->{lastdata} = time;
255        $grabbers->{$grabber}->{laststatus} = "unknown";
256
257        printf "\nSHEPHERD: Using grabber: (%d) %s\n", $used_grabbers, $grabber;
258
259        my $output = "$GRABBER_DIR/$grabber/output.xmltv";
260
261        my $comm = "$GRABBER_DIR/$grabber/$grabber " .
262                   "--region $region " .
263                   "--channels_file $channels_file " .
264                   "--output $output";
265
266        # NOTE: ideally a grabber could be instructed to fetch partial data through --channel, --starttime & --endtime
267        # we don't have that for now so instead whenever there is missing data, ALL 7 days for all channels will be collected
268        # FIXME FUTURE: call grabbers just with what we want...
269        $comm .= " --days $days" if ($days);
270        $comm .= " --offset $opt->{offset}" if ($opt->{offset});
271        $comm .= " --debug" if ($debug);
272        $comm .= " @ARGV" if (@ARGV);
273        print "SHEPHERD: Excuting command: $comm\n";
274
275        chdir "$GRABBER_DIR/$grabber/";
276        system($comm);
277        chdir $CWD;
278
279        # soak up the data we just collected
280        &soak_up_data($grabber, $output, "grabber");
281        $grabbers->{$grabber}->{laststatus} = $plugin_data->{$grabber}->{laststatus};
282
283        # check to see if we have all the data we want
284        $need_more_data = &analyze_plugin_data($channel_ok_threshold_percent, "AGGREGATE GRABBER");
285
286        last if (!$need_more_data);
287    }
288
289
290    if ($used_grabbers == 0)
291    {
292        print "No valid grabbers installed/enabled!\n";
293        return;
294    }
295
296    if ($need_more_data)
297    {
298        print "SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n";
299        $insufficient_grabber_data = 1;
300        return;
301    }
302}
303
304sub choose_grabber
305{
306    unless (defined $gscore)
307    {
308        foreach (keys %$grabbers)
309        {
310            unless ($grabbers->{$_}->{disabled})
311            {
312                $gscore->{$_} = 0;
313            }
314        }
315    }
316
317    my $total = score_grabbers();
318
319    print "Scoring unused valid grabbers:\n" . Dumper($gscore);
320
321    return undef unless (scalar keys %$gscore);
322
323    my $r = int(rand($total));
324#    print "Total score: $total.\nRand: $r.\n";
325
326    my $c = 0;
327    foreach (keys %$gscore)
328    {
329        if ($r >= $c and $r < ($c + $gscore->{$_}))
330        {
331            delete $gscore->{$_};
332            return $_;
333        }
334        $c += $gscore->{$_};
335    }
336    die "ERROR: failed to choose grabber.";
337}
338
339sub score_grabbers
340{
341    my ($score, $total);
342    foreach (keys %$gscore)
343    {
344        $score = 10;
345        $gscore->{$_} = $score;
346        $total += $score;
347    }
348    return $total;
349}
350
351
352# interpret xmltv data from this grabber/postprocessor
353sub soak_up_data
354{
355    my ($plugin, $output, $plugintype) = @_;
356
357    if (! -r $output) {
358        printf "SHEPHERD: Warning: plugin '%s' output file '%s' does not exist\n",$plugin,$output;
359        return;
360    }
361
362    my $parse_start_time = [gettimeofday];
363    printf STDERR "SHEPHERD: Started parsing XMLTV from '%s' in '%s' .. any errors below are from parser:\n",$plugin,$output;
364    eval { $plugin_data->{$plugin}->{xmltv} = XMLTV::parsefiles($output); };
365    printf STDERR "SHEPHERD: Completed XMLTV parsing from '%s' in %0.2f seconds\n",$plugin,tv_interval($parse_start_time);
366
367    if (defined $plugin_data->{$plugin}->{xmltv}) {
368        $plugin_data->{$plugin}->{valid} = 1;
369
370        my $xmltv = $plugin_data->{$plugin}->{xmltv};
371        my ($encoding, $credits, $chan, $progs) = @$xmltv;
372        $plugin_data->{$plugin}->{total_duration} = 0;
373        $plugin_data->{$plugin}->{programmes} = 0;
374
375        my $strptime = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M %z");
376        my $alt_strptime = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M"); # alternate format 1: oztivo doesn't seem to output timezone
377        my $seen_channels_with_data = 0;
378
379        # iterate thru channels
380        foreach my $ch (sort keys %{$channels}) {
381            my $seen_progs_on_this_channel = 0;
382
383            # iterate thru programmes per channel
384            foreach my $prog (@$progs) {
385                next if ($prog->{channel} ne $channels->{$ch});
386
387                my $t1 = $strptime->parse_datetime($prog->{start});
388                $t1 = $alt_strptime->parse_datetime($prog->{start}) if (!$t1);
389
390                my $t2 = $strptime->parse_datetime($prog->{stop});
391                $t2 = $alt_strptime->parse_datetime($prog->{stop}) if (!$t2);
392
393                next if (!$t1 || !$t2); # if we can't parse stop/start then clearly THIS data is bunk!
394
395                # store t1 and t2 times in the xmltv data for later on (shh.. ton't tell anyone..)
396                $prog->{start_epoch} = $t1->epoch;
397                $prog->{stop_epoch} = $t2->epoch;
398
399                # store plugin-specific stats
400                $plugin_data->{$plugin}->{programmes}++;
401                $plugin_data->{$plugin}->{total_duration} += ($t2->epoch - $t1->epoch);
402                $seen_progs_on_this_channel++;
403                $plugin_data->{$plugin}->{earliest_data_seen} = $t1->epoch if (!defined $plugin_data->{$plugin}->{earliest_data_seen});
404                $plugin_data->{$plugin}->{earliest_data_seen} = $t1->epoch if ($t1->epoch < $plugin_data->{$plugin}->{earliest_data_seen});
405                $plugin_data->{$plugin}->{latest_data_seen} = $t2->epoch if (!defined $plugin_data->{$plugin}->{latest_data_seen});
406                $plugin_data->{$plugin}->{latest_data_seen} = $t2->epoch if ($t2->epoch > $plugin_data->{$plugin}->{latest_data_seen});
407
408                # store channel-specific stats
409                $channel_data->{$ch}->{programmes}++;
410                $channel_data->{$ch}->{total_duration} += ($t2->epoch - $t1->epoch);
411
412                # store timeslot info
413                next if ($t1->epoch > $endtime);        # programme starts after timeslots we are interested .. nice that we have it ... but we really don't care about it!
414                next if ($t2->epoch < $starttime);      # programme ends  before timeslots we are interested .. nice that we have it ... but we really don't care about it!
415                my $start_slotnum;
416                if ($t1->epoch >= $starttime) {
417                    $start_slotnum = int(($t1->epoch - $starttime) / $timeslot_size);
418                } else {
419                    $start_slotnum = 0;
420                }
421                my $end_slotnum;
422                if ($t2->epoch < $endtime) {
423                    $end_slotnum = int(($t2->epoch - $starttime) / $timeslot_size);
424                } else {
425                    $end_slotnum = ($num_timeslots-1);
426                }
427
428                # add this programme into the global timeslots table for this channel
429                foreach my $slotnum ($start_slotnum..$end_slotnum) {
430                    $channel_data->{$ch}->{timeslots}[$slotnum]++;
431                }
432            }
433
434            $seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
435        }
436
437        # print some stats about what we saw!
438        printf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
439            ucfirst($plugintype), $plugin, $seen_channels_with_data, $plugin_data->{$plugin}->{programmes},
440            int($plugin_data->{$plugin}->{total_duration} / 86400),             # days
441            int(($plugin_data->{$plugin}->{total_duration} % 86400) / 3600),    # hours
442            int(($plugin_data->{$plugin}->{total_duration} % 3600) / 60),       # mins
443            int($plugin_data->{$plugin}->{total_duration} % 60),                # sec
444            (defined $plugin_data->{$plugin}->{earliest_data_seen} ? (strftime "%a %e %b %H:%M - ", localtime($plugin_data->{$plugin}->{earliest_data_seen})) : 'no data'),
445            (defined $plugin_data->{$plugin}->{latest_data_seen} ? (strftime "%a %e %b %H:%M", localtime($plugin_data->{$plugin}->{latest_data_seen})) : '');
446        $plugin_data->{$plugin}->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
447            $seen_channels_with_data, $plugin_data->{$plugin}->{programmes},
448            int($plugin_data->{$plugin}->{total_duration} / 3600),
449            (defined $plugin_data->{$plugin}->{earliest_data_seen} ? (strftime "%a%d%b%H:%M", localtime($plugin_data->{$plugin}->{earliest_data_seen})) : 'no'),
450            (defined $plugin_data->{$plugin}->{latest_data_seen} ? (strftime "%a%d%b%H:%M", localtime($plugin_data->{$plugin}->{latest_data_seen})) : 'data');
451
452    } else {
453        printf "WARNING: Plugin %s didn't seem to return any valid XMLTV!\n",$plugin;
454        delete $plugin_data->{$plugin}->{valid};
455    }
456}
457
458
459# analyze grabber data - do we have all the data we want?
460# returns 1 if we need more data, 0 if we have all we want
461sub analyze_plugin_data
462{
463    my ($threshold,$analysistype) = @_;
464    my $retval = 0; # until proven otherwise
465    my $total_data_percent = 0, my $total_channels = 0;
466    my $statusstring = "";
467
468    # iterate across each channel
469    foreach my $ch (sort keys %{$channels}) {
470        $total_channels++;
471        if (defined $channel_data->{$ch}) {
472            my $data_in_channel = 0;
473            for my $slotnum (0..($num_timeslots-1)) {
474                $data_in_channel++ if ((defined $channel_data->{$ch}->{timeslots}[$slotnum]) && ($channel_data->{$ch}->{timeslots}[$slotnum] > 0));
475            }
476
477            # do we have enough data for this channel?
478            my $data_in_channel_percent = $data_in_channel / ($num_timeslots-1) * 100;
479            if ($data_in_channel_percent >= $threshold) {
480                $statusstring .= sprintf "%s: %0.1f%% [complete], ",$ch,$data_in_channel_percent;
481            } else {
482                $statusstring .= sprintf "%s: %0.1f%% [hungry], ",$ch,$data_in_channel_percent;
483                $retval = 1;
484            }
485            $total_data_percent += $data_in_channel_percent;
486        } else {
487            $statusstring .= sprintf "%s: 0%% [starving], ",$ch;
488            $retval = 1;
489        }
490    }
491
492    if ($total_channels > 0) {
493        $total_data_percent = $total_data_percent / $total_channels;
494    } else {
495        $total_data_percent = 0;
496    }
497
498    # print some stats about what our analysis says!
499    printf "SHEPHERD: %s ANALYSIS: %sTOTAL %0.2f%% %s %0.2f%%: %s\n",
500        uc($analysistype), $statusstring, $total_data_percent,
501        ($total_data_percent >= $channel_ok_threshold_percent ? ">" : "<"), $channel_ok_threshold_percent,
502        ($retval ? "WANT MORE DATA" : "COMPLETE");
503    return $retval;
504}
505
506
507# work out date range we are expecting data to be in
508sub calc_date_range
509{
510    # normalize starttime to beginning of hour
511    my $now = time;
512    my ($sec,$min,@rest) = localtime($now);
513
514    $starttime = $now - ((60 * $min) + $sec);
515
516    if ($days) {
517        $endtime = $starttime + ($days * 86400);
518    } else {
519        $endtime = $starttime + (7*86400);
520    }
521    $starttime += (86400 * $opt->{offset}) if ($opt->{offset});
522
523    $num_timeslots = ($endtime - $starttime) / $timeslot_size;
524}
525
526# -----------------------------------------
527# Subs: Reconciling data
528# -----------------------------------------
529
530# for all the data we have, try to pick the best bits!
531sub reconcile_data
532{
533    printf "\nReconciling data:\n\n";
534
535    my @proglist = [ ];
536    my @position_pointer = [ ];
537    my $num_grabbers = 0;
538    my $pref_order;
539
540    printf "Preference for whose data we prefer as follows:\n";
541    foreach my $proggy (sort { $grabbers->{$a}->{order} <=> $grabbers->{$b}->{order} } keys %$grabbers) {
542        if ((!$grabbers->{$proggy}->{disabled}) && ($plugin_data->{$proggy}) && ($plugin_data->{$proggy}->{valid})) {
543            my $orig_prog = $plugin_data->{$proggy}->{xmltv}->[3];
544            my $prognum = 0;
545            foreach my $new_prog (sort order_channel_time @{$orig_prog}) {
546                $proglist[$num_grabbers]->[$prognum] = $new_prog;
547                $prognum++;
548            }
549
550            printf "  %d. %s (%d programmes)\n",($num_grabbers+1),$proggy,$prognum;
551            $num_grabbers++;
552        }
553    }
554
555    my %writer_args = ( encoding => 'ISO-8859-1' );
556    my $fh = new IO::File(">$input_postprocess_file") || die "can't open outputfile $input_postprocess_file: $!";
557    $writer_args{OUTPUT} = $fh;
558    my $writer = new XMLTV::Writer(%writer_args);
559
560    $writer->start({'source-info-url' => "about:blank", 'source-info-name' => "$progname $version", 'generator-info-name' => "$progname $version"} );
561
562    for my $ch (sort keys %$channels) {
563        $writer->write_channel({'display-name' => [[ $ch, "en" ]], 'id' => $channels->{$ch}} );
564    }
565
566    for my $ch (sort keys %$channels) {
567        printf "Reconciling channel: %s (%s)\n",$ch,$channels->{$ch};
568
569        #
570        # 1. position pointers to first piece of data for this channel
571        #
572
573        printf "REC#1: processing channel %s\n",$channels->{$ch} if $recdebug;
574        my $position_pointer;
575        for (my $i=0; $i < $num_grabbers; $i++) {
576            $position_pointer[$i] = 0;
577            while ((defined $proglist[$i]->[($position_pointer[$i])]) && ($proglist[$i]->[($position_pointer[$i])]->{'channel'} ne $channels->{$ch})) {
578                $position_pointer[$i]++;
579            }
580            if (!defined $proglist[$i]->[($position_pointer[$i])]) {
581                $position_pointer[$i] = -1;
582                printf "REC#1: no programmes found for channel %s from gradder %d\n",$channels->{$ch},$i if $recdebug;
583            } else {
584                printf "REC#1: advanced position_pointer to %d for grabber %d (first programme is \"%s\", start %d, stop %d)\n",
585                    $position_pointer[$i],$i,${XMLTV::best_name($langs,$proglist[$i]->[($position_pointer[$i])]->{title})}[0],
586                    $proglist[$i]->[($position_pointer[$i])]->{start_epoch},$proglist[$i]->[($position_pointer[$i])]->{stop_epoch} if $recdebug;
587            }
588        }
589
590        my $all_done_on_this_channel;
591        do {
592            #
593            # 2. find 'earliest' programme from all the choices
594            #
595
596            $all_done_on_this_channel = 1; # unless proven otherwise
597            my $earliest_programme_time = undef;
598            my $earliest_programme_slot = undef;
599            for (my $i=0; $i < $num_grabbers; $i++) {
600                next if ($position_pointer[$i] == -1); # skip if no programmes on this channel from this grabber
601                my $this_programme = $proglist[$i]->[($position_pointer[$i])];
602
603                if ((!defined $this_programme) || (!defined $this_programme->{title}) || ($this_programme->{channel} ne $channels->{$ch})) {
604                    # no more programmes on this channel for this grabber!
605                    printf "REC#2: no more programmes on grabber %d for this channel\n",$i if $recdebug;
606                    $position_pointer[$i] = -1;
607                } else {
608                    if ((!defined $earliest_programme_time) || ($earliest_programme_time > $this_programme->{'start_epoch'})) {
609                        $earliest_programme_time = $this_programme->{'start_epoch'};
610                        $earliest_programme_slot = $i;
611                        printf "REC#2: earliest programme (so far) on grabber %d, start %d (end %d) programme \"%s\"\n",
612                            $i,$this_programme->{start_epoch},$this_programme->{stop_epoch},${XMLTV::best_name($langs,$this_programme->{title})}[0] if $recdebug;
613                    } else {
614                        printf "REC#2:    programme on grabber %d was not earlier start %d (end %d) programme \"%s\"\n",
615                            $i,$this_programme->{start_epoch},$this_programme->{stop_epoch},${XMLTV::best_name($langs,$this_programme->{title})}[0] if $recdebug;
616                    }
617                }
618            }
619            if (!defined $earliest_programme_slot) {
620                # no programmes available on ANY grabber for this channel, skip this channel
621                printf "REC#2: no programmes on any grabbers for channel %s, skipping this channel\n",$channels->{$ch} if $recdebug;
622            } else {
623                #
624                # 3a. compare how many programmes on other grabbers overlap with it
625                # TODO (FUTURE): enhance this to do "majority voting" acrosa all grabbers based on identical start/stop
626                # TODO (FUTURE): where star/stop times match exactly but title names dont, record the mapping for known-as_to_most-preferred-title so we can use this in future transformations
627
628                my $preferred_programme = $proglist[$earliest_programme_slot]->[($position_pointer[$earliest_programme_slot])];
629                my $startpoint = $preferred_programme->{'start_epoch'};
630                my $stoppoint = $preferred_programme->{'stop_epoch'};
631                my $duration = $stoppoint - $startpoint;
632                my $extraduration = 0;
633                $extraduration = int($duration * ($reclogic{compare_overlapping_programmes_extra_overtime_duration_percent}/100)) if ($reclogic{compare_overlapping_programmes_extra_overtime_duration_percent} > 0);
634                $extraduration = $reclogic{compare_overlapping_programmes_extra_overtime_max} if ($extraduration > $reclogic{compare_overlapping_programmes_extra_overtime_max}); # upper limit
635                $stoppoint += $extraduration;
636                printf "REC#3: comparing other grabbers to see how many programmes fit in timeslot %d to %d (%d+%d)\n",$startpoint,$stoppoint,$duration,$extraduration if $recdebug;
637
638                my $max_progs_found = 0;
639                my $max_progs_slot = undef;
640                for (my $i=0; $i < $num_grabbers; $i++) {
641                    next if ($i == $earliest_programme_slot);
642                    next if ($position_pointer[$i] == -1);
643                    my $position_offset = 0;
644                    my $progs_found = 0;
645
646                    while ((defined $proglist[$i]->[($position_pointer[$i]+$position_offset)]) &&
647                           ($proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'channel'} eq $channels->{$ch}) &&
648                           ($proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'start_epoch'} >= $startpoint) &&
649                           ($proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'stop_epoch'} <= $stoppoint)) {
650                        my $this_prog_duration = $proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'stop_epoch'} - $proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'start_epoch'};
651
652                        printf "REC#3a.  programme on grabber %d matched (start %d end %d), \"%s\"%s\n", $i,
653                            $proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'start_epoch'},
654                            $proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'stop_epoch'},
655                            ${XMLTV::best_name($langs,$proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'title'})}[0],
656                            ($this_prog_duration <= $reclogic{min_time_override_for_duplicate} ? 
657                            ", but ignored because of min_time_override_for_duplicate ($reclogic{min_time_override_for_duplicate} sec)" : "") if $recdebug;
658
659                        $progs_found++ if ($this_prog_duration > $reclogic{min_time_override_for_duplicate});
660                        $position_offset++;
661                    }
662
663                    printf "REC#3a:  %d programmes on grabber %d within timeslot\n",$progs_found,$i if $recdebug;
664                    if ($progs_found > $max_progs_found) {
665                        $max_progs_found = $progs_found;
666                        $max_progs_slot = $i;
667                    }
668                }
669
670                # 3b. if there are 2 or more programmes on other channels, use those - otherwise use this one
671                if ((!defined $max_progs_slot) || ($max_progs_found <= 1)) {
672                    printf "REC#3b: no grabbers with more programmes in timeslot found\n" if $recdebug;
673                } else {
674                    printf "REC#3b: grabber %d has %d programmes between %d and %d - using THAT grabber as our preference now!\n",
675                        $max_progs_slot,$max_progs_found,$startpoint,$stoppoint if $recdebug;
676                    $earliest_programme_slot = $max_progs_slot;
677                }
678
679                #
680                # 4. populate our "reconciled" programme list with the programming chosen
681                #
682
683                my $chosen_prog = $proglist[$earliest_programme_slot]->[($position_pointer[$earliest_programme_slot])];
684                $startpoint = $chosen_prog->{'start_epoch'};
685                $stoppoint = $chosen_prog->{'stop_epoch'};
686                my $new_prog_entry = $chosen_prog;
687
688                printf "REC#4: chosen programme is from grabber %d: start %d, end %d, duration %d: \"%s\"\n",
689                    $earliest_programme_slot,$startpoint,$stoppoint,($stoppoint-$startpoint),
690                    ${XMLTV::best_name($langs,$chosen_prog->{'title'})}[0] if $recdebug;
691
692                #
693                # 5a. see if we have it duplicated from multiple grabbers (with fuzz -/+ 5 mins max), -/+ 2.5mins for programmes <= 15 mins
694                # TODO (FUTURE): should really do an exact start/stop match as a first pass, then do the fuzz afterwards..
695
696                my $start1, my $start2, my $stop1, my $stop2;
697
698                if (($stoppoint - $startpoint) <= $reclogic{duplicate_programme_augment_data_short_cutoff}) {
699                    $start1 = $startpoint - $reclogic{duplicate_programme_augment_data_short_duration_threshold};
700                    $start2 = $startpoint + $reclogic{duplicate_programme_augment_data_short_duration_threshold};
701                    $stop1 = $stoppoint - $reclogic{duplicate_programme_augment_data_short_duration_threshold};
702                    $stop2 = $stoppoint + $reclogic{duplicate_programme_augment_data_short_duration_threshold};
703                } else {
704                    $start1 = $startpoint - $reclogic{duplicate_programme_augment_data_long_duration_threshold};
705                    $start2 = $startpoint + $reclogic{duplicate_programme_augment_data_long_duration_threshold};
706                    $stop1 = $stoppoint - $reclogic{duplicate_programme_augment_data_long_duration_threshold};
707                    $stop2 = $stoppoint + $reclogic{duplicate_programme_augment_data_long_duration_threshold};
708                }
709                if ($start2 >= $stop1) {
710                    $start2 = $startpoint;
711                    $stop1 = $stoppoint;
712                }
713
714                printf "REC#5: looking in other grabbers for matching programmes within timeslot start %d-%d (%d) and end %d-%d (%d)\n",
715                    $start1,$start2,($start2-$start1),$stop1,$stop2,($stop2-$stop1) if $recdebug;
716
717                for (my $i=0; $i < $num_grabbers; $i++) {
718                    next if ($i == $earliest_programme_slot);
719                    next if ($position_pointer[$i] == -1);
720
721                    if ((defined $proglist[$i]->[($position_pointer[$i])]) &&
722                        ($proglist[$i]->[($position_pointer[$i])]->{'channel'} eq $channels->{$ch}) &&
723                        ($proglist[$i]->[($position_pointer[$i])]->{'start_epoch'} >= $start1) &&
724                        ($proglist[$i]->[($position_pointer[$i])]->{'start_epoch'} < $start2) &&
725                        ($proglist[$i]->[($position_pointer[$i])]->{'stop_epoch'} >= $stop1) &&
726                        ($proglist[$i]->[($position_pointer[$i])]->{'stop_epoch'} < $stop2)) {
727                        # winner .. matches our criteria ...
728                        my $match_prog = $proglist[$i]->[($position_pointer[$i])];
729
730                        printf "REC#5:   found programme on grabber %d: start %d, end %d: \"%s\"\n", $i,
731                            $match_prog->{'start_epoch'},$match_prog->{'stop_epoch'},
732                            ${XMLTV::best_name($langs,$match_prog->{'title'})}[0] if $recdebug;
733
734                        foreach my $field (keys %{$match_prog}) {
735                            # 5b. pick fields from each one in order of our preferences
736                            next if ($field eq "start_epoch");
737                            next if ($field eq "stop_epoch");
738                            if (!defined $new_prog_entry->{$field}) {
739                                printf "REC#5b:      adding field \"%s\"\n",$field;
740                                $new_prog_entry->{$field} = $match_prog->{$field};
741                                # TODO (FUTURE): should we add to programme description to say where we got what data from?
742                            }
743                        }
744                    }
745                }
746
747                # 6.  write out new entry
748                printf "REC#6: writing out programme entry\n" if $recdebug;
749                #delete $new_prog_entry->{'start_epoch'};
750                #delete $new_prog_entry->{'stop_epoch'};
751                &cleanup($new_prog_entry);
752                $writer->write_programme($new_prog_entry);
753
754                # 7a. remove all programmes that end before this endtime
755                for (my $i=0; $i < $num_grabbers; $i++) {
756                    next if ($position_pointer[$i] == -1);
757                    while ((defined $proglist[$i]->[($position_pointer[$i])]) &&
758                           ($proglist[$i]->[($position_pointer[$i])]->{'channel'} eq $channels->{$ch}) &&
759                           ($proglist[$i]->[($position_pointer[$i])]->{'stop_epoch'} <= $stoppoint)) {
760                        printf "REC#7a: removing programme on grabber %d slot %d since it ends before inserted start: start %d end %s: \"%s\"\n",
761                            $i, $position_pointer[$i],
762                            $proglist[$i]->[($position_pointer[$i])]->{'start_epoch'},
763                            $proglist[$i]->[($position_pointer[$i])]->{'stop_epoch'},
764                            ${XMLTV::best_name($langs,$proglist[$i]->[($position_pointer[$i])]->{'title'})}[0] if $recdebug;
765                        delete $proglist[$i]->[($position_pointer[$i])];
766                        $position_pointer[$i]++;
767                    }
768                }
769
770                # 7b. adjust starttimes of any programmes to match endtime (with fuzz of +5 mins max)
771                for (my $i=0; $i < $num_grabbers; $i++) {
772                    next if ($position_pointer[$i] == -1);
773                    my $position_offset = 0;
774                    while ((defined $proglist[$i]->[($position_pointer[$i]+$position_offset)]) &&
775                           ($proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'channel'} eq $channels->{$ch}) &&
776                           ($proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'start_epoch'} < $stoppoint)) {
777                        my $this_prog = $proglist[$i]->[($position_pointer[$i]+$position_offset)];
778                        if (($this_prog->{'start_epoch'} + $reclogic{readjust_starttime_for_nonmatched_programmes}) >= $stoppoint) {
779                            printf "REC#7b: adjusting starttime on grabber %d slot %d since it starts <5mins before inserted end:\n",
780                                $i,($position_pointer[$i]+$position_offset) if $recdebug;
781                            printf "REC#7b:    orig: start %d end %d, now: start %d end %d: \"%s\"\n",
782                                $this_prog->{'start_epoch'}, $this_prog->{'stop_epoch'}, $stoppoint, $this_prog->{'stop_epoch'},
783                                ${XMLTV::best_name($langs,$this_prog->{'title'})}[0] if $recdebug;
784                            $proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'start_epoch'} = $stoppoint;
785                            $proglist[$i]->[($position_pointer[$i]+$position_offset)]->{'start'} = sprintf "%s",(strftime "%Y%m%d%H%M", localtime($stoppoint));
786                            $position_offset++;
787                        } else {
788                            printf "REC#7b: removing grabber %d slot %d programme because it started too long before chosen programme: start %d end %d: \"%s\"\n",
789                                $i, ($position_pointer[$i]+$position_offset), $this_prog->{'start_epoch'}, $this_prog->{'stop_epoch'},
790                                ${XMLTV::best_name($langs,$this_prog->{'title'})}[0] if $recdebug;
791                            $position_pointer[$i]++;
792                        }
793                    }
794                }
795            }
796
797            # 8. check that we still have at least one pointer on current channel
798            for (my $i=0; $i < $num_grabbers; $i++) {
799                next if ($position_pointer[$i] == -1);
800                printf "REC#8: grabber %d is now at slot %d\n",$i,$position_pointer[$i] if $recdebug;
801                if ((defined $proglist[$i]->[($position_pointer[$i])]) &&
802                    ($proglist[$i]->[($position_pointer[$i])]->{'channel'} eq $channels->{$ch})) {
803                    $all_done_on_this_channel = 0;
804                    printf "REC#8:   grabber %d is at slot %d is still on channel \"%s\"\n",$i,$position_pointer[$i],$channels->{$ch} if $recdebug;
805                }
806            }
807            printf "REC#9:\n" if $recdebug;
808        } until ($all_done_on_this_channel);
809    }
810    $writer->end();
811}
812
813# sorting helper routine - sort by channel then by start-time
814sub order_channel_time {
815        my $chanresult = $a->{channel} cmp $b->{channel};
816        return $chanresult if ($chanresult != 0);
817        return ($a->{start_epoch} <=> $b->{start_epoch});
818}
819
820# descend a structure and clean up various things, including stripping
821# leading/trailing spaces in strings, translations of html stuff etc
822#   -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
823my %amp;
824BEGIN { %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } ) }
825sub cleanup {
826    my $x = shift;
827    if    (ref $x eq "REF")   { cleanup($_) }
828    elsif (ref $x eq "HASH")  { cleanup(\$_) for values %$x }
829    elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
830    elsif (defined $$x) {
831        $$x =~ s/&(#(\d+)|(.*?));/ $2 ? chr($2) : $amp{$3}||' ' /eg;
832        # $$x =~ s/[^\x20-\x7f]/ /g;
833        $$x =~ s/(^\s+|\s+$)//g;
834    }
835}
836
837
838# -----------------------------------------
839# Subs: Postprocessing
840# -----------------------------------------
841
842sub postprocess_data
843{
844    # for our first postprocessor, we feed it ALL of the XMLTV files we have
845    # as each postprocessor runs, we feed in the output from the previous one
846    # Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
847    # reverts back to the previous postprocessor if it was shown to be bad
848
849    # first time around: feed in reconciled data ($input_postprocess_file)
850
851    my $need_more_data;
852
853    printf "\nPostprocessing stage:\n";
854
855    foreach my $postprocessor (sort { $postprocessors->{$a} <=> $postprocessors->{$b} } keys %$postprocessors) {
856        next if ($postprocessors->{$postprocessor}->{disabled});
857
858        $postprocessors->{$postprocessor}->{lastdata} = time;
859        $postprocessors->{$postprocessor}->{laststatus} = "unknown";
860
861        printf "\nSHEPHERD: Using postprocessor: %s\n",$postprocessor;
862
863        my $output = "$POSTPROCESSOR_DIR/$postprocessor/output.xmltv";
864        my $comm = "$POSTPROCESSOR_DIR/$postprocessor/$postprocessor " .
865                   "--region $region " .
866                   "--channels_file $channels_file " .
867                   "--output $output";
868        $comm .= " --days $days" if ($days);
869        $comm .= " --offset $opt->{offset}" if ($opt->{offset});
870        $comm .= " --debug" if ($debug);
871        $comm .= " @ARGV" if (@ARGV);
872        $comm .= " $input_postprocess_file";
873        print "SHEPHERD: Excuting command: $comm\n";
874
875        chdir "$POSTPROCESSOR_DIR/$postprocessor/";
876        system($comm);
877        chdir $CWD;
878
879        #
880        # soak up the data we just collected and check it
881        # YES - these are the SAME routines we used in the previous 'grabber' phase
882        # but the difference here is that we clear out our 'channel_data' beforehand
883        # so we can independently analyze the impact of this postprocessor.
884        # if it clearly returns bad data, don't use that data (go back one step) and
885        # flag the postprocessor as having failed.  after 3 consecutive failures, disable it
886        #
887
888        # clear out channel_data
889        foreach my $ch (keys %{$channels}) {
890            delete $channel_data->{$ch};
891        }
892
893        # process and analyze it!
894        &soak_up_data($postprocessor, $output, "postprocessor");
895        $need_more_data = &analyze_plugin_data($postprocessor_ok_threshold_percent, "POSTPROCESSOR");
896
897        $postprocessors->{$postprocessor}->{laststatus} = $plugin_data->{$postprocessor}->{laststatus};
898
899        if (($need_more_data) && (!$insufficient_grabber_data)) {
900            # urgh.  this postprocessor did a bad bad thing ...
901            printf "SHEPHERD: XML data from postprocessor %s rejected, using XML from previous stage\n",$postprocessor;
902
903            if (defined $postprocessors->{$postprocessor}->{conescutive_failures}) {
904                $postprocessors->{$postprocessor}->{conescutive_failures}++;
905            } else {
906                $postprocessors->{$postprocessor}->{conescutive_failures} = 1;
907            }
908            printf "SHEPHERD: Postprocessor \"%s\" has now failed %d times in a row.  %d more and it will be automatically disabled.\n",
909                $postprocessor,
910                $postprocessors->{$postprocessor}->{conescutive_failures},
911                ($postprocessor_disable_failure_threshold - $postprocessors->{$postprocessor}->{conescutive_failures});
912
913            if ($postprocessors->{$postprocessor}->{conescutive_failures} >= $postprocessor_disable_failure_threshold) {
914                printf "SHEPHERD: Disabling Postprocessor \"%s\".\n",$postprocessor;
915                $postprocessors->{$postprocessor}->{disabled} = 1;
916            }
917        } else {
918            # accept what this postprocessor did to our output ...
919            printf "SHEPHERD: accepting output from postprocessor %s, feeding it into next stage\n",$postprocessor;
920            $input_postprocess_file = $output;
921            delete $postprocessors->{$postprocessor}->{conescutive_failures} if (defined $postprocessors->{$postprocessor}->{conescutive_failures});
922        }
923    }
924}
925
926
927sub output_data
928{
929    # $input_postprocess_file contains our final output
930    # send it to whereever --output told us to!
931
932    my $output_filename = "$CWD/output.xmltv";
933    $output_filename = $opt->{output} if ($opt->{output});
934
935    open(OUTFILE,">$output_filename") || die "could not open output file $output_filename for writing: $!\n";
936
937    if (!(open(INFILE,"<$input_postprocess_file"))) {
938        printf "WARNING: could not open input file \"%s\": %s\n", $input_postprocess_file, $!;
939        printf "Output XMLTV data may be damanged as a result!\n";
940    } else {
941        while (<INFILE>) {
942            print OUTFILE $_;
943        }
944        close(INFILE);
945        close(OUTFILE);
946    }
947
948    printf "Final output stored in $output_filename.\n";
949}
950
951# -----------------------------------------
952# Subs: Updates & Installations
953# -----------------------------------------
954
955sub update
956{
957    printf "\nChecking for updates:\n\n";
958
959    my $data;
960    my $sites = "";
961    $sites = "$mirror_site," if ($mirror_site);
962    $sites .= $HOME;
963
964    foreach my $site (split(/,/,$sites)) {
965        my $url = $site . "/status";
966        print "Fetching status file: $url.\n";
967        $data = LWP::Simple::get($url);
968        last if $data;
969
970        print "Failed to retrieve status file from $url.\n";
971    }
972    return if (!$data);
973
974    my %glist = %$grabbers;
975    my %plist = %$postprocessors;
976    while ($data =~ /(.*):(.*):(.*)/g)
977    {
978        my ($proggy, $latestversion, $progtype) = ($1,$2,$3);
979        update_component($proggy, $latestversion, $progtype);
980        delete $glist{$proggy} if ($progtype eq "grabber");
981        delete $plist{$proggy} if ($progtype eq "postprocessor");
982    }
983
984    # work out what grabbers disappeared (if any)
985    foreach (keys %glist) {
986        unless ($grabbers->{$_}->{disabled}) {
987            print "\nDeleted grabber: $_.\n";
988            disable($_,"grabber");
989            $made_changes = 1;
990        }
991    }
992
993    # work out what postprocessors disappeared (if any)
994    foreach (keys %plist) {
995        unless ($postprocessors->{$_}->{disabled}) {
996            print "\nDeleted Postprocessor: $_.\n";
997            disable($_,"postprocessor");
998            $made_changes = 1;
999        }
1000    }
1001}
1002
1003sub update_component
1004{
1005    my ($proggy, $latestversion, $progtype) = @_;
1006
1007    # handle new installs..
1008    if (($proggy eq $progname) && ($progtype eq "shepherd")) {
1009        # shepherd itself..
1010        if(! -e "$CWD/$progname") {
1011            print "Missing: $CWD/$progname\n";
1012            install($progname, $latestversion, $progtype);
1013            return;
1014        }
1015    } elsif ($progtype eq "grabber") {
1016        if (!defined $grabbers->{$proggy} or ! -e "$GRABBER_DIR/$proggy/$proggy") {
1017            print "New grabber: $proggy.\n";
1018            install($proggy, $latestversion, $progtype);
1019            return;
1020        }
1021        print "Warning: grabber $proggy disabled by config file.\n" if ($grabbers->{$proggy}->{disabled});
1022    } elsif ($progtype eq "postprocessor") {
1023        if (!defined $postprocessors->{$proggy} or ! -e "$POSTPROCESSOR_DIR/$proggy/$proggy") {
1024            print "New postprocessor: $proggy.\n";
1025            install($proggy, $latestversion, $progtype);
1026            return;
1027        }
1028        print "Warning: postprocessor $proggy disabled by config file.\n" if ($postprocessors->{$proggy}->{disabled});
1029    }
1030
1031    # upgrade/downgrades
1032    my $ver;
1033    if ($progtype eq "grabber") {
1034        $ver = ($proggy eq $progname ? $version : $grabbers->{$proggy}->{ver});
1035    } elsif ($progtype eq "postprocessor") {
1036        $ver = ($proggy eq $progname ? $version : $postprocessors->{$proggy}->{ver});
1037    } elsif (($proggy eq $progname) && ($progtype eq "shepherd")) {
1038        $ver = $version;
1039    } else {
1040        print "Warning: unknown type of programme: prog '$proggy' progtype '$progtype' not installed.\n";
1041        return;
1042    }
1043
1044    my $result = versioncmp($ver, $latestversion);
1045    if ($result == -1) {
1046        print "Upgrading $proggy from v$ver to v$latestversion.\n";
1047    } elsif ($result == 1) {
1048        print "Downgrading $proggy from v$ver to v$latestversion.\n";
1049    } else {
1050        print "Already have latest version of $proggy: v$ver.\n";
1051        return;
1052    }
1053    install($proggy, $latestversion, $progtype);
1054}
1055
1056sub install
1057{
1058    my ($proggy, $latestversion, $progtype) = @_;
1059
1060    print "Downloading $proggy v$latestversion.\n";
1061
1062    my $sites = "";
1063    $sites = "$mirror_site," if ($mirror_site);
1064    $sites .= $HOME;
1065
1066    my $rdir = "";
1067    my $ldir = $CWD;
1068    my $ver = "unknown";
1069
1070    if (($proggy eq $progname) && ($progtype eq "shepherd")) {
1071        $ver = $version;
1072    } elsif ($progtype eq "grabber") {
1073        $rdir = "grabbers";
1074        $ldir = "$GRABBER_DIR/$proggy";
1075        $ver = $grabbers->{$proggy}->{ver} if ((defined $grabbers->{$proggy}) && $grabbers->{$proggy}->{ver});
1076        -d $GRABBER_DIR or mkdir $GRABBER_DIR or die "Cannot create directory $GRABBER_DIR: $!";
1077    } elsif ($progtype eq "postprocessor") {
1078        $rdir = "postprocessors";
1079        $ldir = "$POSTPROCESSOR_DIR/$proggy";
1080        $ver = $postprocessors->{$proggy}->{ver} if ((defined $postprocessors->{$proggy}) && $postprocessors->{$proggy}->{ver});
1081        -d $POSTPROCESSOR_DIR or mkdir $POSTPROCESSOR_DIR or die "Cannot create directory $POSTPROCESSOR_DIR: $!";
1082    } else {
1083        print "Warning: unknown type of programme: prog '$proggy' progtype '$progtype' not installed.\n";
1084        return;
1085    }
1086    -d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!";
1087
1088    my $newfile = "$ldir/$proggy-$latestversion";
1089    my $rc;
1090
1091    foreach my $site (split(/,/,$sites)) {
1092        printf "Fetching $site/$rdir/$proggy v$latestversion.\n";
1093        $rc = LWP::Simple::getstore("$site/$rdir/$proggy", $newfile);
1094        last if (is_success($rc));
1095
1096        print "Failed to retrieve $site/$rdir/$proggy.\n";
1097    }
1098    return if (!is_success($rc));
1099
1100    # Make it executable
1101    system('chmod u+x ' . $newfile);
1102
1103    -d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!";
1104
1105    if (-e "$ldir/$proggy")
1106    {
1107        rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy-$ver");
1108    }
1109    rename($newfile, "$ldir/$proggy");
1110   
1111    print "Installed $proggy v$latestversion.\n" if ($debug);
1112
1113    # if the update was for shepherd itself, restart it
1114    if (($proggy eq $progname) && ($progtype eq "shepherd")) {
1115        print "\n*** Restarting ***\n\n";
1116        exec("$ldir/$proggy");
1117        # This exits.
1118    }
1119
1120    print "Testing $proggy...\n" if ($debug);
1121    my $result = test_proggy($ldir,"$ldir/$proggy");
1122
1123    if ($progtype eq "grabber") {
1124        $grabbers->{$proggy}->{ver} = $latestversion;
1125        $grabbers->{$proggy}->{ready} = $result;
1126        $grabbers->{$proggy}->{laststatus} = sprintf "updated to %s on %s", $latestversion, (strftime "%a%d%b%y",localtime(time));
1127    } elsif ($progtype eq "postprocessor") {
1128        $postprocessors->{$proggy}->{ver} = $latestversion;
1129        $postprocessors->{$proggy}->{ready} = $result;
1130        $postprocessors->{$proggy}->{laststatus} = sprintf "updated to %s on %s", $latestversion, (strftime "%a%d%b%y",localtime(time));
1131    }
1132
1133    $made_changes = 1;
1134}
1135
1136sub test_proggy
1137{
1138    my ($testdir,$proggyexec) = @_;
1139
1140    chdir($testdir);
1141    system("$proggyexec --ready");
1142    chdir ($CWD);
1143
1144    my $result = $?;
1145    print "Return value: $result\n" if ($debug);
1146
1147    print "\nprogramme $proggyexec did not exit cleanly!\n" .
1148         "It may require configuration.\n\n" if ($result);
1149    return !$result;
1150}
1151
1152sub enable
1153{
1154    my $proggy = shift;
1155
1156    # confirm it exists first
1157    if ((!$grabbers->{$proggy}) && (!$postprocessors->{$proggy})) {
1158        printf "No such grabber/postprocessor: \"%s\".\n",$proggy;
1159        return;
1160    }
1161    print "Enabling $proggy.\n";
1162
1163    if ($grabbers->{$proggy}) {
1164        delete $grabbers->{$proggy}->{disabled};
1165        $grabbers->{$proggy}->{laststatus} = sprintf "enabled on %s, not run yet",(strftime "%a%d%b%y", localtime(time));
1166    } elsif ($postprocessors->{$proggy}) {
1167        delete $postprocessors->{$proggy}->{disabled};
1168        $postprocessors->{$proggy}->{laststatus} = sprintf "enabled on %s, not run yet",(strftime "%a%d%b%y", localtime(time));
1169    }
1170    $made_changes = 1;
1171}
1172
1173sub disable
1174{
1175    my $proggy = shift;
1176
1177    # confirm it exists first
1178    if ((!$grabbers->{$proggy}) && (!$postprocessors->{$proggy})) {
1179        printf "No such grabber/postprocessor: \"%s\".\n",$proggy;
1180        return;
1181    }
1182    print "Disabling $proggy.\n";
1183
1184    if ($grabbers->{$proggy}) {
1185        $grabbers->{$proggy}->{disabled} = 1;
1186        $grabbers->{$proggy}->{laststatus} = sprintf "manually disabled on %s",(strftime "%a%d%b%y", localtime(time));
1187    } elsif ($postprocessors->{$proggy}) {
1188        $postprocessors->{$proggy}->{disabled} = 1;
1189        $postprocessors->{$proggy}->{laststatus} = sprintf "manually disabled on %s",(strftime "%a%d%b%y", localtime(time));
1190    }
1191    $made_changes = 1;
1192}
1193
1194sub set_order
1195{
1196    my ($quiet,$order) = @_;
1197    $pref_order = $order if ($order);
1198
1199    # reset current order to zero
1200    foreach my $proggy (keys %$grabbers) {
1201        $grabbers->{$proggy}->{order} = 0;
1202    }
1203
1204    # and now set order
1205    my $order_num = 1;
1206    if ($pref_order) {
1207        foreach my $proggy (split(/,/,$pref_order)) {
1208            if (defined $grabbers->{$proggy}) {
1209                $grabbers->{$proggy}->{order} = $order_num;
1210                $order_num++;
1211            }
1212        }
1213    }
1214
1215    # set order of any grabbers not specified in a random manner
1216    foreach my $proggy (sort keys %$grabbers) {
1217        if ((!defined $grabbers->{$proggy}->{order}) || ($grabbers->{$proggy}->{order} == 0)) {
1218            $grabbers->{$proggy}->{order} = $order_num+int(rand(1000));
1219        }
1220    }
1221
1222    # .. and finally normalize the order (& show the user the order we chose)
1223    print "Grabber order set as follows:\n" unless $quiet;
1224    $order_num = 0;
1225    foreach my $proggy (sort { $grabbers->{$a}->{order} <=> $grabbers->{$b}->{order} } keys %$grabbers) {
1226        $order_num++;
1227        $grabbers->{$proggy}->{order} = $order_num;
1228        printf " #%d. %s%s\n",$grabbers->{$proggy}->{order},$proggy,($grabbers->{$proggy}->{disabled} ? " [disabled]" : "") unless $quiet;
1229    }
1230
1231    $made_changes = 1;
1232}
1233
1234sub check
1235{
1236    my $result;
1237    foreach my $proggy (keys %$grabbers) {
1238        $result = test_proggy("$GRABBER_DIR/$proggy","$GRABBER_DIR/$proggy/$proggy");
1239        printf "Grabber %s: %s\n",$proggy,($result ? "OK" : "Failed");
1240        if (!$result ne !$grabbers->{$proggy}->{ready}) {
1241            $grabbers->{$proggy}->{ready} = $result;
1242            $made_changes = 1;
1243        }
1244    }
1245
1246    foreach my $proggy (keys %$postprocessors) {
1247        $result = test_proggy("$POSTPROCESSOR_DIR/$proggy","$POSTPROCESSOR_DIR/$proggy/$proggy");
1248        printf "Postprocessor %s: %s\n",$proggy,($result ? "OK" : "Failed");
1249        if (!$result ne !$postprocessors->{$proggy}->{ready}) {
1250            $postprocessors->{$proggy}->{ready} = $result;
1251            $made_changes = 1;
1252        }
1253    }
1254}
1255
1256# -----------------------------------------
1257# Subs: Setup
1258# -----------------------------------------
1259
1260sub read_config_file
1261{
1262    read_file($config_file, 'configuration');
1263
1264    # if we are updating from a previous rev of shepherd.conf we may not
1265    # have any 'order' fields set .. check here
1266    my $found_order = 1;
1267    foreach (keys %$grabbers)
1268    {
1269        $found_order = 0 if (!defined $grabbers->{$_}->{order});
1270    }
1271    if (($found_order == 0) && (!$opt->{setorder}))
1272    {
1273        # at least one 'order' was missing .. we need to put it in!
1274        printf "Legacy shepherd.conf file didn't contain any grabber order! Automatically updating using a random order, use --setorder to manually set this if you care.\n";
1275        &set_order(1);
1276    }
1277
1278    # if a mirror has been specified, add it into our config
1279    if ($opt->{mirror}) {
1280        $mirror_site = $opt->{mirror};
1281        $made_changes = 1;
1282        print "Adding mirror: $mirror_site\n";
1283    }
1284}
1285
1286sub read_channels_file
1287{
1288    read_file($channels_file, 'channels');
1289}
1290
1291sub read_file
1292{
1293    my $fn = shift;
1294    my $name = shift;
1295
1296    print "Reading $name file: $fn\n";
1297    unless (-r $fn)
1298    {
1299        unless ($opt->{configure})
1300        {
1301            print "\nNo $name file found.\n" .
1302                  ucfirst($progname) . " must be configured: " .
1303                  "configuring now.\n\n";
1304            $opt->{'configure'} = 1;
1305        }
1306        return;
1307    }
1308    local (@ARGV, $/) = ($fn);
1309    no warnings 'all';
1310    eval <>;
1311    if ($@ and !$opt->{configure})
1312    {
1313        die "\nError in $name file!\nDetails:\n$@";
1314    }
1315}
1316
1317sub write_config_file
1318{
1319    open(CONF, ">$config_file") or die "cannot write to $config_file: $!";
1320    print CONF Data::Dumper->Dump(
1321        [$region,  $pref_order,  $mirror_site,  $grabbers, $postprocessors  ],
1322        ["region", "pref_order", "mirror_site", "grabbers", "postprocessors" ]);
1323    close CONF;
1324    print "\nUpdated configuration file $config_file.\n" if ($debug);
1325}
1326
1327sub write_channels_file
1328{
1329    open(CHAN, ">$channels_file") or die "cannot write to $channels_file: $!";
1330    print CHAN Data::Dumper->Dump([$channels], ["channels"]);
1331    close CHAN;
1332    print "Updated channels file $channels_file.\n" if ($debug);
1333}
1334
1335sub get_initial_command_line_options
1336{
1337  GetOptions( 'config-file=s'   => \$opt->{configfile},
1338              'help'            => \$opt->{help},
1339              'configure'       => \$opt->{configure},
1340              'mirror=s'        => \$opt->{mirror},
1341              'debug'           => \$debug);
1342}
1343
1344sub get_remaining_command_line_options
1345{
1346    GetOptions(
1347              'version'         => \$opt->{status},
1348              'status'          => \$opt->{status},
1349              'list'            => \$opt->{list},
1350              'show-config'     => \$opt->{show_config},
1351
1352              'update'          => \$opt->{update},
1353              'noupdate'        => \$opt->{noupdate},
1354
1355              'disable=s'       => \$opt->{disable},
1356              'enable=s'        => \$opt->{enable},
1357              'setorder=s'      => \$opt->{setorder},
1358
1359              'days=i'          => \$days,
1360              'offset=i'        => \$opt->{offset},
1361              'show-channels'   => \$opt->{show_channels},
1362              'output=s'        => \$opt->{output},
1363              'check'           => \$opt->{check}
1364            );
1365}
1366
1367
1368# -----------------------------------------
1369# Subs: Configuration
1370# -----------------------------------------
1371
1372sub configure
1373{
1374    my $REGIONS = {
1375        "ACT" => 126,
1376        "NSW: Sydney" => 73,
1377        "NSW: Newcastle" => 184,
1378        "NSW: Central Coast" => 66,
1379        "NSW: Griffith" => 67,
1380        "NSW: Broken Hill" => 63,
1381        "NSW: Northern NSW" => 69,
1382        "NSW: Southern NSW" => 71,
1383        "NSW: Remote and Central" => 106,
1384        "NT: Darwin" => 74,
1385        "NT: Remote & Central" => 108,
1386        "QLD: Brisbane" => 75,
1387        "QLD: Gold Coast" => 78,
1388        "QLD: Regional" => 79,
1389        "QLD: Remote & Central" => 114,
1390        "SA: Adelaide" => 81,
1391        "SA: Renmark" => 82,
1392        "SA: Riverland" => 83,
1393        "SA: South East SA" => 85,
1394        "SA: Spencer Gulf" => 86,
1395        "SA: Remote & Central" => 107,
1396        "Tasmania" => 88,
1397        "VIC: Melbourne" => 94,
1398        "VIC: Geelong" => 93,
1399        "VIC: Eastern Victoria" => 90,
1400        "VIC: Mildura/Sunraysia" => 95,
1401        "VIC: Western Victoria" => 98,
1402        "WA: Perth" => 101,
1403        "WA: Regional" => 102
1404    };
1405
1406    print "\nConfiguring.\n\n" .
1407          "Select your region:\n";
1408    foreach (sort keys %$REGIONS)
1409    {
1410        printf(" (%3d) %s\n", $REGIONS->{$_}, $_);
1411    }
1412    $region = ask_choice("Enter region code:", "94", values %$REGIONS);
1413
1414    print "\nFetching channel information... ";
1415
1416    my @channellist = get_channels();
1417
1418    print "done.\n\n" .
1419          "For each channel you want guide data for, enter an XMLTV id\n" .
1420          "of your choice (e.g. \"seven.free.au\"). If you don't need\n" .
1421          "guide data for this channel, just press Enter.\n\n" .
1422          "Please don't subscribe to unneeded channels.\n\nChannels:\n";
1423    $channels = {};
1424    my $line;
1425    foreach (@channellist)
1426    {
1427        $line = ask(" \"$_\"? ");
1428        $channels->{$_} = $line if ($line);
1429    }
1430
1431
1432    print "\nRandomly selecting grabber order.\n\n";
1433    set_order(0);
1434
1435    show_channels();
1436    unless(ask_boolean("\nCreate configuration file?"))
1437    {
1438        print "Aborting configuration.\n";
1439        exit 0;
1440    }
1441
1442    write_config_file();
1443    write_channels_file();
1444
1445    print "Finished configuring.\n\n" .
1446          "Shepherd is installed into $CWD.\n\n";
1447   
1448    if ($invoked ne "$CWD/$progname" and $invoked =~ /$progname/)
1449    {
1450        print "Warning: you invoked this program as $invoked.\n" .
1451            "In the future, it should be run as $CWD/$progname,\n" .
1452            "to avoid constantly re-downloading the latest version.\n\n" .
1453            "MythTV users may wish to create the following symlink, by " .
1454            "doing this (as root):\n" .
1455            "\"ln -s $CWD/$progname /usr/bin/tv_grab_au\".\n\n" .
1456            "You may safely delete $invoked.\n\n";
1457    }
1458
1459    status();
1460
1461    unless (ask_boolean("\nGrab data now?"))
1462    {
1463        exit 0;
1464    }
1465}
1466
1467sub get_channels
1468{
1469    my @date = localtime;
1470    my $page = LWP::Simple::get(
1471        "http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
1472        ($date[5] + 1900) . "-$date[4]-$date[3]");
1473    my @channellist;
1474    while ($page =~ /<tr class=rtb><td class=rth><a .*?>(.*?)<\/a>/g)
1475    {
1476        push @channellist, $1;
1477    }
1478    return @channellist;
1479}
1480
1481# -----------------------------------------
1482# Subs: Status & Help
1483# -----------------------------------------
1484
1485sub show_config
1486{
1487    print "\nConfiguration\n".
1488          "-------------\n" .
1489          "Config file: $config_file\n" .
1490          "Debug mode : " . is_set($debug) . "\n" .
1491          "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
1492          "Region ID  : $region\n";
1493  show_channels();
1494  print "\n";
1495  status();
1496  print "\n";
1497}
1498
1499sub show_channels
1500{
1501  print "Subscribed channels:\n";
1502  print "    $_ -> $channels->{$_}\n" for sort keys %$channels;
1503}
1504
1505sub is_set
1506{
1507    my $arg = shift;
1508    return $arg ? "Yes" : "No";
1509}
1510
1511sub status
1512{
1513    print " Grabber           Version Enabled Ready Last Run   Status\n" .
1514          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
1515    foreach (sort { $grabbers->{$a}->{order} <=> $grabbers->{$b}->{order} } keys %$grabbers) {
1516        my $h = $grabbers->{$_};
1517        printf  " %-16s %8s %4s %6s  %11s %s\n",
1518                "$h->{order}. $_",
1519                ($h->{ver} ? $h->{ver} : "unknown"),
1520                $h->{disabled} ? '' : 'Y',
1521                $h->{ready} ? 'Y' : '',
1522                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1523                $h->{laststatus} ? $h->{laststatus} : '';
1524    }
1525    printf "Grabbers shown in order of preference.\n\n";
1526
1527    print " Postprocessor     Version Enabled Ready Last Run   Status\n" .
1528          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
1529    foreach (sort { $postprocessors->{$a} <=> $postprocessors->{$b} } keys %$postprocessors) {
1530        my $h = $postprocessors->{$_};
1531        printf  " %-16s %8s %4s %6s  %11s %s\n",
1532                $_,
1533                ($h->{ver} ? $h->{ver} : "unknown"),
1534                $h->{disabled} ? '' : 'Y',
1535                $h->{ready} ? 'Y' : '',
1536                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1537                $h->{laststatus} ? $h->{laststatus} : '';
1538    }
1539    printf "Postprocessors shown in order of execution.\n\n";
1540}
1541
1542sub help
1543{
1544    print q{
1545Command-line options:
1546    --help                Print this message
1547
1548    --status              Print a list of grabbers maintained
1549    --list                Print a detailed list of grabbers
1550    --mirror <s>          Set URL <s> as primary location to check for updates
1551
1552    --configure           Setup
1553    --show-config         Print setup details
1554
1555    --setorder <s>        Set order of grabbers to <s> (comma-seperated list of grabbers)
1556
1557    --disable <s>         Don't ever use grabber/postprocessor <s>
1558    --enable <s>          Okay, maybe use it again then
1559    --uninstall <s>       Remove a disabled grabber/postprocessor
1560
1561    --noupdate            Do not attempt to update before running
1562    --update              Update only; do not grab data
1563
1564    --check               Check status of all grabbers and postprocessors
1565};
1566    exit 0;
1567}
1568
1569# -----------------------------------------
1570# Subs: override handlers for standard perl.
1571# -----------------------------------------
1572
1573# ugly hack. please don't try this at home kids!
1574sub my_die {
1575    my ($arg,@rest) = @_;
1576    my ($pack,$file,$line,$sub) = caller(1);
1577
1578    # check if we are in an eval()
1579    if ($^S) {
1580        printf STDERR "  shepherd caught a die() within eval{} from file $file line $line\n";
1581    } else {
1582        if (!ref($arg)) {
1583            CORE::die((sprintf "DIE at line %d in file %s: %s\n",$line,$file,(join("",($arg,@rest)))));
1584        } else {
1585            CORE::die($arg,@rest);
1586        }
1587    }
1588}
Note: See TracBrowser for help on using the browser.