1#!/usr/local/bin/perl -w 2# 3# tv_check 4# 5# This script searches a channel GUIDE for shows in a show list and alerts when 6# a listed show is missing from its time slot, or shows up at other days or times. 7# 8# The show list is a custom XML format. 9# The channel guide needs to be in XMLTV format. 10# 11# for details, see Usage below 12# 13# (C)2001 - Robert Eden, free to use under the GNU License. 14# 15# Robert Eden - reden@cpan.org 16# 17# See cvs logs entries for module history 18# 19# 20 21=pod 22 23=head1 NAME 24 25tv_check - Check TV guide listings 26 27=head1 SYNOPSIS 28 29tv_check --configure|--scan [other options] 30 31=head1 DESCRIPTIONS 32 33tv_check is a Perl script that reads in a file with show information 34and checks it against a TV guide listing, reporting on upcoming episodes 35and alerting you to unexpected episodes or schedule changes. 36 37=head1 OPTIONS 38 39B<--configure> Run configuration GUI. Either this option or --scan must be 40provided. 41 42B<--season-reset> special --configure option to remove everything but the title to 43help new season setup. The idea is to keep everything a "title-only" search 44until seasons begin. Then you update the details including record device. *expirimental* 45 46B<--scan> Scan TV listings. Either this option or --configure must be provided. 47 48B<--myreplaytv=UNIT,USERNAME,PASSWORD> ** Feature removed ** This option used to 49auto-populate a config file based on myreplaytv.com. 50 51 52B<--shows=FILE> Specify the name of XML shows file (default: shows.xml). 53 54B<--guide=FILE>, B<--listings=FILE> Specify the name of XML guide file 55(default: guide.xml). 56 57B<--html> Generate output in HTML format. 58 59B<--bluenew> Highlights new episodes in blue (helpful back when there was an off-season) 60 61B<--output=FILE> Write to FILE rather than standard output 62 63B<--help> Provide a usage/help listing. 64 65=head1 SEE ALSO 66 67L<xmltv(5)>. 68 69=head1 AUTHOR 70 71Robert Eden; manpage by Kenneth J. Pronovici. 72 73=cut 74 75use strict; 76use XMLTV::Version '$Id: tv_check,v 1.77 2015/07/12 00:46:37 knowledgejunkie Exp $ '; 77 78use Tk; 79use Tk::TableMatrix; 80use XML::Twig; 81use Date::Manip; 82use Time::Local; 83use Data::Dumper; 84use Getopt::Long; 85## use HTTP::Cookies; 86## use HTTP::Request::Common qw(POST GET); 87## use LWP::UserAgent; 88use XMLTV qw(best_name); 89use XMLTV::Date; 90use XMLTV::Usage 91' tv_check v $Revision: 1.77 $ ' . <<END 92 93 part of the xmltv toolkit ( http://xmltv.sourceforge.net ) 94 95usage $0 (--configure|--scan) [--options] [--output=file] [--html] 96where --options are: 97 --shows <file> 98 xml files with show info (default shows.xml ) 99 100 --listings <file> 101 xml files with guide info (default guide.xml ) 102 103 --configure 104 run configuration GUI instead of checking listings 105 106 --html 107 scan output is in HTML format 108 109 --ddmm 110 prints DDMM date instead of MMDD in reports 111 112 --days n 113 process n days (default 7) 114 115 --notruncate 116 don't exclude episodes before today in extra-episode scans 117 don't exclude episodes after '--days' days in extra-episode scans 118 119 --season-reset 120 special --configure option to remove everything but the title to 121 help new season setup. The idea is to keep everything a "title-only" search 122 until its season begins, then add the details including recording device. *experimental* 123 124END 125 ; 126 127# 128# Define constants 129# 130select STDERR; $|=1; 131select STDOUT; $|=1; 132$ENV{TZ}='UTC' unless exists $ENV{TZ}; 133my @WEEKDAY = qw (Sun Mon Tue Wed Thu Fri Sat); 134my $WEEKDAY = "SunMonTueWedThuFriSat "; 135my $R_ON = ""; # used for HTML output 136my $G_ON = ""; # used for HTML output 137my $B_ON = ""; 138my $N_ON = ""; 139my $OFF = ""; 140# COL_TYPE 1:List 2:Entry 3:checkbox 141my @COL = qw(device day channel hhmm len title chanonly dayonly timeonly neartime ); 142my %COL; 143 $COL{$COL[$_]}=$_ foreach (0..$#COL); # populate $COL reverse hash 144 145my @COL_TYPE = qw(1 1 1 2 2 1 3 3 3 3 ); 146 147my $CONFIGURE= 0; 148my $HTML = 0; 149my $DDMM = 0; 150my $DAYS = 7; 151my $NOTRUNCATE = 0; 152my $BLUENEW = 0; 153my $SEASON_RESET =0; 154my $GUIDE_XML= 'guide.xml'; 155my $SHOW_XML = 'shows.xml'; 156my $OUTPUT_FILE = undef; 157my $TODAY = $WEEKDAY[(localtime())[6]]; 158(my $TODAY_MMDD)= UnixDate( "Now", "%Y%m%d"); 159(my $WEEK_MMDD) = UnixDate( "$DAYS days later", "%Y%m%d"); 160(my $TWOM_MMDD) = UnixDate( "2 months ago", "%Y%m%d"); 161 162# 163# Global Vars/Databases 164# 165my @SHOWS = (); # raw show data 166my $SHOW_TABLE = ""; # stores pointer to SHOW_TABLE 167my @SHOW_DATA = (); # pointer to raw by SHOW_TABLE row 168my %SHOW_DATA = (); # data for SHOW_TABLE 169my %SHOW_WIDTH = (); # column widths for SHOW_TABLE 170my %SHOW_TIME; # order of shows for report 171my %OLD_SHOW; # {old_title}=[show entryies] 172my %MIDNIGHTS = (); # {day}[] Holds midnights for each future day of the week 173 174my @MYREPLAY_LIST = (); 175my $MYREPLAY_UNIT = ""; # parameters for MYREPLAY fetch 176my $MYREPLAY_USER = ""; 177my $MYREPLAY_PASS = ""; 178my $MYREPLAY_NONG = ""; 179my $MYREPLAY_DEBUG = ""; # 0=ignore, 1=save to replay.html, 2=load from replay.html 180 181 182my $SHOW_CHANGED = 0; # updd if show needs to be saved 183my $SHOW_SORT = $COL{title}; # column to sort SHOW_TABLE 184my $SHOW_ROW = 0; # last selected row 185 186# 187# Episode data is comes from XMLTV, but data is added to the hash 188# for our own use. Since we never write out the Episode XLM, this is ok. 189# The following non XMLTV fields are used 190# {prev} = pointer to previous episode on channel 191# {next} = pointer to next episode on channel 192# {device} = device that will record this episode 193# {hhmm} = start time ( computed on demand or if $CONFIGURE) 194# {day} = start day ( computed on demand or if $CONFIGURE) 195# {mmdd} = start date ( computed on demand or if $CONFIGURE) 196# {len } = episode length ( computed on demand or if $CONFIGURE) 197 198 199my @GUIDE = (); # episode list 200my %GUIDE = (); # episode indexes 201# 202# Episode Indexes ( CAPS are constants ) 203# 204# $GUIDE{ALL}{title}=[ep...] 205# $GUIDE{chan}{binstart}=$ep 206# $GUIDE{starts}{chan}=[all-start-times]; 207# 208# The following indexes are only used by configure mode 209# array=[day,channel,hhmm,len] 210# $GUIDE{TITLE}{title} =[ [day,chan,hhmm,len]...] 211# $GUIDE{CHAN}{chan}{title}=[ [day,chan,hhmm,len]...] 212# $GUIDE{DAY}{day}{title} =[ [day,chan,hhmm,len]...] 213# $GUIDE{day}{chan}{title} =[ [day,chan,hhmm,len]...] This works since day!=chan. I hope :) 214# 215my $ENCODING; # character encoding for listings data 216 217my @CHAN = (); # channel list (sorted) 218my %CHAN = (); # channel list ( channel-id key ) 219my %CHAN_NAME = (); # channel list ( display-name key ) 220 221my %SELECT = (); # array of selector widgits 222 223my %RECORD = (); # hash of shows to record (conflict check) 224my %DEVICE = (); # list of recording devices ( hash to avoid dupes ) 225 226my $ADD_BUTTON; 227my $DELETE_BUTTON; 228my $UPDATE_BUTTON; 229my $CLEAR_BUTTON; 230my $TOP; 231my @LANG = (); # preferred languages 232 233my @COL_VALUE=(); 234$COL_VALUE[$_] = "" foreach (0..$#COL); 235 236# 237# Step 1, Parse Parameters ------------------------------------------------------- 238# 239# First lets check to see if someone asked for help. 240# this is easier to do here than later. 241{ 242 my $scan=0; 243 my $help=0; 244 my $myreplayargs; 245 GetOptions('configure' => \$CONFIGURE, 246 'scan' => \$scan, 247 'myreplaytv=s' => \@MYREPLAY_LIST, 248 'html' => \$HTML, 249 'shows=s' => \$SHOW_XML, 250 'output=s' => \$OUTPUT_FILE, 251 'guide|listings=s' => \$GUIDE_XML, 252 'ddmm' => \$DDMM, 253 'days=i' => \$DAYS, 254 'notruncate' => \$NOTRUNCATE, 255 'bluenew' => \$BLUENEW, 256 'season-reset' => \$SEASON_RESET, 257 'help' => \$help) 258 or usage(); 259 usage(1) if $help; 260 261 die "Please select either --scan, --configure, or --help\n" if ($CONFIGURE+$scan != 1); 262 if (defined $OUTPUT_FILE) 263 { 264 print STDERR "Sending output to $OUTPUT_FILE\n"; 265 open(STDOUT,">$OUTPUT_FILE") or die "Can't open for output $OUTPUT_FILE\n"; 266 } 267 268 foreach (@MYREPLAY_LIST) 269 { 270 ($MYREPLAY_UNIT,$MYREPLAY_USER,$MYREPLAY_PASS,$MYREPLAY_NONG,$MYREPLAY_DEBUG)=split(/,/,$_); 271 die "MYREPLAY UNIT not specified\n" unless length($MYREPLAY_UNIT)>0; 272 die "MYREPLAY USER not specified\n" unless length($MYREPLAY_USER)>0; 273 die "MYREPLAY PASS not specified\n" unless length($MYREPLAY_PASS)>0; 274 } 275 276} # get params 277 278load_guide($GUIDE_XML); 279load_shows($SHOW_XML); 280 281### ---------------------------------------- 282### do we need to get shows from MYREPLAYTV? 283### 284### disabled, since myreplaytv.com doesn't exist any more! 285### 286### 287##if (@MYREPLAY_LIST) { 288## print STDERR "**WARNING** Replay has discontinued the MyReplayTV service. Ignoring -myreplay\n"; 289##} 290### foreach (@MYREPLAY_LIST) { 291##if (0) { 292## $MYREPLAY_UNIT=$MYREPLAY_USER=$MYREPLAY_PASS=$MYREPLAY_NONG=$MYREPLAY_DEBUG=undef; 293## ($MYREPLAY_UNIT,$MYREPLAY_USER,$MYREPLAY_PASS,$MYREPLAY_NONG,$MYREPLAY_DEBUG)=split(/,/,$_); 294## $MYREPLAY_NONG=0 unless defined $MYREPLAY_NONG; 295## $MYREPLAY_DEBUG=0 unless defined $MYREPLAY_DEBUG; 296## 297## my $html=""; 298## my $device="MyReplayTV$MYREPLAY_UNIT"; 299## 300### 301### remove existing MYREPLAY_UNIT entries (they will be loaded fresh later) 302### 303## for my $show (@SHOWS) 304## { 305## if (defined $MYREPLAY_UNIT and $show->{device} eq "MyReplayTV$MYREPLAY_UNIT") 306## { 307## push @{$OLD_SHOW{$show->{title}}},$show; # quick hack to save previous options 308## $show->{title}=''; 309## } 310## } 311## 312## print STDERR "Fetching shows from $device\n"; 313## 314##if ($MYREPLAY_DEBUG != 2) 315##{ 316### 317### create user agent 318### 319## my $ua = LWP::UserAgent->new; 320## $ua->cookie_jar( HTTP::Cookies->new); 321## $ua->agent("tv_check/1.0" . $ua->agent); 322## 323### 324### login to MyReplayTV 325### 326### print STDERR "MyReplayTV logging in\n"; 327## my $res = $ua->request(POST 'http://my.replaytv.com/servlet/Login', 328## [ username => $MYREPLAY_USER, 329## password => $MYREPLAY_PASS, 330## savePassword => '', 331## ]); 332## 333## unless ( $res->is_success && $res->title eq 'ReplayGuideRecordings' ) 334## { 335## open(FILE,">error.html") && print(FILE $res -> as_string); 336## die "MyReplayTV login error!. Debug info in 'error.html'\n"; 337## } 338## 339### 340### get MyReplayTV show info 341### 342## sleep 5; 343### print STDERR "MyReplayTV getting Replay Channels\n"; 344## $res = $ua->request( GET('http://my.replaytv.com/servlet/ReplayGuideRequests', 345## HTTP::Headers->new( 346## Referer => 'http://my.replaytv.com/servlet/ReplayGuideRecordings' 347## ))); 348## 349## unless ($res->is_success && $res->title eq 'Replay Guide Shows') 350## { 351## open(FILE,">error.html") && print(FILE $res -> as_string); 352## die "MyReplayTV show fetch error. Debug info in 'error.html'\n"; 353## } 354## 355### 356### debug save (to make things faster and not overload Replay's servers during debug) 357### 358## if ($MYREPLAY_DEBUG == 1) 359## { 360## open(FILE,">replay_$MYREPLAY_UNIT.html"); 361## print FILE $res -> as_string; 362## close FILE; 363## } 364## $html=$res->as_string; 365##} 366##else 367##{ 368## open(FILE,"<replay_$MYREPLAY_UNIT.html") || die "Can't open relpay_$MYREPLAY_UNIT.html"; 369## $html = join("\n",<FILE>); 370## close FILE; 371##} # quick debug hack 372## 373### 374### Got the listings... find our shows 375### 376##foreach (split(/\n/,$html)) 377##{ 378## s/\s+/ /g; 379## next unless length($_)>5; 380## next if /was scheduled to record/; 381## next if /Nothing else is scheduled to record/; 382## 383## if (my @a= / This show.+current episode.s. of (.+) occurring every \((.+)\) on Channel (\d+)\((.+)\).+ (\d+):(\d+)(\w). - (\d+):(\d+)(\w).+\. (.+) at /) 384## { 385## 386## $a[4] = "0" if ($a[4]==12 and $a[6] eq 'A'); # midnight -> 00; 387## $a[7] = "0" if ($a[7]==12 and $a[9] eq 'A'); # midnight -> 00; 388## 389## my $title = $a[0]; $title =~ s/\x92/'/g; # fix illegal character in Replay Feed ' 390## my $days = $a[1]; 391## my $chan = "$a[2] $a[3]"; 392## my $hhmm = sprintf("%02d%02d",(($a[6] eq 'P') && ($a[4] != 12) ? $a[4]+12 : $a[4]),$a[5]); 393## my $stop = sprintf("%02d%02d",(($a[9] eq 'P') && ($a[7] != 12) ? $a[7]+12 : $a[7]),$a[8]); 394## my $guar = ( $a[10] =~ /^Not/ ? 0 : 1 ); 395## 396## next unless $guar || $MYREPLAY_NONG; 397## 398## my $len = hhmm_min($stop) - hhmm_min($hhmm); 399## $len += 24*60 if $len < 0; 400## 401## 402##print STDERR "\nMyReplay looking for ",join("|",$title,$chan,$hhmm,$len,$days),"\n" if ($MYREPLAY_DEBUG == 2); 403## 404### 405### convert channel ID to new format if ncessary 406### 407## if ( ! exists $CHAN{$chan} && exists $CHAN_NAME{$chan} ) 408## { 409## $chan=$CHAN_NAME{$chan}; 410## } 411## 412### 413### Check Channel 414### 415## unless ( exists $CHAN{$chan}) 416## { 417## print STDERR "MyReplayTV Channel '$chan' not in guide\n"; 418## $CHAN{$chan}{'display-name'}[0][0]=$chan; 419## } 420## 421### 422### if Replay expects our show on a specific day, we can just add it 423### 424## if (length($days) == 3) 425## { 426## add_myreplaytv_show($title,$chan,$hhmm,$len,$days); 427## next; 428## } 429## 430### 431### Now this gets tricky. MyReplayTV tells us the time of a show, but not 432### the day. We can't assume the show is available for all days listed 433### because that would cause too many false alarms in tv_check 434### 435### We can't use any day the show is on because of syndication. A 2am 436### Daily showing of a weekly show would also cause false alarms. 437### 438### So, the solution is to find the episode 2 slots back and 2 slots forward. 439### If the MyReplay hhmm start time is between these values, record the day. 440### 441### This will cause problems around midnight. I don't have a good solution there 442### 443### Personally, I now set all shows to record on a single day on the Replay, and 444### if you specify a single day, this check isn't done... there's you're work-around! 445### 446## my $found=""; 447## for my $ep (@{$GUIDE{all}{lc($title)}}) 448## { 449## gen_episode_dates($ep) unless $ep->{day}; 450## my $day = $ep->{day}; 451## 452## next if $chan ne $ep->{channel}; 453## next if $days !~ /$day/; # episode on of myreplay's days? 454## next if $found =~ /:$day/; # already got this day? 455## 456### 457### get start time 2 slots back 458### 459## my ($ep1,$ep2,$wstart,$wstop); 460## $ep1= $ep; 461## $ep1 =$ep1->{prev} if $ep1->{prev}; 462## gen_episode_dates($ep1) unless $ep1->{day}; 463## 464## $ep2= $ep1; 465## $ep2 =$ep2->{prev} if $ep2->{prev}; 466## gen_episode_dates($ep2) unless $ep2->{day}; 467## 468## $wstart=$ep ->{hhmm}; 469## $wstart=$ep1->{hhmm} if $ep1->{day} eq $day; 470## $wstart=$ep2->{hhmm} if $ep2->{day} eq $day; 471## 472## 473### 474### Now start time 2 slots forward 475### 476## $ep1= $ep; 477## $ep1 =$ep1->{next} if $ep1->{next}; 478## gen_episode_dates($ep1) unless $ep1->{day}; 479## 480## $ep2= $ep1; 481## $ep2 =$ep2->{next} if $ep2->{next}; 482## gen_episode_dates($ep2) unless $ep2->{day}; 483## 484## $wstop=$ep ->{hhmm}; 485## $wstop=$ep1->{hhmm} if $ep1->{day} eq $day; 486## $wstop=$ep2->{hhmm} if $ep2->{day} eq $day; 487## 488## 489##printf STDERR "day search: %s: %s<%s<%s\n",$title,$wstart,$hhmm,$wstop if $MYREPLAY_DEBUG > 1; 490## 491### 492### record the day if MyReplay start time is between these times 493### 494## next if $hhmm lt $wstart; 495## next if $hhmm gt $wstop; 496## 497### 498### guess it's a hit... mark it 499### 500## add_myreplaytv_show($title,$chan,$hhmm,$len,$day); 501### 502### not sure why we're marking this here. It prevents display when a show moves! 503### 504### $ep->{device} = $device; 505## $found .= ":$day"; 506## 507## } # myreplay day search 508## 509### 510### add it as an unknown if not found 511### 512## unless ($found) 513## { 514## $days="*" if $days eq "Sun, Mon, Tue, Wed, Thu, Fri, Sat"; 515## 516## unless (add_myreplaytv_show($title,$chan,$hhmm,$len,"")) 517## { 518## print STDERR " Can't guess day, using title scan for ",join("|",$title,$chan,$hhmm,$days),"\n"; 519## } 520## } 521## } # show entry match 522##} # listing loop 523## 524##load_show_table(); # build indexes 525##} # MYREPLAY 526 527 528# 529# is it time to CONFIGURE? -------------------------------------------------------- 530# 531if ($CONFIGURE) 532{ 533 if ($SEASON_RESET) { # season-reset is an experiemtnal way to reset for a new season 534 for my $show (@SHOWS) 535 { 536 for my $key (keys %$show) { 537 next if $key eq 'title'; 538 next if $key eq 'channel'; 539 delete $show->{$key}; 540 } #key loop 541 } # show loop 542 load_show_table(); # build indexes 543 } #SEASON-RESET 544 545# 546# create main window! 547# 548 549$TOP = MainWindow->new; 550$TOP->focusmodel("active"); 551 552# 553# configure menu bar 554# 555{ 556my $menubar = $TOP->Menu(-type => 'menubar'); 557 558$TOP->OnDestroy( sub{ 559 return if changed_check(1); 560 $TOP -> destroy(); 561 } 562 ); 563 564$TOP->configure(-menu => $menubar ); 565 566my $f = $menubar->cascade(-label => '~File', -tearoff => 0); 567$f->command(-label => 'New', 568 -underline => 0, 569 -command => sub { 570 $SHOW_XML=''; 571 @SHOWS=(); 572 load_show_table(); 573 }); 574 575$f->command(-label => 'Open...', 576 -underline => 0, 577 -command => sub { 578 return if changed_check(); 579 my $file = $TOP->getOpenFile(-filetypes => [["XML Files",".xml"]], 580 -title => 'Open Show File'); 581 load_shows($file) if defined $file; 582 }); 583 584 585$f->command(-label => 'Save', 586 -underline => 0, 587 -command => \&Save_shows ); 588 589$f->command(-label => 'Save As...', 590 -underline => 5, 591 -command => sub { 592 my $file = $TOP->getSaveFile( -filetypes => [["XML Files",".xml"]], 593 -title => 'Save show file'); 594 if (defined $file) 595 { 596 $SHOW_XML=$file; 597 Save_shows(); 598 } 599 }); 600 601$f->command(-label => 'Listings...', 602 -underline => 0, 603 -command => sub { 604 my $file = $TOP->getOpenFile(-filetypes => [["XML Files",".xml"]], 605 -title => 'Open Listing File' ); 606 load_guide($file) if defined ($file); 607 }); 608 609 610$f->command(-label => 'Exit', 611 -underline => 1, 612 -command => sub { 613 return if changed_check(); 614 $TOP -> destroy(); 615 }); 616 617my $h = $menubar->cascade(-label => '~Help', -tearoff => 0); 618$h->command(-label => 'Help', 619 -underline => 0, 620 -command => \&help_popup ); 621 622$h->command(-label => 'About', 623 -underline => 0, 624 -command => \&help_about ); 625 626} # menu bar 627 628# 629# create show table 630# 631$SHOW_TABLE = $TOP->Scrolled('TableMatrix', 632 -cols => ($#COL+1), 633 -rows => ($#SHOWS > 8 ? $#SHOWS+2 : 10 ), 634 -height => 10, 635 -titlerows => 1, 636 -variable => \%SHOW_DATA, 637 -roworigin => 0, -colorigin => 0, 638 -colstretchmode => 'all', 639 -selecttype => 'row', 640 -sparsearray => 1, 641 -state => 'disabled', 642 -anchor => 'w', 643 -exportselection => 0, 644 ); 645$SHOW_TABLE->colWidth( %SHOW_WIDTH ); 646$SHOW_TABLE->pack(-expand => 1, -fill => 'both'); 647$SHOW_TABLE->bind('<1>', sub { 648 my $w = shift; 649 my $Ev = $w->XEvent; 650 my $row = $w->index('@'.$Ev->x.",".$Ev->y,"row"); 651 my $col = $w->index('@'.$Ev->x.",".$Ev->y,"col"); 652 653 $w->selectionClear('all'); 654 $SHOW_ROW=0; 655 $UPDATE_BUTTON -> configure ( -state => "disabled" ); 656 $DELETE_BUTTON -> configure ( -state => "disabled" ); 657 658 if ($row) 659 { 660 return unless $SHOW_DATA{"$row,$COL{title}"}; # title must exist 661 $SHOW_ROW=$row; 662 $UPDATE_BUTTON -> configure ( -state => "normal" ); 663 $DELETE_BUTTON -> configure ( -state => "normal" ); 664 $w->selectionSet("$row,0","$row,".($#COL+1)); 665 for $col (0..$#COL) # load selection pane 666 { 667 $COL_VALUE[$col] = $SHOW_DATA{"$row,$col"}; 668 } 669 } 670 else 671 { 672 $SHOW_SORT = ($SHOW_SORT == $col ? -$col : $col); 673 load_show_table(); 674 } 675}); # show table click bind 676 677my $selframe = $TOP->Frame->pack(-side => 'bottom'); 678# 679# Control Buttons 680# 681{ 682 my $frame=$selframe->Frame()->pack( -side => 'left' ); 683 $CLEAR_BUTTON = 684 $frame->Button( -text => "Clear Selection", 685 -command => sub{ 686 $SHOW_ROW=0; 687 $SHOW_TABLE->selectionClear('all'); 688 $UPDATE_BUTTON -> configure ( -state => "disabled" ); 689 $DELETE_BUTTON -> configure ( -state => "disabled" ); 690 $COL_VALUE[$_]='' foreach (0..$#COL); 691 load_selection_items(); 692 }) -> pack(-fill => 'x'); 693 694 $ADD_BUTTON = 695 $frame->Button( -text => "Add Selection", 696 -command => sub{ 697 $SHOW_ROW=0; 698 $SHOW_TABLE->selectionClear('all'); 699 $UPDATE_BUTTON -> configure ( -state => "disabled" ); 700 $DELETE_BUTTON -> configure ( -state => "disabled" ); 701 return unless $COL_VALUE[$COL{title}]; 702 my $row = $#SHOWS+1; 703 validate_col_value(); 704 $SHOWS[$row]{$COL[$_]}=$COL_VALUE[$_] foreach (0..$#COL); 705 load_show_table(); 706 $SHOW_CHANGED=1; 707 $COL_VALUE[$COL{title}]=''; 708 }) -> pack(-fill => 'x'); 709 $UPDATE_BUTTON = 710 $frame->Button( -text => "Update Show", 711 -state => "disabled", 712 -command => sub{ 713 return unless $SHOW_ROW; 714 return unless $COL_VALUE[$COL{title}]; 715 validate_col_value(); 716 $SHOW_DATA[$SHOW_ROW]->{$COL[$_]}=$COL_VALUE[$_] foreach (0..$#COL); 717 $SHOW_CHANGED=1; 718 load_show_table(); 719 }) -> pack(-fill => 'x'); 720 721 $DELETE_BUTTON = 722 $frame->Button( -text => "Delete Show", 723 -state => "disabled", 724 -command => sub{ 725 return unless $SHOW_ROW; 726 $SHOW_DATA[$SHOW_ROW]{title}=''; 727 load_show_table(); 728 $SHOW_CHANGED=1; 729 }) -> pack(-fill => 'x'); 730 731} # control buttons 732 733# 734# Selector Widgets 735# Type 1 ( listbox ) 736# 737for my $col (0..$#COL) 738{ 739 next unless $COL_TYPE[$col] == 1; 740 my $frame =$selframe->Frame()->pack( -side => 'left' ); 741 my $label =$frame->Label(-text => $COL[$col])->pack(); 742 my $entry =$frame->Entry(-textvariable => \$COL_VALUE[$col])->pack(); 743 my $list =$frame->Scrolled('Listbox', 744 -setgrid => 1, 745 -height =>12, 746 -selectmode => 'row', 747 -exportselection => 0, 748 -scrollbars => 'w'); 749 $list -> {SubWidget} -> {scrolled} -> privateData('Entry') -> {Entry} = $entry; 750 $list -> {SubWidget} -> {scrolled} -> privateData('Entry') -> {Col} = $col; 751 $list -> pack(qw/-side left -expand yes -fill both/); 752 $list -> bind('<ButtonRelease 1>' => sub { 753 my $w = shift; 754 my $entry = $w->privateData('Entry') -> {Entry}; 755 my $col = $w->privateData('Entry') -> {Col}; 756 my $val = $w->get('active'); 757#print STDERR "Storing ($val) into $col\n"; 758 $COL_VALUE[$col]=$val; 759 load_selection_items(); 760 }); 761 $SELECT{$COL[$col]}= { frame => $frame, 762 label => $label, 763 entry => $entry, 764 list => $list }; 765} # type 1 selectors 766 767# 768# Selector Widgets 769# Type 2 ( entry ) 770# Note: Type 2 and Type 3 share a frame 771# 772my $selframe2 =$selframe->Frame()->pack( -side => 'left' ); 773for my $col (0..$#COL) 774{ 775 next unless $COL_TYPE[$col] == 2; 776 777 my $frame = $selframe2; 778 my $label =$frame->Label(-text => $COL[$col])->pack(); 779 my $entry =$frame->Entry(-textvariable => \$COL_VALUE[$col])->pack(); 780 $frame->Label(-text => " ")->pack(); 781 782 $SELECT{$COL[$col]}= { frame => $frame, 783 label => $label, 784 entry => $entry, 785 }; 786} # type 2 selectors 787 788# 789# Selector Widgets 790# Type 3 ( checkbox ) 791# Note: Type 2 and Type 3 share a frame 792# 793for my $col (0..$#COL) 794{ 795 next unless $COL_TYPE[$col] == 3; 796 797 my $frame = $selframe2; 798 my $check = $frame->Checkbutton( -text => $COL[$col], 799 -variable => \$COL_VALUE[$col], 800 ) -> pack(); 801 802 $SELECT{$COL[$col]}= { frame => $frame, 803 check => $check, 804 }; 805} # type 3 selectors 806 807load_selection_items(); 808 809# 810# let the games begin! 811# 812print STDERR "GUI running\n"; 813Tk::MainLoop; 814} # CONFIGURE 815 816# 817# Step 3, do an actual tv check -------------------------------------------------------- 818# 819else 820{ 821 822# 823# Print HTML Banner 824# 825if ($HTML) 826{ 827 $R_ON = "<span style='color:red'>"; 828 $G_ON = "<span style='color:gray'>"; 829 $B_ON = "<span style='color:blue'>"; 830 $N_ON = "<span style='color:green'>"; 831 $OFF = "</span>"; 832 my $now = localtime(); 833 834 # Make the output in the same encoding as the programme data. We 835 # assume this is a superset of ASCII. 836 # 837 print <<END 838 <html> 839 <head> 840 <meta http-equiv="Content-Type" content="text/html; charset=$ENCODING"> 841 <title>TV-CHECK report</title> 842 </head> 843 <body> 844 <h1 align=center> TV-CHECK </h1> 845 <h3> $now | $SHOW_XML | $GUIDE_XML </h3> 846 <pre> 847END 848;} 849 850 851# 852# Build list of midnight bintimes 853# 854{ 855 my $noon=timelocal(0,0,12,substr($TODAY_MMDD,6,2),substr($TODAY_MMDD,4,2)-1,substr($TODAY_MMDD,0,4)-1900); 856 foreach (0..($DAYS-1)) 857 { 858 my $day=$WEEKDAY[(localtime($noon))[6]]; 859 my $midnight=$noon - 12*3600; # by using this midnight, DST day show times will be off from 0-2am. oh well. 860 unshift @{$MIDNIGHTS{$day}},$midnight; 861 862 printf "WARNING: DST change detected on $day\n" if ((localtime($midnight))[2] != 0); 863 $noon=timelocal(0,0,12,(localtime($noon+24*3600))[3,4,5]); 864 865 } 866} 867 868# 869# Build show_time index 870# 871print STDERR "Computing show time index\n"; 872my $unique=1; 873for my $show (@SHOW_DATA) 874{ 875 $show->{channel}="" unless exists $show->{channel}; 876 $show->{day}="" unless exists $show->{day}; 877 878 if (exists $MIDNIGHTS{$show->{day}}) # deal with shows on a specific day 879 { 880 my $time_of_day=substr($show->{hhmm},0,2)*3600+substr($show->{hhmm},2,2)*60; 881 882 for my $midnight (@{$MIDNIGHTS{$show->{day}}}) 883 { 884 $show->{start} = $midnight + $time_of_day; 885 my @date = localtime($show->{start}); 886 $date[4]++; $date[5]+=1900; 887 $show->{mmdd} = sprintf("%04d%02d%02d",@date[5,4,3]); 888 889 if (exists $SHOW_TIME{$show->{start}} 890 and exists $SHOW_TIME{$show->{start}}{$show->{channel}.$show->{title}} ) { 891 $show->{dupe}=1; # start day,time,title matches.. mark dupe 892 $SHOW_TIME{$show->{start}}{$show->{channel}.$show->{title}.($unique++)} = {%$show}; 893 } 894 else { $SHOW_TIME{$show->{start}}{$show->{channel}.$show->{title}} = {%$show}; } 895 } 896 } 897 else 898 { 899 $show->{mmdd} = ""; 900 $show->{day} = ""; 901 $SHOW_TIME{"Z".($unique++)}{$show->{channel}} = $show; 902 } 903 904} #build SHOW_TIME index 905 906# 907# let the games begin... process shows! 908# 909print STDERR "Processing shows\n\n"; 910for my $start (sort keys %SHOW_TIME) 911{ 912 for my $key (sort keys %{$SHOW_TIME{$start}}) 913 { 914 my $show = $SHOW_TIME{$start}{$key}; 915 my $chan = $show->{channel}; 916 my $ep_desc = ""; 917 next unless $show->{title}; 918 919 $CHAN{$chan}{'display-name'}[0][0]=$chan unless exists $CHAN{$chan}; 920 921# 922# See what episode is on at that time 923# 924 if ( $show -> {mmdd} ) # this phase only gets shows with a mmdd 925 { 926 my $ep = find_episode($show); 927 928# 929# look for close episode matches 930# 931 $ep=$ep->{prev} if ($ep && $ep->{prev} 932 && !($ep->{prev}->{displayed}) # don't flag shows already hit 933 && lc(get_text($ep->{title} )) ne lc($show->{title}) 934 && lc(get_text($ep->{prev}{title})) eq lc($show->{title})); 935 936 $ep=$ep->{next} if ($ep && $ep->{next} 937 && !($ep->{next}->{displayed}) # don't flag shows already hit 938 && lc(get_text($ep->{title} )) ne lc($show->{title}) 939 && lc(get_text($ep->{next}{title})) eq lc($show->{title})); 940# 941# display results 942# 943 if (!defined $ep) 944 { 945 printf "${R_ON}%-60s **** NO GUIDE DATA ****${OFF}\n",sh_summary($show); 946 } 947 elsif ( lc(get_text($ep->{title})) ne lc($show->{title}) ) 948 { 949 printf "${R_ON}%-50s **** wrong show in slot ****\n",sh_summary($show); 950 print " "x10,ep_summary($ep),"${OFF}\n"; 951 } 952 else # ( guess we got what we wanted ) 953 { 954 if (length($show->{device}) 955 && ! $ep->{displayed} )# don't flag shows already hit) 956 { 957 push @{$RECORD{$show->{device}}},$ep; 958 $ep->{device}=$show->{device}; 959 } 960 961 $ep->{displayed}=$show; 962 print $B_ON if $BLUENEW && !$ep->{"previously-shown"}; 963 print ep_summary($ep),opt_summary($show),"\n"; 964 print $OFF if $BLUENEW && !$ep->{"previously-shown"}; 965 if ( $show->{hhmm} ne $ep->{hhmm} ) 966 { 967 print "${R_ON} ***** Start Time Alert ***** Expected $show->{hhmm} got $ep->{hhmm}${OFF}\n"; 968 } 969 if ( $show->{len} && $ep->{len} && $show->{len} ne $ep->{len} ) 970 { 971 print "${R_ON} ***** LENGTH ALERT ***** Expected $show->{len} got $ep->{len}${OFF}\n"; 972 } 973 $ep_desc = get_text($ep ->{"sub-title"}); # use this later 974 } 975 } 976 else 977 { 978 print sh_summary($show)."\n"; 979 } 980 981# 982# See if the show is on at other times 983# 984 for my $ep ( @{$GUIDE{all}{lc($show->{title})}}) 985 { 986 gen_episode_dates($ep) unless $ep->{day}; 987 next if !$NOTRUNCATE && $ep->{mmdd} lt $TODAY_MMDD; # ignore shows before today 988 next if !$NOTRUNCATE && $ep->{mmdd} ge $WEEK_MMDD ; # ignore shows more than a week away 989 next if $ep->{displayed} eq $show; 990 next if length($ep->{device}) >0 && ($ep->{device} eq $show->{device}); #skip if already recording 991 992 gen_episode_dates($ep) unless $ep->{day}; 993 994 995# check channel 996# 997 next if ( $show->{chanonly} && $chan ne $ep->{channel} ); 998 999 1000# 1001# check day 1002# 1003 next if ( $show->{dayonly} && $show->{day} ne $ep->{day}); 1004 1005# 1006# check time 1007# 1008 next if ( $show->{timeonly} && $show->{hhmm} ne $ep->{hhmm}); 1009 if ( $show -> {neartime}) 1010 { 1011 my $delta = abs( substr($show->{hhmm},0,2) - 1012 substr( $ep->{hhmm},0,2) ); 1013 next unless $delta < 2; 1014 } 1015 1016# 1017# ok, guess we're interested in it, print it 1018# 1019# highlight new bonus episodes in green, otherwise gray 1020# 1021 my $tmp=get_text($ep ->{"sub-title"}) || ""; 1022 if ( $ep_desc && $tmp && 1023 $ep_desc ne $tmp && 1024 !$ep->{"previously-shown"} ) 1025 { 1026 print " "x5,$N_ON,ep_summary($ep,1),"$OFF\n"; 1027 } 1028 else 1029 { 1030 print " "x5,$G_ON,ep_summary($ep,1),"$OFF\n"; 1031 } 1032 1033# 1034# special hack to for ReplayTV's "smart" record 1035# 1036 if ($show->{device} =~ /^REPLAY/i ) 1037# 1038# let's try leaving out ReplayTV's "smart" record hack 1039# for MYREPLAY shows. It should be caught by the MYREPLAY 1040# code as an episode on that day 1041# 1042# or $show->{device} =~ /^MYREPLAY/i ) 1043 { 1044 next unless length($show->{day} ); # don't record title-only scans 1045 next unless length($show->{hhmm}); # this should never happen 1046 next unless $ep->{channel} eq $show->{channel}; # Replay is channel specific 1047 1048# 1049# check show two show slots forward + back (one slot caught by start-time search) 1050# 1051 my $hit=undef; 1052 my $epp=undef; 1053 1054 $epp = $ep->{prev} if defined $ep; 1055 $epp = $ep->{prev} if defined $epp; 1056 $hit = $epp if lc(get_text($epp->{title})) eq lc($show->{title}); 1057 $hit = undef if $epp->{device} eq $show->{device}; 1058 1059 $epp = $ep->{next} if defined $ep; 1060 $epp = $ep->{next} if defined $epp; 1061 $hit = $epp if !$hit && lc(get_text($epp->{title})) eq lc($show->{title}); 1062 $hit = undef if $epp->{device} eq $show->{device}; 1063 1064 if ($hit) 1065 { 1066 $epp->{device}=$show->{device}; 1067 push @{$RECORD{$show->{device}}},$epp; 1068 } 1069 } # replay conflict check 1070 } # extra episode scan 1071 1072# 1073# if the title conains a "*" character, do a full search 1074# 1075 if ( $show->{title} =~ /\*/ ) 1076 { 1077 my $key=$show->{title}; 1078 $key =~ s/\*/.\*/g; # replace * wildcard with .* 1079 1080 for my $ep_title ( keys %{$GUIDE{all}} ) 1081 { 1082 next unless $ep_title =~ /^$key$/i; 1083 for my $ep ( @{$GUIDE{all}{$ep_title}} ) 1084 { 1085 next if ( $show->{chanonly} && $chan ne $ep->{channel} ); 1086 next if ( $show->{dayonly} && $show->{day} ne $ep->{day}); 1087 next if ( $show->{timeonly} && $show->{hhmm} ne $ep->{hhmm}); 1088 if ( $show -> {neartime}) 1089 { 1090 my $delta = abs( substr($show->{hhmm},0,2) - 1091 substr( $ep->{hhmm},0,2) ); 1092 next unless $delta < 2; 1093 } 1094 1095 print " "x10,ep_summary($ep)."\n"; 1096 } 1097 } 1098 } # wildcard scan 1099 1100 print "\n"; 1101 } # show chan loop 1102} # show time loop 1103 1104# 1105# Now check for recording conflicts 1106# 1107for my $dev_name (sort keys %RECORD) 1108{ 1109 my @shows = @{$RECORD{$dev_name}}; 1110 for my $ep1 ( 0..($#shows-1) ) 1111 { 1112 my $start = $shows[$ep1] -> {start}; 1113 my $stop = $shows[$ep1] -> {stop}; 1114 my $header = 0; 1115 1116 for my $ep2 ( ($ep1+1)..$#shows ) 1117 { 1118 next if ( $shows[$ep2]->{stop} le $start); 1119 next if ( $shows[$ep2]->{start} ge $stop); 1120 unless ($header) 1121 { 1122 delete $shows[$ep1]{device}; # don't need device print anymore 1123 print "${R_ON}**** recording conflict for device $dev_name\n"; 1124 print " "x5,ep_summary($shows[$ep1]),"\n"; 1125 $header=1; 1126 } 1127 delete $shows[$ep2]{device}; # don't need device print anymore 1128 print " "x5,ep_summary($shows[$ep2]),"\n"; 1129 } # show2 loop 1130 print "$OFF\n" if $header; 1131 } # show1 loop 1132} # recording device loop 1133 1134# 1135# Now check for deleted shows 1136# 1137if (defined $MYREPLAY_LIST[0] ) 1138{ 1139 for my $title (sort keys %OLD_SHOW) 1140 { 1141 for my $show (@{$OLD_SHOW{$title}}) 1142 { 1143 next if $show->{title} ne ""; # already used? 1144 $show->{title}=$title; 1145 printf "${R_ON}** DELETED ** %-60s ${OFF}\n",sh_summary($show); 1146 $show->{title}=""; 1147 } 1148 } 1149} 1150 1151if ($HTML) 1152{ 1153 print "</pre></body>\n"; 1154} 1155 1156# 1157# If we're doing a MyReplayTV scan, save show file 1158# (we can't do this earlier, due to null cleanup breaking scan) 1159# 1160Save_shows() if ($MYREPLAY_USER ne '' ); 1161 1162} # tv check scan 1163 1164# 1165# That's it, have a nice day 1166# 1167print STDERR "Exiting\n"; 1168exit 0; 1169 1170# 1171# Support subroutines ------------------------------------------------------- 1172# 1173 1174sub opt_summary 1175{ 1176 my $show=shift; 1177 my @options=(); 1178 foreach (0..$#COL) 1179 { 1180 next unless $COL_TYPE[$_] == 3; 1181 push @options,$COL[$_] if $show->{$COL[$_]}; 1182 } 1183 push @options,'*DUPE*' if exists $show->{dupe}; 1184 return '{'.join(",",@options).'}' if @options; 1185 return ""; 1186} #opt_summary 1187 1188# 1189# ep_summary 1190# 1191# Print a one-line summary of the specified episode ( in a subroutine to make changes easier ) 1192# 1193sub ep_summary 1194{ 1195 my $ep = shift || die "ep_summary, how about a episode fella!"; 1196 my $flag = shift || 0; 1197 1198 gen_episode_dates($ep) unless $ep->{day}; 1199 1200# 1201# XMLTV format does some wierd things (IMHO) for multi-part episodes. let's deal with it 1202# 1203 my $desc = get_text($ep ->{"sub-title"}) || get_text($ep->{desc}) || ""; 1204 my @parts; 1205 foreach (@{$ep->{"episode-num"}}) 1206 { 1207 my $text = $_->[0]; 1208 if ($text =~ m!Part *(\d+) *of *(\d+)!i) 1209 { 1210 push @parts, "$1/$2"; 1211 } 1212 elsif ($text =~ m!(\d+)/(\d+)$!) 1213 { 1214 push @parts, ($1+1)."/$2"; 1215 } 1216 else 1217 { 1218 # Ignore episode-nums that aren't understood. FIXME do properly. 1219 } 1220 } 1221 1222 my $part; 1223 if (not @parts) 1224 { 1225 $part = ""; 1226 } 1227 else 1228 { 1229 $part = shift @parts; 1230 foreach (@parts) 1231 { 1232 warn "discarding part $_, doesn't match $part" if $_ ne $part; 1233 } 1234 } 1235 1236 gen_episode_dates($ep) unless $ep->{day}; 1237 1238 return join(" ",$ep->{day}, 1239 mmdd_swap($ep->{mmdd}), 1240 "$ep->{hhmm}/$ep->{len}", 1241 get_text($CHAN{ $ep->{channel}}->{'display-name'}), 1242 ($flag ? "" : get_text( $ep->{title} ) ), 1243 "\"$desc\" $part", 1244 ($ep->{"previously-shown"} ? "(R)" : "" ), 1245 ($ep->{device} ? "[$ep->{device}] " : "" )); 1246} # ep_summary 1247 1248# 1249# sh_summary 1250# 1251# Print a one-line summary of the specified show ( in a subroutine to make changes easier ) 1252# 1253sub sh_summary 1254{ 1255 my $show = shift; 1256 my $val=""; 1257 $val = $show->{title}." (title-scan)" unless $show->{day}; 1258 $val = $show->{day} if $show->{day}; 1259 $val .= " ".mmdd_swap($show->{mmdd}) if $show->{mmdd}; 1260 $val .= " ".$show->{hhmm} if $show->{hhmm}; 1261 $val .= "/".$show->{len} if $show->{len}; 1262 $val .= " ".get_text($CHAN{$show->{channel}}->{'display-name'}); 1263 $val .= " ".$show->{title} if $show->{day}; 1264 $val .= " [".$show->{device}."]" if $show->{device}; 1265 $val .= " ".opt_summary($show); 1266 return $val; 1267} #sh_summary 1268 1269# 1270# find_episode 1271# 1272# given a pointer to a show ( with channel/date/time info) see what's playing then. 1273# 1274# we have a ordered binary date array 1275# Returns undef if no episodes are found (or all are greater, see above) This is signifies no guide info 1276# 1277sub find_episode 1278{ 1279 my $show = shift || die "find_episode(show), show to match please"; 1280 my $chan = $show->{channel}; 1281 my $time = $show->{start}; 1282 1283# 1284# first let's search for a direct match! 1285# 1286 my $ep=$GUIDE{$chan}{$time}; 1287 return $ep if defined $ep; 1288 1289# 1290# now let's do a binary search 1291# 1292 my $times = $GUIDE{starts}{$chan}; 1293 return unless defined $times; # channel not found! 1294 my $low = 0; 1295 my $high = @$times; 1296 1297 while ($low < $high ) 1298 { 1299 1300 my $mid=int(($high+$low)/2); 1301 last if $mid == $low; 1302 $low =$mid if $time >= $times->[$mid]; 1303 $high=$mid if $time < $times->[$mid]; 1304 } 1305 1306# 1307# ok we may have found our show. 1308# 1309 $ep=$GUIDE{$chan}{$times->[$low]}; 1310 gen_episode_dates($ep) unless $ep->{day}; 1311 1312# 1313# we have a miss if result has ended before our start time. 1314# 1315 return undef if $time > $ep->{binstart}+($ep->{len}*60); 1316 1317# 1318# guess we have a hit 1319# 1320 return $GUIDE{$chan}{$times->[$low]}; 1321 1322} # find_episode 1323 1324# 1325# get_text 1326# 1327# Given a pointer to an array of [text,lang] pairs, return the best value for our langauge 1328# Note, if more than one value exists for a language, only the first is returned. 1329# 1330# @LANG should point to a list of languages in order of preferences 1331# 1332sub get_text 1333{ 1334 my $val = (best_name(\@LANG, $_[0]))[0]; 1335 $val = $val->[0] if ref($val); 1336 return $val||""; 1337} 1338 1339#################################################################### 1340sub load_show_table 1341{ 1342 1343%SHOW_DATA=(); 1344%SHOW_WIDTH=(); 1345# 1346# Table headings 1347# 1348for my $col (0..$#COL) 1349{ 1350 $SHOW_DATA{"0,$col"}=(abs($SHOW_SORT) == $col ? uc("_$COL[$col]_") : lc($COL[$col])); 1351 $SHOW_WIDTH{$col} = length($COL[$col]); 1352} 1353 1354# 1355# build sort key of table data 1356# 1357my %sort_keys=(); 1358for my $show (@SHOWS) 1359{ 1360 next unless length($show->{title}); # skip deleted records 1361 my $key = $show->{$COL[abs($SHOW_SORT)]} || 0; 1362 1363# 1364# special sort... by day 1365# 1366 if ( $COL[abs($SHOW_SORT)] eq 'day' ) 1367 { 1368 $key=index($WEEKDAY,$key)/3; 1369 $key=9 if $key < 0; 1370 $key=int($key); 1371 } 1372# 1373# special sort.. channel 1374# 1375 elsif ( $COL[abs($SHOW_SORT)] eq 'chan' ) 1376 { 1377 $key=sprintf("%03d",$1) if $key =~ /^(\d+)/; 1378 } 1379 1380# 1381# save value 1382# 1383 push @{$sort_keys{lc($key)}},$show; 1384} # build sort keys 1385# 1386# display table data sorted by key 1387# 1388my $row=0; 1389my @keys=sort keys %sort_keys; 1390 @keys = reverse @keys if $SHOW_SORT<0; 1391for my $key (@keys) 1392{ 1393 for my $show (@{$sort_keys{$key}}) 1394 { 1395 $row++; 1396 $SHOW_DATA[$row]=$show; 1397 1398 for my $col (0..$#COL) 1399 { 1400 my $val = $show->{$COL[$col]}; 1401 $val="" unless defined $val; 1402 next unless length($val); 1403 1404 $DEVICE{$val}=1 if ($COL[$col] eq 'device'); # help build device list 1405 1406 $SHOW_DATA{"$row,$col"}= $val; 1407 $SHOW_WIDTH{$col} = length($val) if ($SHOW_WIDTH{$col}<length($val)); 1408 } 1409 } 1410} 1411$SHOW_ROW=0; 1412 1413$SHOW_WIDTH{$_} += 3 foreach keys %SHOW_WIDTH; 1414if ($SHOW_TABLE) 1415{ 1416 $SHOW_TABLE -> configure (-rows => ($#SHOWS > 8 ? $#SHOWS+2 : 10 )); 1417 $SHOW_TABLE -> clearCache if $SHOW_TABLE; 1418 $SHOW_TABLE -> selectionClear('all'); 1419 $TOP->title("tv_check config -".( $SHOW_XML || '(untitled)' )); 1420 1421 $SHOW_ROW=0; 1422 $UPDATE_BUTTON -> configure ( -state => "disabled" ); 1423 $DELETE_BUTTON -> configure ( -state => "disabled" ); 1424} 1425 1426load_selection_items() if $SELECT{day}; # in case device list has changed. 1427} # load_show_table 1428 1429# 1430# load selection values 1431# 1432sub load_selection_items 1433{ 1434 1435# 1436# load Device list 1437# 1438 $SELECT{device}{list} -> delete(0,"end"); 1439 $SELECT{device}{list} -> insert(0,"",sort keys %DEVICE); 1440 1441# 1442# load Day list 1443# 1444 $SELECT{day}{list} -> delete(0,"end"); 1445 $SELECT{day}{list} -> insert(0,"",@WEEKDAY); 1446 1447# 1448# load Channel list 1449# 1450 $SELECT{channel}{list} -> delete(0,"end"); 1451 $SELECT{channel}{list} -> insert(0,"",@CHAN); 1452 1453 my $day = $COL_VALUE[$COL{day} ]; 1454 my $chan = $COL_VALUE[$COL{channel}]; 1455 my $title = $COL_VALUE[$COL{title} ]; 1456 1457 my $match = undef; 1458 1459 $day = "" unless defined $day; 1460 $chan = "" unless defined $chan; 1461 $title = "" unless defined $title; 1462 1463 $day =~ s/^\s+|\s+$//g; 1464 $chan =~ s/^\s+|\s+$//g; 1465 $title =~ s/^\s+|\s+$//g; 1466 1467# 1468# load Title list ( also fill hhmm and day if known ) 1469# 1470 1471 $SELECT{title}{list} -> delete(0,"end"); 1472 if (length($day) && length($chan)) 1473 { 1474 $SELECT{title}{list} -> insert(0,"",sort keys %{$GUIDE{$day}{$chan}}); 1475 $match = $GUIDE{$day}{$chan}{$title}; 1476 } 1477 elsif (length($day)) 1478 { 1479 $SELECT{title}{list} -> insert(0,"",sort keys %{$GUIDE{day}{$day}} ); 1480 $match=$GUIDE{day}{$day}{$title}; 1481 } 1482 elsif (length($chan)) 1483 { 1484 $SELECT{title}{list} -> insert(0,"",sort keys %{$GUIDE{chan}{$chan}} ); 1485 $match=$GUIDE{chan}{$chan}{$title}; 1486 } 1487 else 1488 { 1489 $SELECT{title}{list} -> insert(0,"",sort keys %{$GUIDE{all}} ); 1490 $match=$GUIDE{title}{$title}; 1491 } 1492 1493# 1494# if we have a match, fill all fields 1495# 1496 if ($match) 1497 { 1498 $COL_VALUE[$COL{day} ] = $match->[0]->[0] || ""; 1499 $COL_VALUE[$COL{channel}] = $match->[0]->[1] || ""; 1500 $COL_VALUE[$COL{hhmm} ] = $match->[0]->[2] || ""; 1501 $COL_VALUE[$COL{len} ] = $match->[0]->[3] || ""; 1502 } 1503} #load_selection_items 1504 1505# 1506# help popup 1507# 1508sub help_popup 1509{ 1510 my $help = MainWindow->new; 1511 $help->title("tv_check help"); 1512 $help->Label(-wraplength => '4i' , 1513 -justify => 'left', 1514 -text => " 1515This is a program to create/maintain a show XML file for use with tv_check. 1516 1517I hope it's fairly intuitive. One thing that can get you is the aggressive nature 1518of the autofill of the selection fields. The good news is the routine only kicks 1519off when you click a listbox. Don't click in a listbox and you can edit the raw 1520data all like. 1521 1522Don't forget to check out README.tv_check 1523 1524Good Luck! 1525Robert Eden 1526rmeden\@cpan.org 1527")->pack(); 1528} # help_popup 1529 1530sub help_about 1531{ 1532 my $help = MainWindow->new; 1533 $help->title("tv_check about"); 1534 $help->Label(-wraplength => '4i' , 1535 -justify => 'left', 1536 -text => ' 1537 1538tv_check $Revision: 1.77 $ 1539(C) 2002 Robert Eden 1540reden@cpan.org 1541 1542This program can be used/distributed on the same terms as the XMLTV distribution. 1543 1544http://xmltv.sourceforge.net 1545')->pack; 1546} # help_about 1547 1548# 1549# Error popup 1550# 1551sub error_popup 1552{ 1553 my $msg = shift; 1554 1555 print STDERR "\nerror: $msg\n"; 1556 1557 $TOP->messageBox( -icon => 'error', 1558 -type => 'ok', 1559 -title => 'TV-Check error', 1560 -message => $msg) if $TOP; 1561} #error popup 1562 1563# 1564# load show array 1565# 1566sub load_shows 1567{ 1568 my $file = shift; 1569 unless (-e $file) 1570 { 1571 print STDERR "\nWarning: show file not found ($file)\n"; 1572 return; 1573 } 1574 1575 $SHOW_XML = $file; 1576 print STDERR "Loading xml show info ($SHOW_XML)\n"; 1577 1578 my $twig = new XML::Twig(TwigHandlers => 1579 { shows => sub { 1580 my ($twig, $show) =@_; 1581 push @SHOWS,$show->atts; 1582 }, 1583 lang => sub { 1584 my ($twig, $lang) =@_; 1585 push @LANG,$lang->text; 1586 }, 1587 }); 1588 $twig->parsefile($SHOW_XML); 1589 1590 printf STDERR "Loaded xml show file ($SHOW_XML) (%d/%d)\n",$#SHOWS+1,$#LANG+1; 1591 1592# 1593# fix show entry 1594# 1595 for my $show (@SHOWS) 1596 { 1597# 1598# UTF-8 encoding seems to *BREAK* display! go figure 1599# 1600 utf8::downgrade($show->{title}); 1601 1602# 1603# ensure no null values 1604# 1605 for my $col ( keys %COL ) 1606 { 1607 $show->{$col} = '' unless defined $show->{$col}; 1608 } 1609 1610# 1611# convert channel ID to new format if ncessary 1612# 1613 if ( ! exists $CHAN{$show->{channel}} 1614 && exists $CHAN_NAME{$show->{channel}} ) 1615 { 1616 printf STDERR "Converting Show File Channel ID %10s to %25s\n",$show->{channel},$CHAN_NAME{$show->{channel}}; 1617 $show->{channel}=$CHAN_NAME{$show->{channel}}; 1618 } 1619 1620# 1621# convert numeric date if needed. 1622# 1623# next unless length($show->{day}); 1624 $show->{day}=$WEEKDAY[$1] if $show->{day} =~ /^(\d+)/; 1625 1626 1627 } # fix entries 1628 1629 unless (@SHOWS) 1630 { 1631 error_popup("$SHOW_XML does not appear to be a show xml file"); 1632 } 1633 1634 load_show_table(); 1635 1636 if ($SHOW_TABLE) 1637 { 1638 $SHOW_TABLE->pack('forget'); 1639 $SHOW_TABLE->pack(-side => 'top', -expand => 1, -fill => 'both'); 1640 } 1641 $SHOW_CHANGED=0; 1642} #load_show 1643 1644 1645# 1646# load channel guide 1647# 1648sub load_guide 1649{ 1650 my $file = shift; 1651 1652 unless (-e $file) 1653 { 1654 error_popup("Guide file not found ($file)"); 1655 return; 1656 } 1657 1658 1659 my $st=time(); 1660 my $c=0; 1661 $GUIDE_XML = $file; 1662 print STDERR "Loading xml guide info ($file) "; 1663 my $xml = XMLTV::parsefile($file); 1664 1665 $ENCODING = $xml->[0]; 1666 %CHAN = %{$xml->[2] }; 1667 @GUIDE = @{$xml->[3] }; 1668 %GUIDE = (); 1669 print STDERR $#GUIDE+1," recs / ",(time()-$st)," secs\n"; 1670 unless (@GUIDE) 1671 { 1672 error_popup("Listings file ($file) invalid or empty"); 1673 } 1674 1675 # 1676 # Build indexes for Episode Data 1677 # 1678 $st=time(); 1679 $c=0; 1680 print STDERR "Building Episode Indexes "; 1681 for my $ep (@GUIDE) 1682 { 1683 print STDERR "." unless $c++ % 1000; 1684 my $title = lc(get_text($ep->{title})); 1685 1686 my $chan = $ep->{channel} || "" ; 1687 $CHAN{$chan}{'display-name'}[0][0]=$chan unless exists $CHAN{$chan}; 1688 1689 if (! exists $ep->{start}) 1690 { 1691 warn "\n No start time for $title\n"; 1692 next; 1693 } 1694 1695# 1696# convert XMLTV time to binary 1697# 1698 $ep->{stop}=$ep->{start} unless exists $ep->{stop}; 1699 $ep->{binstart} = UnixDate($ep->{start},"%s"); 1700 1701# 1702# don't consider a show a repeat if it has been shown in the past 2 months. 1703# 1704 delete $ep->{"previously-shown"} if exists $ep->{"previously-shown"} 1705 and exists $ep->{"previously-shown"}{start} 1706 and $ep->{"previously-shown"}{start} gt $TWOM_MMDD; 1707 $ep->{displayed}=""; 1708 $ep->{device}=""; 1709 1710# 1711# build general indexes (--scan + --configure) 1712# 1713 push @{$GUIDE{all}{$title}},$ep; # all titles 1714 $GUIDE{$chan}{$ep->{binstart}}=$ep; # chan, datetime 1715 1716# 1717# build --configure only indexes 1718# 1719 if ($CONFIGURE) 1720 { 1721 gen_episode_dates($ep); 1722 my $array = [$ep->{day},$ep->{channel},$ep->{hhmm},$ep->{len}]; 1723 1724 push @{$GUIDE{title} {$title}} ,$array; # titles by chan 1725 push @{$GUIDE{chan} {$chan} {$title}} ,$array; # titles by chan 1726 push @{$GUIDE{day} {$ep->{day}} {$title}} ,$array; # titles by day 1727 push @{$GUIDE{$ep->{day}}{$chan} {$title}} ,$array; # titles by chan by day 1728 } 1729 } # building guide indexes 1730 1731# 1732# Now compute next/prev episodes and start time array 1733# 1734 for my $chan (keys %GUIDE) 1735 { 1736 $GUIDE{starts}{$chan}=[sort keys %{$GUIDE{$chan}}]; # start time array 1737 1738 my $prev=undef; 1739 next if $chan eq 'chan'; # skip special indexes 1740 next if $chan eq 'day'; 1741 next if $chan eq 'all'; 1742 next if $chan eq 'starts'; 1743 next unless exists $CHAN{$chan}; 1744 1745 for my $date ( @{$GUIDE{starts}{$chan}} ) 1746 { 1747 my $ep=$GUIDE{$chan}{$date}; 1748 $ep ->{prev}=$prev; 1749 $prev->{next}=$ep if defined $prev; 1750 $prev =$ep; 1751 } #date 1752 $prev->{next}=undef if defined $prev; 1753 } #chan 1754 1755 print STDERR " $c recs / ",time()-$st,"secs \n"; 1756 error_popup("guide file $GUIDE_XML does not appear to be valid") unless @GUIDE; 1757 1758 # 1759 # Build channel sort 1760 # 1761 my %sorting; 1762 foreach (keys %CHAN ) 1763 { 1764 my $key = $_; 1765 $key=sprintf("%03d",$1) if /^(\d+)/; 1766 $sorting{$key}=$_; 1767 $CHAN_NAME{get_text($CHAN{$_}->{'display-name'})}=$_, 1768 1769 } 1770 @CHAN=(); 1771 map { push @CHAN,$sorting{$_}; } sort keys %sorting; 1772 1773 1774 load_selection_items() if $SELECT{day}; 1775} #load_guide 1776 1777 1778# 1779# Generate XML to save current show array 1780# 1781sub Save_shows 1782{ 1783 unless ($SHOW_XML) 1784 { 1785 error_popup("no show file defined, data will be lost, aborting"); 1786 return 1; 1787 } 1788 1789# 1790# recreate show array dropping deleted elements 1791# 1792 my @newshow; 1793 for my $show (@SHOWS) 1794 { 1795 next unless $show -> {title}; 1796 for my $item ( keys %$show ) 1797 { 1798 if ( exists $COL{$item} ) 1799 { 1800 delete $show -> {$item} unless $show->{$item}; #no null values 1801 } 1802 else 1803 { 1804 delete $show -> {$item}; # no "extra" values 1805 } 1806 } 1807 push @newshow,$show; 1808 } 1809 1810# 1811# dump xml 1812# 1813 print STDERR "saving shows to $SHOW_XML\n"; 1814 my $output = new IO::File(">$SHOW_XML"); 1815 my $writer = new XML::Writer(OUTPUT=>$output, 1816 DATA_MODE=>1, 1817 DATA_INDENT=>2); 1818 $writer->xmlDecl("ISO-8859-1"); 1819 $writer->startTag('tv_check'); 1820 $writer->emptyTag('lang' ,%$_) foreach (@LANG); 1821 $writer->emptyTag('shows',%$_) foreach (@newshow); 1822 $writer->endTag('tv_check'); 1823 $writer->end; 1824 $SHOW_CHANGED=0; 1825} # Save_shows 1826 1827# 1828# give chance to save file before losing changes 1829# 1830sub changed_check 1831{ 1832 my $nocan = shift || 0; 1833 if ($SHOW_CHANGED) 1834 { 1835 my $button = lc($TOP->messageBox( -icon => 'warning', 1836 -type => ( $nocan ? 'YesNo' : 'YesNoCancel'), 1837 -title => 'File Change Warning', 1838 -message => "Show data changed. Do you want to save?")); 1839 if ($button eq 'yes') { Save_shows(); } 1840 elsif ($button eq 'cancel' ) { return 1; } 1841 elsif ($button ne 'no' ) { die "Button returned unexpected value <$button>\n"}; 1842 $SHOW_CHANGED=0; # prevent 2nd warning 1843 } 1844 return 0; 1845} # changed_check 1846 1847# 1848# Note, Date::Manip doesn't deal with DST switch correctly. We need to use localtime 1849# 1850sub gen_episode_dates 1851{ 1852 my $ep = shift || die "empty episode "; 1853 1854 my @d=localtime($ep->{binstart}); $d[4]++; $d[5]+=1900; 1855 1856 $ep->{day} = $WEEKDAY[$d[6]]; 1857 $ep->{hhmm} = sprintf("%02d%02d",@d[2,1]); 1858 $ep->{mmdd} = sprintf("%4d%02d%02d",@d[5,4,3]); 1859 $ep->{len} = Delta_Format( DateCalc( $ep->{start},$ep->{stop}), 0,"%mh"); 1860 1861} # gen_episode_dates 1862 1863# 1864# 1865# 1866sub validate_col_value 1867{ 1868 for my $col (0..$#COL) 1869 { 1870 $_ = $COL_VALUE[$col]; 1871 $_ = '' unless defined $_; 1872 next unless length($_) ; 1873 1874 s/^\s+|\s+$//g; 1875 if ($COL[$col] eq 'len') 1876 { 1877 $_ = '' unless /^\d+/; 1878 } 1879 if ($COL_TYPE[$col] == 3) 1880 { 1881 $_ = ( $_ ? 1 : ''); 1882 } 1883 $COL_VALUE[$col] = $_; 1884 } 1885} # validate_col_value 1886 1887sub add_myreplaytv_show 1888{ 1889 print STDERR " adding myreplaytv: @_\n" if ($MYREPLAY_DEBUG == 2); 1890 my $show; 1891 my $title = shift || ''; 1892 my $chan = shift || ''; 1893 my $start = shift || ''; 1894 my $len = shift || ''; 1895 my $day = shift || ''; 1896 my $foundit = 0; #used to supress message on auto-theme 1897 1898 printf STDERR "want <%s>/<%s>/<%s>\n",$chan,$start,$day if ($MYREPLAY_DEBUG == 2); 1899 for my $old (@{$OLD_SHOW{$title}}) # capture settings from pre-existing show 1900 { 1901 next if $old->{title} ne ""; # already used? 1902 1903 printf STDERR " got <%s>/<%s>.<%s>\n",$old->{channel},$old->{hhmm},$old->{day} if ($MYREPLAY_DEBUG == 2); 1904 if ( ( $old->{channel} eq $chan #use old show if chan/time match 1905 and $old->{hhmm} eq $start) 1906 || ( !$day && #use old show if old and new are title only 1907 ( !exists $old->{day} or $old->{day} eq '' )) 1908 ) 1909 { 1910 print STDERR "Found old $title\n" if ($MYREPLAY_DEBUG == 2); 1911 $foundit=1; 1912 $show=$old; 1913 $show->{day} = $day if $day; #only change day if we know what it is! 1914 last; 1915 } 1916 } # old show check 1917 1918 unless ($show) # build a new show entry 1919 { 1920 print STDERR "Make new $title\n" if ($MYREPLAY_DEBUG == 2); 1921 $show->{$_}='' foreach (0..$#COL); # initialize to blanks 1922 $show->{device} ="MyReplayTV$MYREPLAY_UNIT"; # set initial values 1923 $show->{chanonly}=1; 1924 $show->{day}=$day; 1925 push @SHOWS,$show; 1926 } 1927 1928 $show->{title} = $title; 1929 $show->{channel}= $chan; 1930 $show->{hhmm} = $start; 1931 $show->{len} = $len; 1932 return $foundit; 1933} #add_myreplaytv_show 1934 1935# 1936# quick routine to compute minute of day from hhmm 1937# 1938sub hhmm_min 1939{ 1940 my $hh=substr($_[0],0,2); 1941 my $mm=substr($_[0],2,2); 1942 return ($hh*60+$mm) 1943} 1944 1945# 1946# quick routine for mmdd->ddmm for our users across the pond 1947# 1948sub mmdd_swap 1949{ 1950 my $mm=substr($_[0],4,2); 1951 my $dd=substr($_[0],6,2); 1952 return $dd.$mm if $DDMM; 1953 return $mm.$dd; 1954} 1955