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