| [72] | 1 | #!/usr/bin/perl -w |
|---|
| 2 | |
|---|
| 3 | # "reconciler mk2": shepherd XMLTV data reconciler |
|---|
| 4 | # * to be used as a postprocessor for XMLTV data |
|---|
| 5 | # * takes the output from multiple XMLTV sources and combines them |
|---|
| 6 | # (hopefully taking the best data from each) |
|---|
| 7 | # * can be used in conjunction with 'shepherd' XMLTV reconciler or standalone (pipe-through) |
|---|
| 8 | # * can be used in conjunction with 'shepherd' channels.conf channels_file (but not necessary |
|---|
| 9 | # if input XMLTV grabbers populate <channel>..</channel> section properly |
|---|
| 10 | # * no configuration necessary |
|---|
| 11 | # |
|---|
| 12 | # changelog: |
|---|
| 13 | # 0.01 07aug06 initial version |
|---|
| 14 | # 0.02 11aug06 complete rewrite, new algorithms, seperate out from shepherd |
|---|
| 15 | # 0.03 15aug06 first committed |
|---|
| [73] | 16 | # 0.04 17aug06 bug fix: use our own parse_xmltv_date, Date::Manip seems broken |
|---|
| 17 | # bug fix: correctly parse some XMLTV rare fields |
|---|
| [72] | 18 | |
|---|
| 19 | # |
|---|
| 20 | # reconciles programme listings using the following logic: |
|---|
| 21 | # sort programmes into per-channel and per-timeslot |
|---|
| 22 | # for each channel: |
|---|
| 23 | # 1. for programmes with a common start & stop time, evaluate them to see |
|---|
| 24 | # if they are the same programme using fuzzy title matching. |
|---|
| 25 | # use "majority voting" to decide which programme wins if titles differ. |
|---|
| 26 | # 2. for programmes that start within 10 minutes of each other, try to |
|---|
| 27 | # see if they are the same programme (fuzzy title matching), merging |
|---|
| 28 | # data between them |
|---|
| 29 | # 3. as a tie-breaker, prefer data based on order of grabber data we are |
|---|
| 30 | # fed. i.e. first data file takes preference over second data file, etc. |
|---|
| 31 | # |
|---|
| 32 | # other features: |
|---|
| 33 | # - will automatically split titles with "title: subtitle" into "title" and |
|---|
| 34 | # "subtitle" (controlled via $reclogic{min_title_for_colon_title_split}) |
|---|
| 35 | # - will try to match "same titles" (including fuzzy title matching) for |
|---|
| 36 | # duplicate programmes within 10 minutes (or whatever |
|---|
| 37 | # $reclogic{fuzzy_match_title_time_window} is set to) |
|---|
| 38 | # - will automatically move start/stop times (up to a max of 5 minutes or whatever |
|---|
| 39 | # $reclogic{max_prog_length_for_rejig} is set to) whenever programming |
|---|
| 40 | # overlaps occur. logic for when-to-delete versus when-to-cutoff are |
|---|
| 41 | # controlled via $reclogic{min_prog_length_for_delete_cutoff} and |
|---|
| 42 | # $reclogic{delete_window_smaller_than_prog_window_threshold} |
|---|
| 43 | # - will remove all timezones from data (can be disabled by removing setting |
|---|
| 44 | # $reclogic{always_rewrite_start_stop_without_timezone} |
|---|
| 45 | |
|---|
| 46 | |
|---|
| 47 | # processing uses the following tables: |
|---|
| 48 | # |
|---|
| 49 | # order in which we read datafiles: |
|---|
| 50 | # number of datafiles: $in->{num_datafiles); |
|---|
| 51 | # order of datafiles: $in->{datafile_order}->[n] = $proggy; |
|---|
| 52 | # map datafile-to-grabber: $in->{datafile}->{$datafile} = $proggy; |
|---|
| 53 | # map grabber-to-datafile: $in->{data}->{$proggy}->{file} = $datafile; |
|---|
| 54 | # grabber version: $in->{data}->{$proggy}->{version} = $version; |
|---|
| 55 | # |
|---|
| 56 | # channels list: |
|---|
| 57 | # channel list: $in->{channels}->{$chan}->{lang}->{$lang} = $desc |
|---|
| 58 | # |
|---|
| 59 | # programme tables: |
|---|
| 60 | # $in->{tree}->{$chan}->{"start:stop"}->{progs}->[n] |
|---|
| 61 | # $in->{tree}->{$chan}->{"start:stop"}->{numprogs} |
|---|
| 62 | # $in->{total_progs}->{$chan} |
|---|
| 63 | # $in->{total_progs_in}->{$chan}, $in->{total_progs_out}->{$chan} |
|---|
| 64 | # |
|---|
| 65 | # misc tables: |
|---|
| 66 | # encoding we are using: $in->{encoding} |
|---|
| 67 | # where we sourced data from: $in->{sources} |
|---|
| 68 | # duplicate checking: $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key} |
|---|
| 69 | # channel list: $in->{channels}->{$chan}->{$lang} = $desc |
|---|
| 70 | |
|---|
| 71 | |
|---|
| 72 | use strict; |
|---|
| 73 | $| = 1; |
|---|
| 74 | BEGIN { *CORE::GLOBAL::die = \&my_die; } |
|---|
| 75 | |
|---|
| 76 | my $progname = "reconciler_mk2"; |
|---|
| [73] | 77 | my $version = "0.04_15aug06"; |
|---|
| [72] | 78 | |
|---|
| 79 | use LWP::UserAgent; |
|---|
| 80 | use Time::HiRes qw(gettimeofday tv_interval); |
|---|
| 81 | use XMLTV; |
|---|
| 82 | use XMLTV::ProgressBar; |
|---|
| 83 | use POSIX qw(strftime mktime); |
|---|
| 84 | use Getopt::Long; |
|---|
| 85 | use HTML::TreeBuilder; |
|---|
| 86 | use Data::Dumper; |
|---|
| 87 | use Compress::Zlib; |
|---|
| 88 | use Cwd; |
|---|
| 89 | |
|---|
| 90 | #### reconciler settings #### |
|---|
| 91 | my %reclogic; |
|---|
| 92 | |
|---|
| 93 | ### ******************************************************************************* |
|---|
| 94 | ### *** NOTE: all of these can be overridden through a (site local) config file *** |
|---|
| 95 | ### ******************************************************************************* |
|---|
| 96 | ### Doing that is HIGHLY PREFERABLE to CHANGING THIS FILE! |
|---|
| 97 | ### remember that Shepherd may upgrade this automatically from time-to-time, |
|---|
| 98 | ### causing any changes here to be LOST! |
|---|
| 99 | |
|---|
| 100 | # |
|---|
| 101 | # reconciler logic settings |
|---|
| 102 | # |
|---|
| 103 | |
|---|
| 104 | # delete_window_smaller_than_prog_window_threshold: |
|---|
| 105 | $reclogic{delete_window_smaller_than_prog_window_threshold} = (5*60); # 5 mins each side |
|---|
| 106 | |
|---|
| 107 | # min_prog_length_for_delete_cutoff: |
|---|
| 108 | $reclogic{min_prog_length_for_delete_cutoff} = (10*60); # prog needs to be at least 10 mins if we're cutting back |
|---|
| 109 | |
|---|
| 110 | # max_prog_length_for_rejig: |
|---|
| 111 | $reclogic{max_prog_length_for_rejig} = (10*60); # allow programme times to be changed by at-most 10 mins |
|---|
| 112 | |
|---|
| 113 | $reclogic{fuzzy_match_title_time_window} = (10*60); # attempt title matches within +/- 10 min window |
|---|
| 114 | |
|---|
| 115 | # always rewrite XMLTV 'start' & 'stop', removing timezone |
|---|
| 116 | $reclogic{always_rewrite_start_stop_without_timezone} = 1; |
|---|
| 117 | |
|---|
| 118 | # when we have a title with a ": " in the middle but no subtitle, split |
|---|
| 119 | # the title into "title: subtitle" provided title & subtitle are each at least |
|---|
| 120 | # 5 characters long |
|---|
| 121 | $reclogic{min_title_for_colon_title_split} = 5; |
|---|
| 122 | |
|---|
| 123 | # don't accept programmes that last for longer than 8 hours. |
|---|
| 124 | $reclogic{max_programme_length} = (8 * 60 * 60); # 8 hours |
|---|
| 125 | |
|---|
| 126 | |
|---|
| 127 | # |
|---|
| 128 | # warning messages |
|---|
| 129 | # |
|---|
| 130 | |
|---|
| 131 | $reclogic{warn_on_encoding_differences} = 0; # don't warn on encoding differences between XMLTV files |
|---|
| 132 | $reclogic{warn_on_no_title} = 1; # do warn on programme with no title |
|---|
| 133 | $reclogic{warn_on_no_channel} = 1; # do warn on programme with no channel |
|---|
| 134 | $reclogic{warn_on_unknown_channel} = 1; # do warn on programme with unknown channel |
|---|
| 135 | $reclogic{warn_on_invalid_time_in_prog} = 1; # do warn on programme with bad time format |
|---|
| 136 | $reclogic{warn_on_overlapping_programmes_always} = 0; # don't warn on all overlapping programmes from same source |
|---|
| 137 | $reclogic{warn_on_overlapping_programmes_for_different_title} = 1; # do warn on overlapping programmes from same source with different names |
|---|
| 138 | $reclogic{warn_on_invalid_time_in_prog} = 1; # do warn on a programme with a duration that is too long |
|---|
| 139 | |
|---|
| 140 | # |
|---|
| 141 | # debug messages |
|---|
| 142 | # |
|---|
| 143 | |
|---|
| 144 | $reclogic{debug_parse_time} = 0; # don't show debugging when parsing input time |
|---|
| 145 | $reclogic{debug_reconcile} = 0; # don't show reconciler logic |
|---|
| 146 | $reclogic{debug_reconcile_pass1} = 0; # don't show verbose pass 1 reconciler logic |
|---|
| 147 | $reclogic{debug_reconcile_pass2} = 0; # don't show verbose pass 2 reconciler logic |
|---|
| 148 | $reclogic{debug_add_logic} = 0; # don't show add logic debugging messages |
|---|
| 149 | $reclogic{debug_add_logic_verbose} = 0; # don't show add logic verbose debugging messages |
|---|
| 150 | $reclogic{debug_delete_logic} = 0; # don't show delete logic debugging messages |
|---|
| 151 | $reclogic{debug_show_nonmatching_title_alternatives} = 0; # don't show non-matching alternative debugging messages |
|---|
| 152 | $reclogic{debug_find_prog_to_add} = 0; # don't show add_multiple logic debugging messages |
|---|
| 153 | $reclogic{debug_print_programme_list} = 0; # don't show programme listings while writing |
|---|
| 154 | $reclogic{debug_subtitle_derived_from_title} = 0; # don't show subtitles mapped from titles |
|---|
| 155 | |
|---|
| 156 | #### end reconciler settings #### |
|---|
| 157 | |
|---|
| 158 | |
|---|
| 159 | # |
|---|
| 160 | # some initial cruft |
|---|
| 161 | # |
|---|
| 162 | |
|---|
| 163 | my $script_start_time = [gettimeofday]; |
|---|
| 164 | my %stats; |
|---|
| 165 | my $datafile; |
|---|
| 166 | my $channels; |
|---|
| 167 | my $in = { }; |
|---|
| 168 | my $out = { }; |
|---|
| 169 | my $w; |
|---|
| 170 | |
|---|
| 171 | my %amp; |
|---|
| 172 | BEGIN { %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } ) } |
|---|
| 173 | |
|---|
| 174 | |
|---|
| 175 | # |
|---|
| 176 | # parse command line |
|---|
| 177 | # |
|---|
| 178 | |
|---|
| 179 | my $opt = { }; |
|---|
| 180 | $opt->{output_file} = cwd()."/".$progname.".xmltv"; |
|---|
| 181 | $opt->{log_file} = cwd()."/".$progname.".log"; |
|---|
| 182 | $opt->{alt_title_file} = cwd()."/".$progname.".alt_title.log"; |
|---|
| 183 | $opt->{lang} = "en"; |
|---|
| 184 | |
|---|
| 185 | GetOptions( |
|---|
| 186 | 'region=i' => \$opt->{region}, # silently ignored |
|---|
| 187 | 'days=i' => \$opt->{days}, # silently ignored |
|---|
| 188 | 'offset=i' => \$opt->{offset}, # silently ignored |
|---|
| 189 | 'timezone=s' => \$opt->{timezone}, # silently ignored |
|---|
| 190 | |
|---|
| 191 | 'channels_file=s' => \$opt->{channels_file}, |
|---|
| 192 | 'config-file=s' => \$opt->{config_file}, |
|---|
| 193 | 'log=s' => \$opt->{log_file}, |
|---|
| 194 | 'alt-title-file=s' => \$opt->{alt_title_file}, |
|---|
| 195 | 'output=s' => \$opt->{output_file}, |
|---|
| 196 | 'debug+' => \$opt->{debug}, |
|---|
| 197 | 'lang=s' => \$opt->{lang}, |
|---|
| 198 | 'option=s' => \%reclogic, |
|---|
| 199 | |
|---|
| 200 | 'print_listing' => \$reclogic{debug_print_programme_list}, |
|---|
| 201 | |
|---|
| 202 | 'help' => \$opt->{help}, |
|---|
| 203 | 'verbose' => \$opt->{help}, |
|---|
| 204 | 'list_options' => \$opt->{help}, |
|---|
| 205 | 'version' => \$opt->{version}, |
|---|
| 206 | 'ready' => \$opt->{ready}, |
|---|
| 207 | 'desc' => \$opt->{desc}, |
|---|
| 208 | 'v' => \$opt->{version}); |
|---|
| 209 | |
|---|
| 210 | printf "%s v%s\n",$progname,$version; |
|---|
| 211 | |
|---|
| 212 | if ($opt->{version} || $opt->{desc} || $opt->{help} || $opt->{ready} || $opt->{configure} || $opt->{output_file} eq "") { |
|---|
| 213 | printf "A reconciler for multiple XMLTV data sources.\n" if $opt->{desc}; |
|---|
| 214 | printf "$progname is ready for operation.\n" if ($opt->{ready}); |
|---|
| 215 | |
|---|
| 216 | printf "No --output file specified.\n" if ($opt->{output_file} eq ""); |
|---|
| 217 | |
|---|
| 218 | if ($opt->{help} || $opt->{output_file} eq "") { |
|---|
| 219 | print<<EOF |
|---|
| 220 | |
|---|
| 221 | usage: $0 [options] {FILE(s)} |
|---|
| 222 | |
|---|
| 223 | Supported options include: |
|---|
| 224 | --ready verify that '$progname' is ready for operation |
|---|
| 225 | |
|---|
| 226 | --lang={lang} set language to {lang} (default: $opt->{lang}) |
|---|
| 227 | --channels_file={file} use channels file to augment list of channels (default: don't) |
|---|
| 228 | --output={file} send final XMLTV output to {file} (default: $opt->{output_file}) |
|---|
| 229 | --debug enable debugging |
|---|
| 230 | |
|---|
| 231 | --print_listing print out programme listing of chosen programs |
|---|
| 232 | |
|---|
| 233 | --config-file={file} config file for default overrides (default: none) |
|---|
| 234 | --log={file} write (detailed) log file in {file} (default: $opt->{log_file}) |
|---|
| 235 | --alt-title-file={file} write details of possible alternate titles into {file} (default: $opt->{alt_title_file}) |
|---|
| 236 | |
|---|
| 237 | --list_options list all possible options |
|---|
| 238 | --option {opt}={val} set option {opt} to value {val} |
|---|
| 239 | EOF |
|---|
| 240 | ; |
|---|
| 241 | foreach my $key (sort keys %reclogic) { |
|---|
| 242 | if (($key =~ /^warn_on_/) || ($key =~ /^debug_/)) { |
|---|
| 243 | my $thiskey = sprintf "%s=%d",$key,($reclogic{$key} ? 0 : 1); |
|---|
| 244 | printf " --option %-30s %sable %s '%s' (default: %s)\n", $thiskey, ($reclogic{$key} ? "dis" : "en"), |
|---|
| 245 | ($key =~ /^warn_on/ ? "warning" : "debug"), $key, ($reclogic{$key} ? "do" : "don't"); |
|---|
| 246 | } else { |
|---|
| 247 | my $thiskey = $key."={val}"; |
|---|
| 248 | printf " --option %-30s set '%s' to {val} (default: %s)\n",$thiskey,$key,$reclogic{$key}; |
|---|
| 249 | } |
|---|
| 250 | } |
|---|
| 251 | } |
|---|
| 252 | exit(0); |
|---|
| 253 | } |
|---|
| 254 | |
|---|
| 255 | @ARGV = ('-') if not @ARGV; |
|---|
| 256 | |
|---|
| 257 | # go go go! |
|---|
| 258 | open(LOG_FILE,">$opt->{log_file}") || die "can't open log file $opt->{log_file} for writing: $!\n"; |
|---|
| 259 | open(ALT_TITLE_FILE,">$opt->{alt_title_file}") || die "can't open alt-title-file $opt->{alt_title_file} for writing: $!\n"; |
|---|
| 260 | |
|---|
| 261 | &log(1,(sprintf "started: %s%soutput %s", |
|---|
| 262 | ($opt->{channels_file} ? "channels in $opt->{channels_file}, " : ""), |
|---|
| 263 | ($opt->{config_file} ? "default overrides in $opt->{config_file}, " : ""), |
|---|
| 264 | ($opt->{output_file}))); |
|---|
| 265 | &log(1,(sprintf " logging to %s, alternate titles to %s",$opt->{log_file},$opt->{alt_title_file})); |
|---|
| 266 | |
|---|
| 267 | printf ALT_TITLE_FILE "$progname $version\n"; |
|---|
| 268 | printf ALT_TITLE_FILE "This log file contains lists of what title matches were attempted (but didn't match).\n"; |
|---|
| 269 | printf ALT_TITLE_FILE "The intent of this is to keep a log that we can (hopefully) interpret in order to\n"; |
|---|
| 270 | printf ALT_TITLE_FILE "improve the alternateTitle() logic.\n\n"; |
|---|
| 271 | |
|---|
| 272 | &override_settings; |
|---|
| 273 | |
|---|
| 274 | &read_config_file($opt->{config_file}) if ($opt->{config_file}); |
|---|
| 275 | |
|---|
| 276 | &fill_in_channels if ($opt->{channels_file}); |
|---|
| 277 | |
|---|
| 278 | foreach my $file (@ARGV) { |
|---|
| 279 | $datafile = $file; |
|---|
| 280 | &log(1,(sprintf "Parsing: %s",($datafile eq "-" ? "(from-stdin, hit control-D to finiah)" : $datafile))); |
|---|
| 281 | |
|---|
| 282 | eval { XMLTV::parsefiles_callback(\&encoding_cb, \&credits_cb, \&channel_cb, \&programme_cb, $datafile); }; |
|---|
| 283 | } |
|---|
| 284 | |
|---|
| 285 | &start_writer; |
|---|
| 286 | &write_channels; |
|---|
| 287 | |
|---|
| 288 | &reconcile; |
|---|
| 289 | |
|---|
| 290 | &write_programmes; |
|---|
| 291 | $w->end(); |
|---|
| 292 | |
|---|
| 293 | &print_stats; |
|---|
| 294 | |
|---|
| 295 | close(LOG_FILE); |
|---|
| 296 | close(ALT_TITLE_FILE); |
|---|
| 297 | |
|---|
| 298 | exit(0); |
|---|
| 299 | |
|---|
| 300 | ###################################################################################################### |
|---|
| 301 | # read settings |
|---|
| 302 | |
|---|
| 303 | sub read_config_file |
|---|
| 304 | { |
|---|
| 305 | my $file = shift; |
|---|
| 306 | die "file $file could not be read. aborting.\n" if (!(-r $file)); |
|---|
| 307 | local (@ARGV, $/) = ($file); |
|---|
| 308 | no warnings 'all'; eval <>; die "$@" if $@; |
|---|
| 309 | } |
|---|
| 310 | |
|---|
| 311 | |
|---|
| 312 | ###################################################################################################### |
|---|
| 313 | # debug is actually always enabled (with default settings). |
|---|
| 314 | # --debug will turn on all debugging! |
|---|
| 315 | |
|---|
| 316 | sub override_settings |
|---|
| 317 | { |
|---|
| 318 | foreach my $key (sort keys %reclogic) { |
|---|
| 319 | if ($key !~ /^debug_/) { |
|---|
| 320 | if ($key =~ /^warn_on_/) { |
|---|
| 321 | &log(1,(sprintf "warning %s is %s",$key,($reclogic{$key} ? "enabled" : "disabled; enable with --option $key"))); |
|---|
| 322 | } else { |
|---|
| 323 | &log(1,(sprintf "%s is set to %s",$key,$reclogic{$key})); |
|---|
| 324 | &log(1,(sprintf " override using config-file option: %s\{%s\}=%s;","reclogic",$key,$reclogic{$key})); |
|---|
| 325 | } |
|---|
| 326 | } |
|---|
| 327 | } |
|---|
| 328 | |
|---|
| 329 | foreach my $key (sort keys %reclogic) { |
|---|
| 330 | if ($key =~ /^debug_/) { |
|---|
| 331 | $reclogic{$key} = 1 if ($opt->{debug}); |
|---|
| 332 | &log(1,(sprintf "debug setting %s is %s",$key,($reclogic{$key} ? "enabled" : "disabled; enable with --option $key"))); |
|---|
| 333 | } |
|---|
| 334 | } |
|---|
| 335 | } |
|---|
| 336 | |
|---|
| 337 | ###################################################################################################### |
|---|
| 338 | # we use our own die() routing to circumvent die() within eval statements where we are |
|---|
| 339 | # calling the standard XMLTV::parsefiles. |
|---|
| 340 | # this prevents bad XML from causing the reconciler to completely fail. |
|---|
| 341 | |
|---|
| 342 | # ugly hack. please don't try this at home kids! |
|---|
| 343 | |
|---|
| 344 | sub my_die { |
|---|
| 345 | my ($arg,@rest) = @_; |
|---|
| 346 | my ($pack,$file,$line,$sub) = caller(1); |
|---|
| 347 | |
|---|
| 348 | # check if we are in an eval() |
|---|
| 349 | if ($^S) { |
|---|
| 350 | printf STDERR " caught a die() within eval{} from file $file line $line\n"; |
|---|
| 351 | } else { |
|---|
| 352 | if (!ref($arg)) { |
|---|
| 353 | printf STDERR "DIE at line %d in file %s\n",$line,$file; |
|---|
| 354 | CORE::die(join("",@rest)); |
|---|
| 355 | } else { |
|---|
| 356 | CORE::die($arg,@rest); |
|---|
| 357 | } |
|---|
| 358 | } |
|---|
| 359 | } |
|---|
| 360 | |
|---|
| 361 | ###################################################################################################### |
|---|
| 362 | # if we are supplied a channels_file, then fill in channels we know about from that. |
|---|
| 363 | # this is useful because some grabbers (e.g. oztivo) don't supply a <channels></channels> |
|---|
| 364 | # section at the top of their xmltv - and if they happen to be the first grabber, |
|---|
| 365 | # this causes issues with programmes with no (known) channel |
|---|
| 366 | |
|---|
| 367 | sub fill_in_channels |
|---|
| 368 | { |
|---|
| 369 | &read_config_file($opt->{channels_file}); |
|---|
| 370 | |
|---|
| 371 | foreach my $ch (sort keys %{$channels}) { |
|---|
| 372 | my $id = $channels->{$ch}; |
|---|
| 373 | |
|---|
| 374 | $in->{channels}->{$id}->{lang}->{($opt->{lang})} = $ch; |
|---|
| 375 | $in->{channels}->{$id}->{pref_desc} = $ch; |
|---|
| 376 | $in->{total_progs}->{$id} = 0; |
|---|
| 377 | $in->{total_progs_in}->{$id} = 0; |
|---|
| 378 | $in->{total_progs_out}->{$id} = 0; |
|---|
| 379 | } |
|---|
| 380 | } |
|---|
| 381 | |
|---|
| 382 | ###################################################################################################### |
|---|
| 383 | |
|---|
| 384 | sub log |
|---|
| 385 | { |
|---|
| 386 | my ($log_to_screen,$entry) = @_; |
|---|
| 387 | printf STDERR "%s [%d] %s\n",$progname, time,$entry if ($log_to_screen); |
|---|
| 388 | printf LOG_FILE "%s [%d] %s\n",$progname, time,$entry; |
|---|
| 389 | } |
|---|
| 390 | |
|---|
| 391 | ###################################################################################################### |
|---|
| 392 | |
|---|
| 393 | sub print_stats |
|---|
| 394 | { |
|---|
| 395 | printf STDERR "%s v%s [%d] completed in %0.2f seconds",$progname, $version, time, tv_interval($script_start_time); |
|---|
| 396 | foreach my $key (sort keys %stats) { |
|---|
| 397 | printf STDERR ",\n\t%d %s", $stats{$key},$key; |
|---|
| 398 | } |
|---|
| 399 | printf STDERR ".\n"; |
|---|
| 400 | } |
|---|
| 401 | |
|---|
| 402 | ###################################################################################################### |
|---|
| 403 | # descend a structure and clean up various things, including stripping |
|---|
| 404 | # leading/trailing spaces in strings, translations of html stuff etc |
|---|
| 405 | # -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au |
|---|
| 406 | |
|---|
| 407 | sub cleanup { |
|---|
| 408 | my $x = shift; |
|---|
| 409 | if (ref $x eq "REF") { cleanup($_) } |
|---|
| 410 | elsif (ref $x eq "HASH") { cleanup(\$_) for values %$x } |
|---|
| 411 | elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x } |
|---|
| 412 | elsif (defined $$x) { |
|---|
| 413 | $$x =~ s/&(#(\d+)|(.*?));/ $2 ? chr($2) : $amp{$3}||' ' /eg; |
|---|
| 414 | # $$x =~ s/[^\x20-\x7f]/ /g; |
|---|
| 415 | $$x =~ s/(^\s+|\s+$)//g; |
|---|
| 416 | } |
|---|
| 417 | } |
|---|
| 418 | |
|---|
| 419 | ###################################################################################################### |
|---|
| [73] | 420 | |
|---|
| 421 | sub parse_xmltv_date |
|---|
| 422 | { |
|---|
| 423 | my $datestring = shift; |
|---|
| 424 | my @timeattr; # = localtime(time); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst |
|---|
| 425 | |
|---|
| 426 | if ($datestring =~ /^(....)(..)(..)(..)(..)/) { |
|---|
| 427 | ($timeattr[5],$timeattr[4],$timeattr[3],$timeattr[2],$timeattr[1],$timeattr[0]) = (int($1)-1900,int($2)-1,int($3),int($4),int($5),0); |
|---|
| 428 | ($timeattr[6],$timeattr[7],$timeattr[8]) = (-1,-1,-1); |
|---|
| 429 | # NOTE: FIXME: we are ignoring timezone for now... |
|---|
| 430 | |
|---|
| 431 | my $return_epoch = mktime(@timeattr); |
|---|
| 432 | return $return_epoch if ($return_epoch > 1); |
|---|
| 433 | } |
|---|
| 434 | |
|---|
| 435 | return undef; |
|---|
| 436 | } |
|---|
| 437 | |
|---|
| 438 | ###################################################################################################### |
|---|
| [72] | 439 | # original alternativeTitles() from XMLTV::IMDB, this one knows about even more translations.. |
|---|
| 440 | |
|---|
| 441 | sub alternativeTitles($) |
|---|
| 442 | { |
|---|
| 443 | my $title=shift; |
|---|
| 444 | my @titles; |
|---|
| 445 | |
|---|
| 446 | push(@titles, $title); # seed with original title |
|---|
| 447 | |
|---|
| 448 | # try "&" -> "and" conversion ('Spicks & Specks' => 'Spicks and Specks') |
|---|
| 449 | if ( $title=~m/\&/o ) { |
|---|
| 450 | my $t=$title; |
|---|
| 451 | push(@titles, $t) while ( $t=~s/(\s)\&(\s)/$1and$2/o ); |
|---|
| 452 | } |
|---|
| 453 | |
|---|
| 454 | # try the "and" -> "&" conversion ('Spicks and Specks' => 'Spicks & Specks') |
|---|
| 455 | if ( $title=~m/\sand\s/io ) { |
|---|
| 456 | my $t=$title; |
|---|
| 457 | push(@titles, $t) while ( $t=~s/(\s)and(\s)/$1\&$2/io ); |
|---|
| 458 | } |
|---|
| 459 | |
|---|
| 460 | # 'Barney Friends' => 'Barney & Friends' |
|---|
| 461 | foreach my $t (@titles) { |
|---|
| 462 | if ($t =~ /^(.*) (.*)$/) { |
|---|
| 463 | push(@titles,"$1 & $2"); |
|---|
| 464 | } |
|---|
| 465 | } |
|---|
| 466 | |
|---|
| 467 | # 'Barney Friends' => 'Barney - Friends' |
|---|
| 468 | foreach my $t (@titles) { |
|---|
| 469 | if ($t =~ /^(.*) (.*)$/) { |
|---|
| 470 | push(@titles,"$1 - $2"); |
|---|
| 471 | } |
|---|
| 472 | } |
|---|
| 473 | |
|---|
| 474 | # "Creflo A. Dollar, Jr" => "Creflo A Dollar" |
|---|
| 475 | # "House, M.D." => "House" |
|---|
| 476 | foreach my $t (@titles) { |
|---|
| 477 | push(@titles,"$1") if ($t =~ /^(.*), Jr$/); |
|---|
| 478 | push(@titles,"$1") if ($t =~ /^(.*), M\.D\.$/); |
|---|
| 479 | } |
|---|
| 480 | |
|---|
| 481 | # "quotes" -> quotes |
|---|
| 482 | foreach my $t (@titles) { |
|---|
| 483 | push(@titles,$1) if ( $t =~ /^\"(.*)\"$/); |
|---|
| 484 | } |
|---|
| 485 | |
|---|
| 486 | # remove full stops - e.g. will translate 'Dr. Dog.' to 'Dr Dog.' and 'Dr Dog' |
|---|
| 487 | foreach my $t (@titles) { |
|---|
| 488 | if ($t =~ /\./) { |
|---|
| 489 | my @new_titles; |
|---|
| 490 | push(@new_titles, $t) while ( $t=~s/(.*)\.(.*)/$1$2/io ); |
|---|
| 491 | push(@titles,@new_titles); |
|---|
| 492 | } |
|---|
| 493 | } |
|---|
| 494 | |
|---|
| 495 | # remove dashes |
|---|
| 496 | foreach my $t (@titles) { |
|---|
| 497 | if ($t =~ /\-/) { |
|---|
| 498 | my @new_titles; |
|---|
| 499 | push(@new_titles, $t) while ( $t=~s/(.*)\-(.*)/$1$2/io ); |
|---|
| 500 | push(@titles,@new_titles); |
|---|
| 501 | } |
|---|
| 502 | } |
|---|
| 503 | |
|---|
| 504 | # # strip *'s: "M*A*S*H" => "MASH"; |
|---|
| 505 | foreach my $t (@titles) { |
|---|
| 506 | if ($t =~ /\*/) { |
|---|
| 507 | my @new_titles; |
|---|
| 508 | push(@new_titles, $t) while ( $t=~s/(.*)\*(.*)/$1$2/io ); |
|---|
| 509 | push(@titles,@new_titles); |
|---|
| 510 | } |
|---|
| 511 | } |
|---|
| 512 | |
|---|
| 513 | # remove !s |
|---|
| 514 | foreach my $t (@titles) { |
|---|
| 515 | if ($t =~ /\'/) { |
|---|
| 516 | my @new_titles; |
|---|
| 517 | push(@new_titles, $t) while ( $t=~s/(.*)\'(.*)/$1$2/io ); |
|---|
| 518 | push(@titles,@new_titles); |
|---|
| 519 | } |
|---|
| 520 | } |
|---|
| 521 | |
|---|
| 522 | # remove :s |
|---|
| 523 | foreach my $t (@titles) { |
|---|
| 524 | if ($t =~ /:/) { |
|---|
| 525 | my @new_titles; |
|---|
| 526 | push(@new_titles, $t) while ( $t=~s/(.*):(.*)/$1$2/io ); |
|---|
| 527 | push(@titles,@new_titles); |
|---|
| 528 | } |
|---|
| 529 | } |
|---|
| 530 | |
|---|
| 531 | # remove apostrophies |
|---|
| 532 | foreach my $t (@titles) { |
|---|
| 533 | if ($t =~ /\!/) { |
|---|
| 534 | my @new_titles; |
|---|
| 535 | push(@new_titles, $t) while ( $t=~s/(.*)!(.*)/$1$2/io ); |
|---|
| 536 | push(@titles,@new_titles); |
|---|
| 537 | } |
|---|
| 538 | } |
|---|
| 539 | |
|---|
| 540 | # remove commas |
|---|
| 541 | foreach my $t (@titles) { |
|---|
| 542 | if ($t =~ /\,/) { |
|---|
| 543 | my @new_titles; |
|---|
| 544 | push(@new_titles, $t) while ( $t=~s/(.*)\,(.*)/$1$2/io ); |
|---|
| 545 | push(@titles,@new_titles); |
|---|
| 546 | } |
|---|
| 547 | } |
|---|
| 548 | |
|---|
| 549 | # strip text after !s provided we have at least one word |
|---|
| 550 | # e.g. will fix 'Jakers! The Adventures of Piggley Winks' to match 'Jakers' |
|---|
| 551 | # or 'Jakers! The Adventures of Piggley Winks' to match 'The Adventures of Piggley Winks' |
|---|
| 552 | foreach my $t (@titles) { |
|---|
| 553 | if ($t =~ /! /) { |
|---|
| 554 | my @t2 = split(/! /,$t); |
|---|
| 555 | push(@titles, @t2); |
|---|
| 556 | } |
|---|
| 557 | } |
|---|
| 558 | |
|---|
| 559 | # 'Message Stick (Shorts)' => 'Message Stick' |
|---|
| 560 | # 'Behind The News (5 Min)' => 'Behind the News' |
|---|
| 561 | # 'Behind The News (5 Min)' => 'Behind the News 5 Min' |
|---|
| 562 | foreach my $t (@titles) { |
|---|
| 563 | if ($t =~ /(.+)\((.+)\)$/) { |
|---|
| 564 | my $t2 = $1; |
|---|
| 565 | my $t3 = $1.$2; |
|---|
| 566 | $t2 =~ s/(^\s+|\s+$)//g; # strip leading/trailing spaces |
|---|
| 567 | $t3 =~ s/(^\s+|\s+$)//g; # strip leading/trailing spaces |
|---|
| 568 | push(@titles,$t2); |
|---|
| 569 | push(@titles,$t3); |
|---|
| 570 | } |
|---|
| 571 | } |
|---|
| 572 | |
|---|
| 573 | # 'Family Story: The Longest Season' => 'Family Story' |
|---|
| 574 | foreach my $t (@titles) { |
|---|
| 575 | if ($t =~ /: /) { |
|---|
| 576 | my @t2 = split(/: /,$t); |
|---|
| 577 | push(@titles, @t2); |
|---|
| 578 | } |
|---|
| 579 | } |
|---|
| 580 | |
|---|
| 581 | # 'Family Story The Longest Season' => 'Family Story: The Longest Season' |
|---|
| 582 | foreach my $t (@titles) { |
|---|
| 583 | if ($t =~ / /) { |
|---|
| 584 | my @t2 = split(/ /,$t); |
|---|
| 585 | push(@titles, @t2); |
|---|
| 586 | } |
|---|
| 587 | } |
|---|
| 588 | |
|---|
| 589 | # #39; -> ' ('He's Having A Baby' => 'He\'s Having a Baby') |
|---|
| 590 | foreach my $t (@titles) { |
|---|
| 591 | my $t2 = $t; |
|---|
| 592 | $t2 =~ s/&(#(\d+)|(.*?));/ $2 ? chr($2) : $amp{$3}||' ' /eg; |
|---|
| 593 | push(@titles,$t2) if ($t2 ne $t); |
|---|
| 594 | } |
|---|
| 595 | |
|---|
| 596 | # 'Head 2 Head' => 'Head To Head' |
|---|
| 597 | foreach my $t (@titles) { |
|---|
| 598 | push(@titles, "$1 to $2") if ($t =~ /(.*) 2 (.*)/); |
|---|
| 599 | } |
|---|
| 600 | |
|---|
| 601 | # remove leading 'The': |
|---|
| 602 | # "Iron Chef" alternatives "The Iron Chef" |
|---|
| 603 | # "The Newshour with Jim Lehrer" alternative "Newshour with Jim Lehrer" |
|---|
| 604 | foreach my $t (@titles) { |
|---|
| 605 | push(@titles,"$1") if ($t =~ /^The (.*)$/); |
|---|
| 606 | } |
|---|
| 607 | |
|---|
| 608 | # strip "With [..]" if at least 10 chars before With |
|---|
| 609 | # "The 7.30 Report With Kerry O'brien" alternatives "The 7.30 Report" |
|---|
| 610 | # "Seven News With Peter Mitchell" alternatives "Seven News" |
|---|
| 611 | # "Today Tonight With Naomi Robson" alternatives "Today Tonight" |
|---|
| 612 | foreach my $t (@titles) { |
|---|
| 613 | if ($t =~/^(.*) [Ww]ith (.*)$/) { |
|---|
| 614 | my $t2 = $1; |
|---|
| 615 | push (@titles, $t2) if (length($t2) >= 10); |
|---|
| 616 | } |
|---|
| 617 | } |
|---|
| 618 | |
|---|
| 619 | # Place the articles last |
|---|
| 620 | # 'The Daily Show' => 'Daily Show, The' |
|---|
| 621 | foreach (@titles) { |
|---|
| 622 | if ( m/^(The|A|Une|Les|Los|Las|L\'|Le|La|El|Das|De|Het|Een)\s+(.*)$/io ) { |
|---|
| 623 | my $t=$_; |
|---|
| 624 | $t=~s/^(The|A|Une|Les|Los|Las|L\'|Le|La|El|Das|De|Het|Een)\s+(.*)$/$2, $1/iog; |
|---|
| 625 | push(@titles, $t); |
|---|
| 626 | } |
|---|
| 627 | } |
|---|
| 628 | |
|---|
| 629 | #foreach my $t (@titles) { printf "alternativeTitles: alternative \"$t\"\n"; } |
|---|
| 630 | |
|---|
| 631 | return(@titles); |
|---|
| 632 | } |
|---|
| 633 | |
|---|
| 634 | ###################################################################################################### |
|---|
| 635 | |
|---|
| 636 | sub encoding_cb( $ ) |
|---|
| 637 | { |
|---|
| 638 | my $e = shift; |
|---|
| 639 | #printf "got encoding ".Dumper($e); |
|---|
| 640 | $in->{encoding} = $e if (!$in->{encoding}); |
|---|
| 641 | |
|---|
| 642 | &log($reclogic{warn_on_encoding_differences}, |
|---|
| 643 | (sprintf"WARNING: encoding '%s' from %s different from %s",$e,$datafile,$in->{encoding})) |
|---|
| 644 | if ($in->{encoding} ne $e); |
|---|
| 645 | } |
|---|
| 646 | |
|---|
| 647 | ###################################################################################################### |
|---|
| 648 | |
|---|
| 649 | sub credits_cb( $ ) |
|---|
| 650 | { |
|---|
| 651 | my $c = shift; |
|---|
| 652 | #printf "got credits ".Dumper($c); |
|---|
| 653 | |
|---|
| 654 | my ($proggy, $version) = split(/ /,$c->{'generator-info-name'}) if $c->{'generator-info-name'}; |
|---|
| 655 | |
|---|
| 656 | $proggy = $datafile if (!defined $proggy); |
|---|
| 657 | $version = "" if (!defined $version); |
|---|
| 658 | |
|---|
| 659 | $in->{data}->{$proggy}->{file} = $datafile; |
|---|
| 660 | $in->{datafile}->{$datafile} = $proggy; |
|---|
| 661 | $in->{data}->{$proggy}->{version} = $version; |
|---|
| 662 | |
|---|
| 663 | if (!defined $in->{num_datafiles}) { |
|---|
| 664 | $in->{num_datafiles} = 0; |
|---|
| 665 | $in->{sources} = "$proggy"; |
|---|
| 666 | } else { |
|---|
| 667 | $in->{sources} .= ",$proggy"; |
|---|
| 668 | } |
|---|
| 669 | |
|---|
| 670 | $in->{datafile_order}->[($in->{num_datafiles})] = $proggy; |
|---|
| 671 | $in->{num_datafiles}++; |
|---|
| 672 | } |
|---|
| 673 | |
|---|
| 674 | ###################################################################################################### |
|---|
| 675 | |
|---|
| 676 | sub channel_cb( $ ) |
|---|
| 677 | { |
|---|
| 678 | my $c = shift; |
|---|
| 679 | #printf "got channel ".Dumper($c); |
|---|
| 680 | |
|---|
| 681 | my $chan = $c->{id}; |
|---|
| 682 | my %chan_lang; |
|---|
| 683 | |
|---|
| 684 | if (defined $c->{'display-name'} && defined $c->{'display-name'}->[0]) { |
|---|
| 685 | foreach my $ch_block ($c->{'display-name'}->[0]) { |
|---|
| 686 | my ($desc,$lang) = ($ch_block->[0],$ch_block->[1]); |
|---|
| 687 | $lang = $opt->{lang} if (!defined $lang); |
|---|
| 688 | $desc = "unknown" if (!defined $desc); |
|---|
| 689 | |
|---|
| 690 | if (!defined $in->{channels}->{$chan}) { |
|---|
| 691 | $in->{channels}->{$chan}->{lang}->{$lang} = $desc; |
|---|
| 692 | $in->{total_progs}->{$chan} = 0; |
|---|
| 693 | $in->{total_progs_in}->{$chan} = 0; |
|---|
| 694 | $in->{total_progs_out}->{$chan} = 0; |
|---|
| 695 | } else { |
|---|
| 696 | $in->{channels}->{$chan}->{lang}->{$lang} = $desc |
|---|
| 697 | if (!defined $in->{channels}->{$chan}->{lang}->{$lang}); |
|---|
| 698 | } |
|---|
| 699 | |
|---|
| 700 | $in->{channels}->{$chan}->{pref_desc} = $desc |
|---|
| 701 | if (!defined $in->{channels}->{$chan}->{pref_desc}); |
|---|
| 702 | } |
|---|
| 703 | } |
|---|
| 704 | } |
|---|
| 705 | |
|---|
| 706 | ###################################################################################################### |
|---|
| 707 | |
|---|
| 708 | sub programme_cb( $ ) |
|---|
| 709 | { |
|---|
| 710 | my $prog=shift; |
|---|
| 711 | # print "got programme from $datafile: ".Dumper($prog); |
|---|
| 712 | |
|---|
| 713 | # make sure programme has a title |
|---|
| 714 | if (!defined $prog->{title} || !defined $prog->{title}->[0]) { |
|---|
| 715 | &log($reclogic{warn_on_no_title},(sprintf "WARNING: programme with no title in %s; ignored.", $datafile)); |
|---|
| 716 | $stats{bad_programme_no_title}++; |
|---|
| 717 | return; |
|---|
| 718 | } |
|---|
| 719 | my $prog_title = $prog->{title}->[0]->[0]; |
|---|
| 720 | my $prog_subtitle; |
|---|
| 721 | $prog_subtitle = $prog->{'sub-title'}->[0]->[0] if (defined $prog->{'sub-title'} && $prog->{'sub-title'}->[0] && $prog->{'sub-title'}->[0]->[0]); |
|---|
| 722 | |
|---|
| 723 | # make sure programme has a channel |
|---|
| 724 | if (!defined $prog->{channel}) { |
|---|
| 725 | &log($reclogic{warn_on_no_channel},(sprintf "WARNING: programme '%s' had no channel information; ignored.", $prog_title)); |
|---|
| 726 | $stats{bad_programme_no_channel}++; |
|---|
| 727 | return; |
|---|
| 728 | } |
|---|
| 729 | my $prog_chan = $prog->{channel}; |
|---|
| 730 | |
|---|
| 731 | # make sure we know about this channel |
|---|
| 732 | if (!defined $in->{channels}->{$prog_chan}) { |
|---|
| 733 | &log($reclogic{warn_on_unknown_channel},(sprintf "WARNING: programme '%s' had unknown channel \"%s\"; ignored.", $prog_title, $prog_chan)); |
|---|
| 734 | $stats{bad_programme_unknown_channel}++; |
|---|
| 735 | return; |
|---|
| 736 | } |
|---|
| 737 | |
|---|
| 738 | my $source = $datafile; |
|---|
| 739 | # $source = $in->{datafile}->{$datafile} if (defined $in->{datafile}->{$datafile}); |
|---|
| 740 | |
|---|
| 741 | # work out epoch times |
|---|
| [73] | 742 | my $t1 = &parse_xmltv_date($prog->{start}); |
|---|
| 743 | my $t2 = &parse_xmltv_date($prog->{stop}); |
|---|
| [72] | 744 | |
|---|
| 745 | if (!$t1 || !$t2) { |
|---|
| 746 | &log($reclogic{warn_on_invalid_time_in_prog}, |
|---|
| 747 | (sprintf "WARNING: programme '%s' on channel '%s' from %s had invalid start (%s) or stop (%s) time; ignored.", |
|---|
| 748 | $prog_title, $prog_chan, $datafile, ($prog->{start} ? $prog->{start} : "undef"), |
|---|
| 749 | ($prog->{stop} ? $prog->{stop} : "undef"))); |
|---|
| 750 | $stats{bad_programme_invalid_times}++; |
|---|
| 751 | return; |
|---|
| 752 | } |
|---|
| 753 | |
|---|
| [73] | 754 | &log($reclogic{debug_parse_time}, |
|---|
| 755 | (sprintf " prog \"%s\" on chan \"%s\" start %s end %s, duration %d, file %s", |
|---|
| 756 | $prog_title, $prog_chan, (strftime "%a%e%b%H:%M", localtime($t1)), |
|---|
| 757 | (strftime "%a%e%b%H%M", localtime($t2)), ($t2 - $t1), $source)) if ($t1 && $t2); |
|---|
| 758 | #printf "got start '%s', turned it into start_epoch '%s'\n",$prog->{start},(strftime "%a %e %b %H %M",localtime($t1)); |
|---|
| 759 | |
|---|
| 760 | if (($t2 - $t1) > $reclogic{max_programme_length}) { |
|---|
| [72] | 761 | &log($reclogic{warn_on_invalid_time_in_prog}, |
|---|
| 762 | (sprintf "WARNING: programme '%s' on channel '%s' from %s had a programme duration (%d) that exceeded max_programme_length (%d): start '%s' stop '%s'; ignored.\n", |
|---|
| [73] | 763 | $prog_title, $prog_chan, $datafile, ($t2-$t1), $reclogic{max_programme_length}, |
|---|
| [72] | 764 | ($prog->{start} ? $prog->{start} : "undef"), ($prog->{stop} ? $prog->{stop} : "undef"))); |
|---|
| 765 | $stats{bad_programme_duration_too_long}++; |
|---|
| 766 | return; |
|---|
| 767 | } |
|---|
| 768 | |
|---|
| [73] | 769 | $prog->{start_epoch} = $t1; |
|---|
| 770 | $prog->{stop_epoch} = $t2; |
|---|
| [72] | 771 | $prog->{grabber} = $source; |
|---|
| 772 | $prog->{grabber_num} = ($in->{num_datafiles}-1); |
|---|
| [73] | 773 | my $prog_key = sprintf "%d:%d",$t1,$t2; |
|---|
| [72] | 774 | |
|---|
| 775 | # if there is a ": " in title and no subtitle, split title into "title: subtitle" |
|---|
| 776 | # provided each of title/subtitle will be at least $reclogic{min_title_for_colon_title_split} |
|---|
| 777 | # characters |
|---|
| 778 | if (!defined $prog_subtitle) { |
|---|
| 779 | my ($title1,$title2) = split(/: /,$prog_title); |
|---|
| 780 | |
|---|
| 781 | if (($title1) && ($title2) && |
|---|
| 782 | (length($title1) >= $reclogic{min_title_for_colon_title_split}) && |
|---|
| 783 | (length($title2) >= $reclogic{min_title_for_colon_title_split})) { |
|---|
| 784 | &log($reclogic{debug_subtitle_derived_from_title}, |
|---|
| 785 | (sprintf "split title \"%s\" into title \"%s\" subtitle \"%s\" since over min_title_for_colon_title_split (%d)", |
|---|
| 786 | $prog_title, $title1, $title2, $reclogic{min_title_for_colon_title_split})); |
|---|
| 787 | $stats{derived_subtitle_from_title}++; |
|---|
| 788 | |
|---|
| 789 | $prog_title = $title1; |
|---|
| 790 | $prog->{title}->[0]->[0] = $title1; |
|---|
| 791 | |
|---|
| 792 | $prog_subtitle = $title2; |
|---|
| 793 | $prog->{'sub-title'}->[0]->[0] = $title2; |
|---|
| 794 | $prog->{'sub-title'}->[0]->[1] = $prog->{'title'}->[0]->[1]; |
|---|
| 795 | } |
|---|
| 796 | |
|---|
| 797 | } |
|---|
| 798 | |
|---|
| 799 | # check to see if this grabber has supplied a programme with this start/stop on this |
|---|
| 800 | # channel already. if there is, whinge about it & drop the duplicate |
|---|
| 801 | if (defined $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key}) { |
|---|
| 802 | # record statistic but don't print error message if programme names actually match |
|---|
| 803 | my $warn = (($reclogic{warn_on_overlapping_programmes_always}) || |
|---|
| 804 | (($reclogic{warn_on_overlapping_programmes_for_different_title}) && |
|---|
| 805 | ($prog_title ne $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key}))); |
|---|
| 806 | &log($warn,(sprintf "WARNING: file contained more than one programme in same timeslot: channel '%s' start %s, stop %s, programs \"%s\" and \"%s\"; ignored.", |
|---|
| 807 | $prog_chan, |
|---|
| [73] | 808 | (strftime "%a %e %b %H:%M",localtime($t1)), |
|---|
| 809 | (strftime "%H:%M",localtime($t2)), |
|---|
| [72] | 810 | $prog_title, |
|---|
| 811 | $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key})); |
|---|
| 812 | $stats{bad_programme_duplicate_times}++; |
|---|
| 813 | return; |
|---|
| 814 | } |
|---|
| 815 | $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key} = $prog_title; |
|---|
| 816 | |
|---|
| 817 | |
|---|
| 818 | # |
|---|
| 819 | # store each programme in a tree. the tree looks like: |
|---|
| 820 | # $in->{tree}->{$chan}->{$progkey}->{progs}->[n] |
|---|
| 821 | # $in->{tree}->{$chan}->{$progkey}->{numprogs} |
|---|
| 822 | # |
|---|
| 823 | |
|---|
| 824 | my $prognum = 0; |
|---|
| 825 | $prognum = $in->{tree}->{$prog_chan}->{$prog_key}->{numprogs} |
|---|
| 826 | if (defined $in->{tree}->{$prog_chan}->{$prog_key}->{numprogs}); |
|---|
| 827 | $in->{tree}->{$prog_chan}->{$prog_key}->{progs}->[$prognum] = $prog; |
|---|
| 828 | $prognum++; |
|---|
| 829 | $in->{tree}->{$prog_chan}->{$prog_key}->{numprogs} = $prognum; |
|---|
| 830 | |
|---|
| 831 | $in->{total_progs}->{$prog_chan}++; |
|---|
| 832 | $in->{total_progs_in}->{$prog_chan}++; |
|---|
| 833 | } |
|---|
| 834 | |
|---|
| 835 | ###################################################################################################### |
|---|
| 836 | # open output file, write encoding + credits headings |
|---|
| 837 | |
|---|
| 838 | sub start_writer |
|---|
| 839 | { |
|---|
| 840 | my %writer_args = ( encoding => $in->{encoding} ); |
|---|
| 841 | my $fh = new IO::File(">$opt->{output_file}") || die "can't open $opt->{output_file}: $!"; |
|---|
| 842 | $writer_args{OUTPUT} = $fh; |
|---|
| 843 | $w = new XMLTV::Writer(%writer_args); |
|---|
| 844 | $w->start( { 'generator-info-name' => "$progname $version", 'source-info-name' => $in->{sources} } ); |
|---|
| 845 | } |
|---|
| 846 | |
|---|
| 847 | ###################################################################################################### |
|---|
| 848 | # write out our channels |
|---|
| 849 | |
|---|
| 850 | sub write_channels |
|---|
| 851 | { |
|---|
| 852 | foreach my $chan_id (sort keys %{($in->{channels})}) { |
|---|
| 853 | my $this_chan = $in->{channels}->{$chan_id}; |
|---|
| 854 | |
|---|
| 855 | my $lang_list, my $num_langs = 0; |
|---|
| 856 | foreach my $lang (keys %{($this_chan->{lang})}) { |
|---|
| 857 | $lang_list->[$num_langs]->[0] = $this_chan->{lang}->{$lang}; |
|---|
| 858 | $lang_list->[$num_langs]->[1] = $lang; |
|---|
| 859 | $num_langs++; |
|---|
| 860 | } |
|---|
| 861 | |
|---|
| 862 | $w->write_channel( { 'id' => $chan_id, 'display-name' => $lang_list } ); |
|---|
| 863 | } |
|---|
| 864 | } |
|---|
| 865 | |
|---|
| 866 | ###################################################################################################### |
|---|
| 867 | # write out our programmes |
|---|
| 868 | |
|---|
| 869 | sub write_programmes |
|---|
| 870 | { |
|---|
| 871 | foreach my $chan_id (sort keys %{($in->{channels})}) { |
|---|
| 872 | foreach my $prog_key (sort keys %{($out->{$chan_id})}) { |
|---|
| 873 | my $prog = $out->{$chan_id}->{$prog_key}; |
|---|
| 874 | my $progname = sprintf "%s%s", |
|---|
| 875 | $prog->{title}->[0]->[0], |
|---|
| 876 | ($prog->{subtitle} ? ": $prog->{subtitle}->[0]->[0]" : ""); |
|---|
| 877 | |
|---|
| 878 | printf "%-10s %s - %s: %-30s {src %s}\n", |
|---|
| 879 | $in->{channels}->{$chan_id}->{pref_desc}, |
|---|
| 880 | (strftime "%a%e%b %H:%M", localtime($prog->{start_epoch})), |
|---|
| 881 | (strftime "%H:%M", localtime($prog->{stop_epoch})), |
|---|
| 882 | $progname, |
|---|
| 883 | $prog->{datasources} |
|---|
| 884 | if ($reclogic{debug_print_programme_list}); |
|---|
| 885 | |
|---|
| 886 | delete $prog->{start_epoch} if (defined $prog->{start_epoch}); |
|---|
| 887 | delete $prog->{stop_epoch} if (defined $prog->{stop_epoch}); |
|---|
| 888 | delete $prog->{datasources} if (defined $prog->{datasources}); |
|---|
| 889 | |
|---|
| 890 | &cleanup($prog); |
|---|
| 891 | $w->write_programme($prog); |
|---|
| 892 | } |
|---|
| 893 | } |
|---|
| 894 | } |
|---|
| 895 | |
|---|
| 896 | ###################################################################################################### |
|---|
| 897 | # insert a programme into our reconciled list |
|---|
| 898 | # - if fed multiple programmes for the one slot, choose attributes from all of them |
|---|
| 899 | |
|---|
| 900 | sub add_one_programme |
|---|
| 901 | { |
|---|
| 902 | my($chan_id,$num_matching,$m) = @_; |
|---|
| 903 | &log($reclogic{debug_add_logic}, |
|---|
| 904 | (sprintf "add_one_programme: adding programme %s-%s \"%s\" with data from %d programmes", |
|---|
| 905 | (strftime "%a %e %b %H:%M",localtime(($m->[0]->{start_epoch}))), |
|---|
| 906 | (strftime "%H:%M",localtime(($m->[0]->{stop_epoch}))), |
|---|
| 907 | $m->[0]->{title}->[0]->[0], $num_matching)); |
|---|
| 908 | |
|---|
| 909 | my $newprog; |
|---|
| 910 | my $chan = $m->[0]->{channel}; |
|---|
| 911 | my $starttime = $m->[0]->{start_epoch}; |
|---|
| 912 | |
|---|
| 913 | # always take start/stop/channel from first choice |
|---|
| 914 | |
|---|
| 915 | if ($reclogic{always_rewrite_start_stop_without_timezone}) { |
|---|
| 916 | $newprog->{start} = strftime "%Y%m%d%H%M", localtime($m->[0]->{start_epoch}); |
|---|
| 917 | $newprog->{stop} = strftime "%Y%m%d%H%M", localtime($m->[0]->{stop_epoch}); |
|---|
| 918 | } else { |
|---|
| 919 | $newprog->{start} = $m->[0]->{start}; |
|---|
| 920 | $newprog->{stop} = $m->[0]->{stop}; |
|---|
| 921 | } |
|---|
| 922 | $newprog->{start_epoch} = $m->[0]->{start_epoch}; |
|---|
| 923 | $newprog->{stop_epoch} = $m->[0]->{stop_epoch}; |
|---|
| 924 | $newprog->{channel} = $chan; |
|---|
| 925 | |
|---|
| 926 | $newprog->{datasources} = ""; |
|---|
| 927 | for my $i (0..($num_matching-1)) { |
|---|
| 928 | $newprog->{datasources} .= sprintf "%s%d",($newprog->{datasources} ne "" ? "," : ""),$m->[$i]->{grabber_num}; |
|---|
| 929 | |
|---|
| 930 | # (1) merge in attributes which are simple scalars |
|---|
| 931 | foreach my $field ('date', 'length') { |
|---|
| 932 | $newprog->{$field} = $m->[$i]->{$field} |
|---|
| 933 | if ((!defined $newprog->{$field}) && (defined $m->[$i]->{$field}) && ($m->[$i]->{$field} ne "")); |
|---|
| 934 | } |
|---|
| 935 | |
|---|
| 936 | # (2) merge in attributes which are simple arrays |
|---|
| [73] | 937 | foreach my $field ('url', 'star-rating', 'premiere', 'last-chance', 'language', 'orig-language') { |
|---|
| [72] | 938 | if (defined $m->[$i]->{$field}) { |
|---|
| 939 | my %existing_hash; |
|---|
| 940 | my $num_existing = 0; |
|---|
| 941 | |
|---|
| 942 | # pick up existing entries |
|---|
| 943 | if (defined $newprog->{$field}) { |
|---|
| 944 | my $existing_entries = $newprog->{$field}; |
|---|
| 945 | foreach my $entry (@$existing_entries) { |
|---|
| 946 | $existing_hash{$entry} = 1; |
|---|
| 947 | $num_existing++; |
|---|
| 948 | } |
|---|
| 949 | } |
|---|
| 950 | |
|---|
| 951 | my $new_entries = $m->[$i]->{$field}; |
|---|
| 952 | foreach my $entry (@$new_entries) { |
|---|
| 953 | if ((!defined $existing_hash{$entry}) && ($entry ne "")) { |
|---|
| 954 | $existing_hash{$entry} = 1; |
|---|
| 955 | $newprog->{$field}->[$num_existing] = $entry; |
|---|
| 956 | $num_existing++; |
|---|
| 957 | } |
|---|
| 958 | } |
|---|
| 959 | } |
|---|
| 960 | } |
|---|
| 961 | |
|---|
| 962 | # (3) merge in attributes which are [val,lang] pairs, [val,val] or [val,val,val] |
|---|
| [73] | 963 | foreach my $field ('title', 'sub-title', 'desc', 'category', 'country', 'episode-num', 'rating') { |
|---|
| [72] | 964 | my $num_added = 0; |
|---|
| 965 | my %lang_added; |
|---|
| 966 | |
|---|
| 967 | # pick up existing entries already there |
|---|
| 968 | if (defined $newprog->{$field}) { |
|---|
| 969 | my $existing_entries = $newprog->{$field}; |
|---|
| 970 | foreach my $entry (@$existing_entries) { |
|---|
| 971 | my $val = $entry->[0]; |
|---|
| 972 | my $lang = $entry->[1]; |
|---|
| 973 | $lang = "BLANK" if (!$lang); |
|---|
| 974 | $lang_added{$lang} = $val; |
|---|
| 975 | $num_added++; |
|---|
| 976 | } |
|---|
| 977 | } |
|---|
| 978 | |
|---|
| 979 | # augment them with any new data |
|---|
| 980 | if (defined $m->[$i]->{$field}) { |
|---|
| 981 | my $new_entries = $m->[$i]->{$field}; |
|---|
| 982 | foreach my $entry (@$new_entries) { |
|---|
| 983 | my $val = $entry->[0]; |
|---|
| 984 | my $lang = $entry->[1]; |
|---|
| 985 | |
|---|
| 986 | if ($field eq "episode-num") { |
|---|
| 987 | $lang = "onscreen" if (!$lang); |
|---|
| 988 | } elsif ($field eq "rating") { |
|---|
| 989 | $lang = "BLANK" if (!$lang); |
|---|
| 990 | } else { |
|---|
| 991 | $lang = $opt->{lang} if (!$lang); |
|---|
| 992 | } |
|---|
| 993 | |
|---|
| 994 | if (!defined $lang_added{$lang}) { |
|---|
| 995 | $lang_added{$lang} = $val; |
|---|
| 996 | $newprog->{$field}->[$num_added]->[0] = $val; |
|---|
| 997 | |
|---|
| 998 | if ($lang eq "BLANK") { |
|---|
| 999 | $newprog->{$field}->[$num_added]->[1] = undef; |
|---|
| 1000 | } else { |
|---|
| 1001 | $newprog->{$field}->[$num_added]->[1] = $lang; |
|---|
| 1002 | } |
|---|
| 1003 | |
|---|
| 1004 | if ($field eq "rating") { |
|---|
| 1005 | $newprog->{$field}->[$num_added]->[2] = $entry->[2]; |
|---|
| 1006 | } |
|---|
| 1007 | |
|---|
| 1008 | $num_added++; |
|---|
| 1009 | } |
|---|
| 1010 | } |
|---|
| 1011 | } |
|---|
| 1012 | } |
|---|
| 1013 | |
|---|
| 1014 | # (4) merge in attributes which are {hash}->{hash}->[array] |
|---|
| 1015 | foreach my $field ('credits') { |
|---|
| 1016 | foreach my $field2 ('director','actor','writer','adapter','producer','presenter','commentator','guest') { |
|---|
| 1017 | my $num_added = 0; |
|---|
| 1018 | my %entries; |
|---|
| 1019 | |
|---|
| 1020 | # pick up existing entries we already have |
|---|
| 1021 | if (defined $newprog->{$field}->{$field2}) { |
|---|
| 1022 | my $existing_entries = $newprog->{$field}->{$field2}; |
|---|
| 1023 | foreach my $entry (@$existing_entries) { |
|---|
| 1024 | $entries{$entry} = 1; |
|---|
| 1025 | $num_added++; |
|---|
| 1026 | } |
|---|
| 1027 | } |
|---|
| 1028 | |
|---|
| 1029 | # augment with new data |
|---|
| 1030 | if (defined $m->[$i]->{$field}->{$field2}) { |
|---|
| 1031 | my $new_entries = $m->[$i]->{$field}->{$field2}; |
|---|
| 1032 | foreach my $entry (@$new_entries) { |
|---|
| 1033 | if (($entry ne "") && (!defined $entries{$entry})) { |
|---|
| 1034 | $newprog->{$field}->{$field2}->[$num_added] = $entry; |
|---|
| 1035 | $entries{$entry} = 1; |
|---|
| 1036 | $num_added++; |
|---|
| 1037 | } |
|---|
| 1038 | } |
|---|
| 1039 | } |
|---|
| 1040 | } |
|---|
| 1041 | } |
|---|
| 1042 | |
|---|
| 1043 | # (5) merge in attributes which are by name with no values, or values we don't care to interpret |
|---|
| [73] | 1044 | foreach my $field ('new', 'subtitles', 'previously-shown') { |
|---|
| [72] | 1045 | if ((!defined $newprog->{$field}) && (defined $m->[$i]->{$field})) { |
|---|
| 1046 | $newprog->{$field} = $m->[$i]->{$field}; |
|---|
| 1047 | } |
|---|
| 1048 | } |
|---|
| 1049 | |
|---|
| 1050 | # (6) merge in attributes which are {hash}->{hash}=val |
|---|
| [73] | 1051 | foreach my $field ('video', 'audio') { |
|---|
| [72] | 1052 | my %entries; |
|---|
| 1053 | |
|---|
| 1054 | # pick up existing entries we already have |
|---|
| 1055 | if (defined $newprog->{$field}) { |
|---|
| 1056 | my $existing_entries = $newprog->{$field}; |
|---|
| 1057 | foreach my $entry (keys %{$existing_entries}) { |
|---|
| 1058 | $entries{$entry} = $newprog->{$field}->{$entry}; |
|---|
| 1059 | } |
|---|
| 1060 | } |
|---|
| 1061 | |
|---|
| 1062 | # augment with new data |
|---|
| 1063 | if (defined $m->[$i]->{$field}) { |
|---|
| 1064 | my $new_entries = $m->[$i]->{$field}; |
|---|
| 1065 | foreach my $entry (keys %{$new_entries}) { |
|---|
| 1066 | if (($entry ne "") && (!defined $entries{$entry})) { |
|---|
| 1067 | $newprog->{$field}->{$entry} = $m->[$i]->{$field}->{$entry}; |
|---|
| 1068 | $entries{$entry} = $m->[$i]->{$field}->{$entry}; |
|---|
| 1069 | } |
|---|
| 1070 | } |
|---|
| 1071 | } |
|---|
| 1072 | } |
|---|
| 1073 | |
|---|
| 1074 | # ignored attributes: |
|---|
| 1075 | # icon |
|---|
| 1076 | } |
|---|
| 1077 | |
|---|
| 1078 | if (defined $out->{$chan}->{$starttime}) { |
|---|
| 1079 | &log(1,(sprintf "ERROR: already have a programme on channel \"%s\" scheduled for %s! bug!", |
|---|
| 1080 | $chan, (strftime "%a %e %b %H:%M",localtime($starttime)))); |
|---|
| 1081 | } else { |
|---|
| 1082 | $out->{$chan}->{$starttime} = $newprog; |
|---|
| 1083 | $in->{total_progs_out}->{($newprog->{channel})}++; |
|---|
| 1084 | } |
|---|
| 1085 | } |
|---|
| 1086 | |
|---|
| 1087 | ###################################################################################################### |
|---|
| 1088 | # remove all programming data for this channel where programming is between start/stop times |
|---|
| 1089 | |
|---|
| 1090 | sub delete_overlapping_programmes |
|---|
| 1091 | { |
|---|
| 1092 | my($chan_id,$del_start,$del_stop) = @_; |
|---|
| 1093 | |
|---|
| 1094 | &log($reclogic{debug_delete_logic}, |
|---|
| 1095 | (sprintf "delete_overlapping_programmes: called to delete within %s-%s on chan %s", |
|---|
| 1096 | (strftime "%a%e%b%H:%M", localtime($del_start)), (strftime "%a%e%b%H:%M", localtime($del_stop)), |
|---|
| 1097 | $in->{channels}->{$chan_id}->{pref_desc})); |
|---|
| 1098 | |
|---|
| 1099 | # remove programming between $del_start and $del_stop |
|---|
| 1100 | foreach my $prog_key ( keys %{($in->{tree}->{$chan_id})} ) { |
|---|
| 1101 | for my $i (0..($in->{tree}->{$chan_id}->{$prog_key}->{numprogs}-1)) { |
|---|
| 1102 | my $delete_this = 0; |
|---|
| 1103 | my $prog_start = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start_epoch}; |
|---|
| 1104 | my $prog_stop = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop_epoch}; |
|---|
| 1105 | my $prog_title = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{title}->[0]->[0]; |
|---|
| 1106 | my $prog_grabber = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{grabber_num}; |
|---|
| 1107 | |
|---|
| 1108 | if (($prog_start >= $del_start) && ($prog_stop <= $del_stop)) { |
|---|
| 1109 | # |
|---|
| 1110 | # prog entirely within window - delete it |
|---|
| 1111 | # |
|---|
| 1112 | |
|---|
| 1113 | $delete_this = 1; |
|---|
| 1114 | &log($reclogic{debug_delete_logic}, |
|---|
| 1115 | (sprintf " - deleting \"%s\" (%s-%s, grabber %d) - within window", |
|---|
| 1116 | $prog_title, (strftime "%a%e%b %H:%M", localtime($prog_start)), |
|---|
| 1117 | (strftime "%H:%M", localtime($prog_stop)), $prog_grabber)); |
|---|
| 1118 | } elsif (($prog_start < $del_start) && ($prog_stop > $del_stop)) { |
|---|
| 1119 | # |
|---|
| 1120 | # looks very bogus. starts before our delete window and ends after our delete window. |
|---|
| 1121 | # there is no "right" action here - try to apply some heuristics |
|---|
| 1122 | # |
|---|
| 1123 | |
|---|
| 1124 | if ((($prog_start + $reclogic{delete_window_smaller_than_prog_window_threshold}) >= $del_start) && |
|---|
| 1125 | (($prog_stop - $reclogic{delete_window_smaller_than_prog_window_threshold}) <= $del_stop)) { |
|---|
| 1126 | # |
|---|
| 1127 | # if programme is within -/+5 minutes (default) for both start/end of delete window |
|---|
| 1128 | # then delete it |
|---|
| 1129 | # |
|---|
| 1130 | |
|---|
| 1131 | $delete_this = 1; |
|---|
| 1132 | &log($reclogic{debug_delete_logic}, |
|---|
| 1133 | (sprintf " - deleting \"%s\" (%s-%s, grabber %d) - within window +/- delete_window_smaller_than_prog_window_threshold (%d)", |
|---|
| 1134 | $prog_title, (strftime "%a%e%b %H:%M", localtime($prog_start)), |
|---|
| 1135 | (strftime "%H:%M", localtime($prog_stop)), $prog_grabber, |
|---|
| 1136 | $reclogic{delete_window_smaller_than_prog_window_threshold})); |
|---|
| 1137 | $stats{prog_del_overwindow_close_enough}++; |
|---|
| 1138 | } else { |
|---|
| 1139 | # |
|---|
| 1140 | # rather than deleting it, try to cut back either the stop or bring forward the start |
|---|
| 1141 | # |
|---|
| 1142 | |
|---|
| 1143 | my $before_del_start = $del_start - $prog_start; |
|---|
| 1144 | my $after_del_stop = $prog_stop - $del_stop; |
|---|
| 1145 | |
|---|
| 1146 | if (($before_del_start <= $reclogic{min_prog_length_for_delete_cutoff}) && |
|---|
| 1147 | ($after_del_stop <= $reclogic{min_prog_length_for_delete_cutoff})) { |
|---|
| 1148 | # |
|---|
| 1149 | # programme would be too short if we did that. delete it |
|---|
| 1150 | # |
|---|
| 1151 | $delete_this = 1; |
|---|
| 1152 | &log($reclogic{debug_delete_logic}, |
|---|
| 1153 | (sprintf " - deleting \"%s\" (%s-%s, grabber %d) - updating start/stop would result in under min_prog_length_for_delete_cutoff (%d)", |
|---|
| 1154 | $prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)), |
|---|
| 1155 | (strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber, |
|---|
| 1156 | $reclogic{min_prog_length_for_delete_cutoff})); |
|---|
| 1157 | $stats{prog_del_overwindow_too_short}++; |
|---|
| 1158 | } else { |
|---|
| 1159 | if ($before_del_start > $after_del_stop) { |
|---|
| 1160 | # |
|---|
| 1161 | # cut off end |
|---|
| 1162 | # |
|---|
| 1163 | &log($reclogic{debug_delete_logic}, |
|---|
| 1164 | (sprintf " - updating \"%s\" (%s-%s, grabber %d) - pulled back stop time because less time after cut window than before (%d before, %d after). prog now %s-%s", |
|---|
| 1165 | $prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)), |
|---|
| 1166 | (strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber, |
|---|
| 1167 | $before_del_start, $after_del_stop, |
|---|
| 1168 | (strftime "%a%e%b%H:%M", localtime($prog_start)), |
|---|
| 1169 | (strftime "%a%e%b%H:%M", localtime($del_start)))); |
|---|
| 1170 | $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop_epoch} = $del_start; |
|---|
| 1171 | $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop} = strftime "%Y%m%d%H%M",localtime($del_start); |
|---|
| 1172 | $stats{prog_del_overwindow_cut_end}++; |
|---|
| 1173 | } else { |
|---|
| 1174 | # |
|---|
| 1175 | # cut off beginning |
|---|
| 1176 | # |
|---|
| 1177 | &log($reclogic{debug_delete_logic}, |
|---|
| 1178 | (sprintf " - updating \"%s\" (%s-%s, grabber %d) - pushed forward start time because less time before cut window than after (%d before, %d after). prog now %s-%s", |
|---|
| 1179 | $prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)), |
|---|
| 1180 | (strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber, |
|---|
| 1181 | $before_del_start, $after_del_stop, |
|---|
| 1182 | (strftime "%a%e%b%H:%M", localtime($del_stop)), |
|---|
| 1183 | (strftime "%a%e%b%H:%M", localtime($prog_stop)))); |
|---|
| 1184 | $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start_epoch} = $del_stop; |
|---|
| 1185 | $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start} = strftime "%Y%m%d%H%M",localtime($del_stop); |
|---|
| 1186 | $stats{prog_del_overwindow_culled_start}++; |
|---|
| 1187 | } |
|---|
| 1188 | } |
|---|
| 1189 | } |
|---|
| 1190 | } elsif (($prog_start < $del_stop) && ($prog_stop > $del_stop)) { |
|---|
| 1191 | # |
|---|
| 1192 | # programme starts within window but ends outside of it. |
|---|
| 1193 | # |
|---|
| 1194 | if (($del_stop - $prog_start) > $reclogic{max_prog_length_for_rejig}) { |
|---|
| 1195 | # would cut off too much programme - delete it |
|---|
| 1196 | $delete_this = 1; |
|---|
| 1197 | &log($reclogic{debug_delete_logic}, |
|---|
| 1198 | (sprintf " - deleting \"%s\" (%s-%s, grabber %d) - updating start would lose more than max_prog_length_for_rejig (%d)", |
|---|
| 1199 | $prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)), |
|---|
| 1200 | (strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber, |
|---|
| 1201 | $reclogic{max_prog_length_for_rejig})); |
|---|
| 1202 | $stats{prog_del_too_much_culled_from_start}++; |
|---|
| 1203 | } else { |
|---|
| 1204 | &log($reclogic{debug_delete_logic}, |
|---|
| 1205 | (sprintf " - updating \"%s\" (%s-%s, grabber %d) - pushed forward start time because under max_prog_length_for_rejig (%d). prog now %s-%s", |
|---|
| 1206 | $prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)), |
|---|
| 1207 | (strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber, |
|---|
| 1208 | $reclogic{max_prog_length_for_rejig}, |
|---|
| 1209 | (strftime "%a%e%b%H:%M", localtime($del_stop)), |
|---|
| 1210 | (strftime "%a%e%b%H:%M", localtime($prog_stop)))); |
|---|
| 1211 | $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start_epoch} = $del_stop; |
|---|
| 1212 | $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start} = strftime "%Y%m%d%H%M",localtime($del_stop); |
|---|
| 1213 | $stats{prog_del_start_cull_ok}++; |
|---|
| 1214 | } |
|---|
| 1215 | } elsif (($prog_start < $del_start) && ($prog_stop > $del_start)) { |
|---|
| 1216 | # |
|---|
| 1217 | # programme starts outside window but ends within it. |
|---|
| 1218 | # |
|---|
| 1219 | if (($prog_stop - $del_start) > $reclogic{max_prog_length_for_rejig}) { |
|---|
| 1220 | # would cut off too much programme - delete it |
|---|
| 1221 | $delete_this = 1; |
|---|
| 1222 | &log($reclogic{debug_delete_logic}, |
|---|
| 1223 | (sprintf " - deleting \"%s\" (%s-%s, grabber %d) - updating stop would lose more than max_prog_length_for_rejig (%d)", |
|---|
| 1224 | $prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)), |
|---|
| 1225 | (strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber, |
|---|
| 1226 | $reclogic{max_prog_length_for_rejig})); |
|---|
| 1227 | $stats{prog_del_too_much_cut_from_end}++; |
|---|
| 1228 | } else { |
|---|
| 1229 | &log($reclogic{debug_delete_logic}, |
|---|
| 1230 | (sprintf " - updating \"%s\" (%s-%s, grabber %d) - pulled back stop time due to under max_prog_length_for_rejig (%d). prog now %s-%s", |
|---|
| 1231 | $prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)), |
|---|
| 1232 | (strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber, |
|---|
| 1233 | $reclogic{max_prog_length_for_rejig}, |
|---|
| 1234 | (strftime "%a%e%b%H:%M", localtime($prog_start)), |
|---|
| 1235 | (strftime "%a%e%b%H:%M", localtime($del_start)))); |
|---|
| 1236 | $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop_epoch} = $del_start; |
|---|
| 1237 | $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop} = strftime "%Y%m%d%H%M",localtime($del_start); |
|---|
| 1238 | $stats{prog_del_end_cut_ok}++; |
|---|
| 1239 | } |
|---|
| 1240 | } |
|---|
| 1241 | |
|---|
| 1242 | if ($delete_this) { |
|---|
| 1243 | delete $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]; |
|---|
| 1244 | $in->{tree}->{$chan_id}->{$prog_key}->{numprogs}--; |
|---|
| 1245 | $in->{total_progs}->{$chan_id}--; |
|---|
| 1246 | $i--; |
|---|
| 1247 | } |
|---|
| 1248 | } |
|---|
| 1249 | |
|---|
| 1250 | # if no progs left in group, delete entire group |
|---|
| 1251 | if ($in->{tree}->{$chan_id}->{$prog_key}->{numprogs} == 0) { |
|---|
| 1252 | # delete entire group |
|---|
| 1253 | delete $in->{tree}->{$chan_id}->{$prog_key}; |
|---|
| 1254 | } |
|---|
| 1255 | } |
|---|
| 1256 | } |
|---|
| 1257 | |
|---|
| 1258 | ###################################################################################################### |
|---|
| 1259 | # when given multiple programmes matching same timeslot, compare titles of them to see if |
|---|
| 1260 | # they are the same programme. |
|---|
| 1261 | # - if the same programme, insert them. |
|---|
| 1262 | # - if different programmes, select our preferred one to insert. |
|---|
| 1263 | |
|---|
| 1264 | sub find_prog_to_add |
|---|
| 1265 | { |
|---|
| 1266 | my ($chan_id,$numprogs,$log_check_matching,$prog_list) = @_; |
|---|
| 1267 | |
|---|
| 1268 | # |
|---|
| 1269 | # find out what titles match, store results |
|---|
| 1270 | # |
|---|
| 1271 | |
|---|
| 1272 | &log($reclogic{debug_find_prog_to_add}, |
|---|
| 1273 | (sprintf "find_prog_to_add: slot on channel %s has %d programmes to choose from.", |
|---|
| 1274 | $chan_id,$numprogs)); |
|---|
| 1275 | |
|---|
| 1276 | my @match_count; |
|---|
| 1277 | my $data_match; |
|---|
| 1278 | my $highest_num_matches_slot = 0; |
|---|
| 1279 | |
|---|
| 1280 | for my $i (0..($numprogs-1)) { |
|---|
| 1281 | my $primary_title = $prog_list->[$i]{title}->[0]->[0]; |
|---|
| 1282 | my @primary_titles = alternativeTitles($primary_title); |
|---|
| 1283 | $match_count[$i] = 0; |
|---|
| 1284 | |
|---|
| 1285 | for my $j (0..($numprogs-1)) { |
|---|
| 1286 | next if ($i == $j); |
|---|
| 1287 | my $compare_title = $prog_list->[$j]->{title}->[0]->[0]; |
|---|
| 1288 | my @compare_titles = alternativeTitles($compare_title); |
|---|
| 1289 | |
|---|
| 1290 | foreach my $alt (@primary_titles) { |
|---|
| 1291 | foreach my $alt2 (@compare_titles) { |
|---|
| 1292 | &log($reclogic{debug_find_prog_to_add}, |
|---|
| 1293 | (sprintf "find_prog_to_add: comparing %d to %d: \"%s\" to \"%s\" ...", |
|---|
| 1294 | $i,$j,$alt,$alt2)); |
|---|
| 1295 | if (lc($alt) eq lc($alt2)) { |
|---|
| 1296 | $data_match->[$i]->[$j] = 1; |
|---|
| 1297 | $match_count[$i]++; |
|---|
| 1298 | &log($reclogic{debug_find_prog_to_add}, |
|---|
| 1299 | (sprintf "find_prog_to_add: -> %d++ (\"%s\") matched %d (\"%s\") with \"%s\" and \"%s\"", |
|---|
| 1300 | $i, $primary_title, $j, $compare_title, $alt, $alt2)); |
|---|
| 1301 | goto JUMPOUT_MATCH; |
|---|
| 1302 | } |
|---|
| 1303 | } |
|---|
| 1304 | } |
|---|
| 1305 | JUMPOUT_MATCH: |
|---|
| 1306 | } |
|---|
| 1307 | |
|---|
| 1308 | $highest_num_matches_slot = $i if ($match_count[$i] > $match_count[$highest_num_matches_slot]); |
|---|
| 1309 | } |
|---|
| 1310 | |
|---|
| 1311 | &log($reclogic{debug_find_prog_to_add}, |
|---|
| 1312 | (sprintf "find_prog_to_add: grabber %d wins for this slot with %d matches.", |
|---|
| 1313 | $highest_num_matches_slot,$match_count[$highest_num_matches_slot])); |
|---|
| 1314 | |
|---|
| 1315 | my $matching_progs, my $num_matching_progs = 1; |
|---|
| 1316 | if ($match_count[$highest_num_matches_slot] == 0) { |
|---|
| 1317 | my $prog = $prog_list->[0]; |
|---|
| 1318 | if (($numprogs > 1) && ($log_check_matching)) { |
|---|
| 1319 | # |
|---|
| 1320 | # no data matched - log this for further inspection |
|---|
| 1321 | # |
|---|
| 1322 | my $alternate_titles = sprintf "channel %s timeslot %s-%s, preferred grabber %d\n", |
|---|
| 1323 | $in->{channels}->{$chan_id}->{pref_desc}, |
|---|
| 1324 | (strftime "%a %e %b %H:%M",localtime(($prog->{start_epoch}))), |
|---|
| 1325 | (strftime "%H:%M",localtime(($prog->{stop_epoch}))), |
|---|
| 1326 | $prog->{grabber_num}; |
|---|
| 1327 | |
|---|
| 1328 | for my $i (0..($numprogs-1)) { |
|---|
| 1329 | my $this_prog = $prog_list->[$i]; |
|---|
| 1330 | $alternate_titles .= sprintf " #%d. \"%s\" {src %s}\n", |
|---|
| 1331 | $this_prog->{grabber_num}, $this_prog->{title}->[0]->[0], $this_prog->{grabber}; |
|---|
| 1332 | |
|---|
| 1333 | my $seen = 0; |
|---|
| 1334 | foreach my $alt_title (alternativeTitles($this_prog->{title}->[0]->[0])) { |
|---|
| 1335 | $seen++; |
|---|
| 1336 | $alternate_titles .= sprintf" also tried alternate: \"%s\"\n",$alt_title if ($seen > 1); |
|---|
| 1337 | } |
|---|
| 1338 | } |
|---|
| 1339 | |
|---|
| 1340 | &log($reclogic{debug_show_nonmatching_title_alternatives}, $alternate_titles); |
|---|
| 1341 | printf ALT_TITLE_FILE "%s\n\n",$alternate_titles; |
|---|
| 1342 | } |
|---|
| 1343 | |
|---|
| 1344 | # add entry from our preferred grabber |
|---|
| 1345 | $matching_progs->[0] = $prog; |
|---|
| 1346 | } else { |
|---|
| 1347 | # add entry from our multiple grabbers |
|---|
| 1348 | $stats{rec_start_stop_title_match}++; |
|---|
| 1349 | $matching_progs->[0] = $prog_list->[$highest_num_matches_slot]; |
|---|
| 1350 | for my $i (0..($numprogs-1)) { |
|---|
| 1351 | if ($data_match->[$highest_num_matches_slot]->[$i]) { |
|---|
| 1352 | &log($reclogic{debug_find_prog_to_add}, |
|---|
| 1353 | (sprintf "find_prog_to_add: - augmenting with data from grabber %d\n",$i)); |
|---|
| 1354 | $matching_progs->[$num_matching_progs] = $prog_list->[$i]; |
|---|
| 1355 | $num_matching_progs++; |
|---|
| 1356 | } |
|---|
| 1357 | } |
|---|
| 1358 | } |
|---|
| 1359 | &add_one_programme($chan_id,$num_matching_progs,$matching_progs); |
|---|
| 1360 | |
|---|
| 1361 | # remove all programming data for this channel which overlaps with this (inserted) programme |
|---|
| 1362 | &delete_overlapping_programmes($chan_id,$matching_progs->[0]->{start_epoch},$matching_progs->[0]->{stop_epoch}); |
|---|
| 1363 | } |
|---|
| 1364 | |
|---|
| 1365 | ###################################################################################################### |
|---|
| 1366 | |
|---|
| 1367 | sub reconcile |
|---|
| 1368 | { |
|---|
| 1369 | |
|---|
| 1370 | # |
|---|
| 1371 | # loop through channels |
|---|
| 1372 | # (chan_id) |
|---|
| 1373 | # |
|---|
| 1374 | |
|---|
| 1375 | foreach my $chan_id (sort keys %{($in->{channels})}) { |
|---|
| 1376 | my $this_chan = $in->{channels}->{$chan_id}; |
|---|
| 1377 | |
|---|
| 1378 | # |
|---|
| 1379 | # (1) look for programmes within the same timeslot |
|---|
| 1380 | # if at least 2 grabbers say a programme starts/ends at the |
|---|
| 1381 | # same time & have a similar title, use that |
|---|
| 1382 | # |
|---|
| 1383 | |
|---|
| 1384 | &log($reclogic{debug_reconcile}, |
|---|
| 1385 | (sprintf "reconcile: channel '%s': pass 1: %d programmes remaining", |
|---|
| 1386 | $in->{channels}->{$chan_id}->{pref_desc}, $in->{total_progs}->{$chan_id})); |
|---|
| 1387 | |
|---|
| 1388 | # 1a. gather up programming timeslots |
|---|
| 1389 | foreach my $prog_key ( |
|---|
| 1390 | sort { $in->{tree}->{$chan_id}->{$a}->{numprogs} <=> $in->{tree}->{$chan_id}->{$b}->{numprogs} } |
|---|
| 1391 | keys %{($in->{tree}->{$chan_id})} ) { |
|---|
| 1392 | next if (!defined $in->{tree}->{$chan_id}->{$prog_key}); |
|---|
| 1393 | my $num_progs_in_slot = $in->{tree}->{$chan_id}->{$prog_key}->{numprogs}; |
|---|
| 1394 | |
|---|
| 1395 | # 1b. at least 2 programs in the same timeslot - try to add it if titles match |
|---|
| 1396 | if ($num_progs_in_slot > 1) { |
|---|
| 1397 | my $this_prog_start = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{start_epoch}; |
|---|
| 1398 | my $this_prog_stop = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{stop_epoch}; |
|---|
| 1399 | |
|---|
| 1400 | &log($reclogic{debug_reconcile_pass1}, |
|---|
| 1401 | (sprintf "reconcile: %d programs between %s - %s", |
|---|
| 1402 | $num_progs_in_slot, (strftime "%a %e %b %H:%M",localtime($this_prog_start)), |
|---|
| 1403 | (strftime "%H:%M",localtime($this_prog_stop)))); |
|---|
| 1404 | |
|---|
| 1405 | $stats{rec_start_stop_match}++; |
|---|
| 1406 | &find_prog_to_add($chan_id,$num_progs_in_slot,1,$in->{tree}->{$chan_id}->{$prog_key}->{progs}); |
|---|
| 1407 | } |
|---|
| 1408 | } |
|---|
| 1409 | |
|---|
| 1410 | # |
|---|
| 1411 | # (2) look for programmes within similar (but not exact) timeslots |
|---|
| 1412 | # but with same name. use timeslot from the "higher preference" |
|---|
| 1413 | # grabber |
|---|
| 1414 | # |
|---|
| 1415 | |
|---|
| 1416 | my $done = 0, my $preferred_grabber = 0; |
|---|
| 1417 | while (($in->{total_progs}->{$chan_id} > 0) && (!$done)) { |
|---|
| 1418 | &log($reclogic{debug_reconcile}, |
|---|
| 1419 | (sprintf "reconcile: channel '%s': pass 2: %d programmes remaining, preferring grabber %d", |
|---|
| 1420 | $in->{channels}->{$chan_id}->{pref_desc}, $in->{total_progs}->{$chan_id}, $preferred_grabber)); |
|---|
| 1421 | |
|---|
| 1422 | # 2a. find first programme from preferred grabber |
|---|
| 1423 | my @prog_keys = sort { $in->{tree}->{$chan_id}->{$a} <=> $in->{tree}->{$chan_id}->{$b} } keys %{($in->{tree}->{$chan_id})}; |
|---|
| 1424 | foreach my $prog_key (@prog_keys) { |
|---|
| 1425 | next if (!defined $in->{tree}->{$chan_id}->{$prog_key}); |
|---|
| 1426 | next if ($in->{tree}->{$chan_id}->{$prog_key}->{numprogs} == 0); |
|---|
| 1427 | next if ($in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{grabber_num} != $preferred_grabber); |
|---|
| 1428 | |
|---|
| 1429 | # got a programme from our preferred grabber |
|---|
| 1430 | my $found_prog = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]; |
|---|
| 1431 | my $start_window = $found_prog->{start_epoch} - $reclogic{fuzzy_match_title_time_window}; |
|---|
| 1432 | my $stop_window = $found_prog->{stop_epoch} + $reclogic{fuzzy_match_title_time_window}; |
|---|
| 1433 | |
|---|
| 1434 | my $matched_progs; |
|---|
| 1435 | $matched_progs->[0] = $found_prog; |
|---|
| 1436 | my $num_matched_progs = 1; |
|---|
| 1437 | |
|---|
| 1438 | &log($reclogic{debug_reconcile_pass2}, |
|---|
| 1439 | (sprintf "reconcile: (%d to go) chose programme for %s-%s: \"%s\", looking for alternatives between %s-%s", |
|---|
| 1440 | $in->{total_progs}->{$chan_id}, |
|---|
| 1441 | (strftime "%a %e %b %H:%M",localtime($found_prog->{start_epoch})), |
|---|
| 1442 | (strftime "%H:%M",localtime($found_prog->{stop_epoch})), $found_prog->{title}->[0]->[0], |
|---|
| 1443 | (strftime "%H:%M",localtime($start_window)), |
|---|
| 1444 | (strftime "%H:%M",localtime($stop_window)))); |
|---|
| 1445 | |
|---|
| 1446 | foreach my $prog_key2 ( sort { $in->{tree}->{$chan_id}->{$a} <=> $in->{tree}->{$chan_id}->{$b} } keys %{($in->{tree}->{$chan_id})} ) { |
|---|
| 1447 | next if ($in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{grabber_num} != $preferred_grabber); |
|---|
| 1448 | next if ($prog_key2 eq $prog_key); |
|---|
| 1449 | |
|---|
| 1450 | my $numprogs = $in->{tree}->{$chan_id}->{$prog_key2}->{numprogs}; |
|---|
| 1451 | for my $i (0..($numprogs-1)) { |
|---|
| 1452 | my $check_prog = $in->{tree}->{$chan_id}->{$prog_key2}->{progs}->[$i]; |
|---|
| 1453 | |
|---|
| 1454 | # match programmes which _start_ within the timewindow (but not necessarily end!) |
|---|
| 1455 | if (($check_prog->{start_epoch} >= $start_window) && ($check_prog->{start_epoch} < $stop_window)) { |
|---|
| 1456 | $matched_progs->[$num_matched_progs] = $check_prog; |
|---|
| 1457 | $num_matched_progs++; |
|---|
| 1458 | |
|---|
| 1459 | &log($reclogic{debug_reconcile_pass2}, |
|---|
| 1460 | (sprintf "reconcile: found alternative prog: %s-%s, \"%s\"", |
|---|
| 1461 | (strftime "%a%e%b %H:%M",localtime($check_prog->{start_epoch})), |
|---|
| 1462 | (strftime "%H:%M",localtime($check_prog->{stop_epoch})), |
|---|
| 1463 | $check_prog->{title}->[0]->[0])); |
|---|
| 1464 | } |
|---|
| 1465 | } |
|---|
| 1466 | } |
|---|
| 1467 | |
|---|
| 1468 | &find_prog_to_add($chan_id,$num_matched_progs,0,$matched_progs); |
|---|
| 1469 | } |
|---|
| 1470 | |
|---|
| 1471 | &log($reclogic{debug_reconcile}, |
|---|
| 1472 | (sprintf "reconcile: still have %d programmes left, switching preferred grabbers", |
|---|
| 1473 | $in->{total_progs}->{$chan_id})) |
|---|
| 1474 | if ($in->{total_progs}->{$chan_id} > 0); |
|---|
| 1475 | |
|---|
| 1476 | $preferred_grabber++; |
|---|
| 1477 | $done = 1 if ($preferred_grabber == $in->{num_datafiles}); |
|---|
| 1478 | } |
|---|
| 1479 | |
|---|
| 1480 | &log(1,(sprintf "Reconciled \"%s\" (%s): %d input programmes reconciled into %d output programmes", |
|---|
| 1481 | $in->{channels}->{$chan_id}->{pref_desc}, $chan_id, $in->{total_progs_in}->{$chan_id}, $in->{total_progs_out}->{$chan_id})); |
|---|
| 1482 | } |
|---|
| 1483 | } |
|---|
