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