1#!/usr/local/bin/perl -w 2 3=pod 4 5=head1 NAME 6 7tv_grab_na_dd - Grab TV listings for North America using Schedules Direct http://www.schedulesdirect.org 8 9=head1 SYNOPSIS 10 11 tv_grab_na_dd --help 12 13 tv_grab_na_dd --version 14 15 tv_grab_na_dd --capabilities 16 17 tv_grab_na_dd --configure [--config-file FILE] [--dd-data FILE] 18 [--reprocess] [--auto-config add|ignore] 19 [--gui OPTION] 20 21 tv_grab_na_dd --list-lineups [--config-file FILE] [--dd-data FILE] 22 [--reprocess] 23 24 tv_grab_na_dd [--config-file FILE] [--dd-data FILE] 25 [--reprocess] [--auto-config add|ignore] 26 [--days N] [--offset N] [--quiet] [--notrim] 27 [--old-chan-id] [--low-mem] [--output FILE] 28 [--list-channel] [--share SHAREDIR] [--list-times] 29 [--download-only] [--padd n] [--dropbadchar] [--agent NAME] 30 31=head1 DESCRIPTION 32 33This script downloads TV listings using Schedules Direct's data service, 34converts it to XMLTV format, and outputs the results. 35 36You must first register with Schedules Direct at: L<http://www.schedulesdirect.org> 37 38Schedules Direct is a non-profit organization whose mission is to provide 39low-cost television program guide data to end-users of Open Source 40and Freeware applications. 41 42The raw data source is Schedules Direct's SD-DD service, which purchases 43Data from Gracenote (formerly known as Tribune Media Services). 44 45While the service is not available for free, Schedules Direct strives 46to keep costs as low as possible. 47 48First you must become a member at the L<http://www.schedulesdirect.org> site. 49 50Next, you use that website to add lineup(s) to your account. 51 52Next, you execute C<tv_grab_na_dd --configure> to set up the grabber. 53 54Finally, you execute B<tv_grab_na_dd> with no arguments and it will output 55listings in XML format to standard output. See below for other options. 56 57Like many utilities, tv_grab_na_dd tries to exit with a "0" on success and something else 58on error. 59 60=head1 Stand-alone options 61 62=over 63 64=item --help 65 66Print a help message and exit. 67 68=item --version 69 70Show the version of the grabber. 71 72=item --capabilities 73 74Show which capabilities the grabber supports. For more 75information, see L<http://wiki.xmltv.org/index.php/XmltvCapabilities> 76 77=back 78 79=head1 Mode selection (default is grab mode) 80 81=over 82 83=item --configure 84 85Activates configure mode. If a config file already exists the values 86are used as defaults. 87 88=item --gui OPTION 89 90Use this option to enable a graphical interface to be used. 91OPTION may be 'Tk', or left blank for the best available choice. 92Additional allowed values of OPTION are 'Term' for normal terminal output 93(default) and 'TermNoProgressBar' to disable the use of Term::ProgressBar. 94 95=item --list-lineups 96 97Lists available lineups. Only requires username in the config file. Used 98by programs that automate the L</--configure> process. 99 100=back 101 102=head1 General Options 103 104=over 105 106=item --config-file 107I<file> 108 109Set the name of the configuration file, the default is B<~/.xmltv/tv_grab_na_dd.conf>. 110This is the file created during L</--configure> mode. 111 112=item --dd-data 113I<file> 114 115Store raw Data Direct data to this file. (default is a temporary file) 116 117=item --reprocess 118 119Don't get data from Data Direct, but reprocess a file saved with L<--dd-data|/"--dd-data I<file>">. 120 121=item --auto-config I<add|ignore> 122 123When used in --configure mode, updates the config file, removing old channels, and adding or 124ignoring new channels. Prompts are skipped if defaults are available in the current config file. 125 126When used in grab mode, appends new channels to the config file. 127 128=back 129 130=head1 Grabber Mode options 131 132=over 133 134=item --days I<n> 135 136Grab I<n> days. The default is 7. 137 138=item --offset I<n> 139 140Start N days after the default. 141 142=item --quiet 143 144Suppress some messages normally written to standard error. 145 146=item --notrim 147 148Data Direct includes shows in progress at the start time. The default behavior 149is to filter these shows out so data can be cleanly split between days. This 150option turns off that filter so you get shows in progress a tthe start time. 151 152=item --old-chan-id 153 154Use a channel id similar to the one used by the old B<tv_grab_na> grabber. 155 156=item --low-mem 157 158Omit all but the most basic program information. Reduces memory usage. 159 160=item --output I<file> 161 162Write xml to I<file> rather than standard output. 163 164=item --list-channel 165 166Same as B<--days> 0 167 168=item --share I<SHAREDIR> 169 170tv_grab_na_icons stores icons in I<SHAREDIR>/icons. The share directory is set at install time, 171but there may be times when it needs to be specified. (for example: no write access to the default share 172directory) 173 174=item --list-times 175 176Report to STDERR the Schedules Direct blockedTime (not currently enforced) 177and suggestedTime values to assist automated processes with scheduling. 178 179=item --download-only 180 181Don't generate any output, just fetch the data. Personally I don't see the point, 182but it was requested and easy to add. 183 184=item --padd I<n> 185 186Add <n> spaces to the front of the start date. This is normally not needed, 187but can be helpful in working around a SD-DD problem when the request packet 188spans TCP packets. Recommended initial value is "20". This is only needed if you get 189"invalid start time" messages. If this helps, please post results to the list. 190 191=item --dropbadchar 192 193DD data is supposed to be in UTF-8 format. Sometimes DD sends bad characters 194which cause a "Bad XML from DD" error. This option causes those bad characters 195to be deleted. 196 197=item --agent NAME 198 199appends NAME to the http agent string when fetching data. This is a polite way to 200tell Schedules Direct which application is being used. It helps developers know 201how many people are using their application and gives applications credit towards 202free accounts. 203 204=back 205 206=head1 Automating configuration 207 208Sometimes applications want to call B<tv_grab_na_dd> as a standalone application, 209but automate the configure process. The best way is to hook in to the XMLTV::Ask module, 210but if that's not available, here is a solution. 211 212=over 213 214Step1. Application creates config file with username (and optionally password). 215 216Step2. C<tv_grab_na_dd --dd-data lineups.xml --list-lineups> 217 218Step3. Application adds desired lineup to config file. 219 220Step4. C<tv_grab_na_dd --dd-data lineups.xml --reprocess --auto-config add --list-channels> 221 222Step5. Application edits config file as needed, and deletes lineups.xml. 223 224=back 225 226=head1 Grabber Timing 227 228Data Direct offers a "suggested download time" that can be retrieved with the 229"--list-times" option. Its use is encouraged. 230 231=head1 Handling Multiple Linups 232 233tv_grab_na_dd only outputs a single lineup. If your Schedules Direct 234account has multiple lineups, they are all downloaded even though only one is output. 235 236To process multiple lineups, use separate L<--config-file|/"--config-file I<file>">. 237Separate config files are also handy if you need different channel sets for a lineup 238(common with MythTV). To prevent re-downloading the data on subsequent passes, the 239L</--reprocess> option is recommended. 240 241Here's an example: (the = sign is optional, but helps readability) 242 243 tv_grab_na_dd --config-file=lineup1.dat --output=lineup1.xml --dd-data=dd.xml 244 tv_grab_na_dd --config-file=lineup2.dat --output=lineup2.xml --dd-data=dd.xml --reprocess 245 tv_grab_na_dd --config-file=lineup3.dat --output=lineup3.xml --dd-data=dd.xml --reprocess 246 247Each config file specifies the desired lineup and channel list. 248 249If you want to merge the lineups into a single file, you can use tv_cat 250 251 tv_cat lineup1.xml lineup2.xml lineup3.xml >guide.xml 252 253=head1 Adding icon links to listings 254 255B<tv_grab_na_dd> checks for channel icons in a directory B<I<share>>/B<icons>. The I<share> directory 256is usually set during the install. For windows exe users, it defaults to the location where 257B<xmltv.exe> is. B<tv_grab_na_icons> is available to download the icons. 258 259=head1 Notes on channel lists 260 261Channel lists can be configured both at the Schedules Direct website and through the grabber. This is done to 262allow multiple config files with different channel lists as Schedules Direct only supports a single channel map 263per lineup. 264 265Similarly, tv_grab_na_dd only supports a single channel mapping for a station. If multiple mappings 266are detected, only the first one is used and you are advised to adjust your Schedules Direct lineup. 267 268=head1 Notes on episode numbers 269 270Three episode-num formats are supplied (when available) 271 272=over 273 274=item xmltv_ns 275 276always C<..a/b> for part C<a> of C<b>. First two xmltv_ns fields always blank. 277 278=item dd_progid 279 280Gracenote generated C<a.b.c/d> where C<a> is a unique program id, C<b> is a unique episode id, 281C<c/d> is part C<c> of C<d> similar to xmltv_ns. 282 283=item onscreen 284 285Distributor-designated number corresponding to an episode of a specific show. Varies by distributor. 286 287=back 288 289=head1 Notes on passwords 290 291If a password is stored in the config file, the config file should be properly protected. 292Instead of storing the password in the config file, it can be omitted, and will be prompted for. 293 294=head1 Notes on lineup changes 295 296Data Direct currently adds a channel to your lineup automatically when it is available. When 297B<tv_grab_na_dd> sees the new channel in the Schedules Direct lineup, it prints a message (and 298potentially adds or ignores it based on --auto-config). 299 300If you are sensitive to bandwidth issues, I would set B<--auto-config ignore> and periodically check 301your B<--config-file> for ignored channels and remove from your Schedules Direct lineup. 302 303=head1 Notes on previously-shown 304 305Previous releases of tv_grab_na_dd set XMLTV's "date" field for DD "original-air-date" field. 306The correct place for the data is "previously-shown->start" The OAD is in both places temporarily 307for compatibility reasons. 308 309DD has dropped the "repeat" flag and replaced it with a "new" flag. Now we set "previously-shown 310 311=head1 Known issues 312 313none! 314 315=head1 SEE ALSO 316 317L<xmltv(5)>. 318 319=head1 Author 320 321Author/Maintainer: Robert Eden, rmeden@yahoo.com 322 323=head2 Contributors: 324 325=over 326 327Ed Avis, ed@membled.com 328 329Don Huettl, drh@huettl.net 330 331Matti Airas, mairas@iki.fi (I used tv_grab_fi as a template) 332 333and of course everyone else I forgot to mention. :) 334 335=back 336 337=cut 338 339################################################################# 340# initializations 341 342use strict; 343use XMLTV::Version '$Id: tv_grab_na_dd.in,v 1.93 2016/03/13 08:06:09 rmeden Exp $ '; 344use XMLTV::Capabilities qw/baseline manualconfig share/; 345use XMLTV::Description 'North America (Data Direct)'; 346use Data::Dumper; 347use Date::Manip; 348use Time::Local; 349use SOAP::Lite; 350use File::Temp qw(tempfile); 351use Getopt::Long; 352use XML::Twig 3.10; 353 354use XMLTV; 355use XMLTV::Ask; 356use XMLTV::Config_file; 357use XMLTV::ProgressBar; 358use XMLTV::TZ qw(offset_to_gmt); 359use XMLTV::Usage <<END 360$0: get listings via Schedules Direct (http://schedulesdirect.org) 361in XMLTV format 362 363 tv_grab_na_dd --help 364 365 tv_grab_na_dd --version 366 367 tv_grab_na_dd --capabilities 368 369 tv_grab_na_dd --configure [--config-file FILE] [--dd-data FILE] 370 [--reprocess] [--auto-config add|ignore] 371 [--gui OPTION] 372 373 tv_grab_na_dd --list-lineups [--config-file FILE] [--dd-data FILE] 374 [--reprocess] 375 376 tv_grab_na_dd [--config-file FILE] [--dd-data FILE] 377 [--reprocess] [--auto-config add|ignore] 378 [--days N] [--offset N] [--quiet] [--notrim] 379 [--old-chan-id] [--low-mem] [--output FILE] 380 [--list-channel] [--share SHAREDIR] [--list-times] 381 [--download-only] [--padd n] [--dropbadchar] [--agent STRING] 382 383END 384; 385# 386# module version checking doesn't work with XMLTV version numbers 387# 388die "ERROR: XMLTV.PM 0.5.32 required\n" if $XMLTV::VERSION lt '0.5.32'; 389 390# 391# Global Vars 392# 393my $SHARE_DIR ='c:/share/xmltv'; 394my @messages; # DD warnings. 395my %chan_config; # Active/inactive channels. 396my %chan_id; # quick channel id lookup 397my %station; # DD station data 398my %lineups; # DD channel mapping data 399my %program; # DD program data 400my %crew; # DD crew data 401my %programGenre; # DD Genre data 402my @schedules; # DD schedule list 403 404my $bar; # handle for status bar 405my $count; # record count (for status bar) 406my $DEBUG =0; # debug mode 407my $config_file; # config file name 408my $tz_offset=0; 409my $start_time=time(); 410my $sched_count=0; # record count; 411my %old_lineups=(); # used for DD schema 1.2 -> 1.3 migration 412my %icons=(); # holds icons (if present) 413 414my $dd_user=""; # dd username 415my $dd_pass=""; # dd password 416my $dd_lineup=""; # dd lineup (empty all lineups) 417my $dd_data; # temp file handle to store DD data 418my $dd_schema=undef; # dd schema found 419my $dd_data_name; # filename for above 420my $dd_data_size; # amount of data returned 421my $dd_start; # dd start time 422my $dd_stop; # dd stop time 423 424my $opt_help; # ask for help 425my $opt_configure; # configure mode 426my $opt_config_file ; # config_file_name 427my $opt_gui ; # use a gui for configuration 428my $opt_output; # output name 429my $opt_days =7; # days to fetch 430my $opt_offset =0; # day to start 431my $opt_quiet =0; # supress messages 432my $opt_lineup =''; # limit results to one lineup 433my $opt_old_chan_id=0; # use tv_grab_na style chan ids 434my $opt_low_mem =0; # use as little memory as you can 435my $opt_dd_data =''; # save dd data 436my $opt_reprocess =''; # reprocess dd data 437my $opt_auto_config =''; # auto add/ignore channels 438my $opt_list_channels=''; 439my $opt_list_lineups='' ; 440my $opt_list_times='' ; 441my $opt_dropbadchar=0; ; 442my $opt_down_only=0 ; 443my $opt_padd=0 ; 444my $opt_tz_offset=undef; 445my $opt_notrim=0; 446my $opt_agent=""; 447 448# 449# Process command line 450# 451foreach (@ARGV) { 452 tr/_/-/ if /^--/; # older option style 453} 454GetOptions( 455 'help' => \$opt_help, 456 'configure' => \$opt_configure, 457 'config=s' => \$opt_config_file, 458 'config-file=s' => \$opt_config_file, 459 'gui:s' => \$opt_gui, 460 'output=s' => \$opt_output, 461 'days=i' => \$opt_days, 462 'offset=i' => \$opt_offset, 463 'quiet' => \$opt_quiet, 464 'lineup=s' => \$opt_lineup, 465 'old_chan_id' => \$opt_old_chan_id, 466 'old-chan-id' => \$opt_old_chan_id, 467 'low_mem' => \$opt_low_mem, 468 'low-mem' => \$opt_low_mem, 469 'dd_data=s' => \$opt_dd_data, 470 'dd-data=s' => \$opt_dd_data, 471 'reprocess' => \$opt_reprocess, 472 'auto-config=s' => \$opt_auto_config, 473 'auto_config=s' => \$opt_auto_config, 474 'list-channels' => \$opt_list_channels, 475 'list-lineups' => \$opt_list_lineups, 476 'list-times' => \$opt_list_times, 477 'download-only' => \$opt_down_only, 478 'debug' => \$DEBUG, 479 'share=s' => \$SHARE_DIR, 480 'dropbadchars' => \$opt_dropbadchar, 481 'padd=i' => \$opt_padd, 482 'notrim' => \$opt_notrim, 483 'agent=s' => \$opt_agent, 484 ) 485 or usage(0); 486usage(1) if $opt_help; 487die "ERROR: number of days must not be negative\n" if ($opt_days < 0); 488die "ERROR: must specify --dd_data during reprocess\n" if $opt_reprocess and not $opt_dd_data; 489die "ERRIR: --auto-config must be 'add' or 'ignore'\n" if $opt_auto_config && $opt_auto_config !~ /^(add|ignore)$/; 490die "ERROR: --down-only without --dd-data is pointless!\n" if $opt_down_only && ! $opt_dd_data; 491 492$opt_days = 0 if $opt_configure || $opt_list_channels || $opt_list_lineups; 493XMLTV::Ask::init($opt_gui); 494$config_file = XMLTV::Config_file::filename($opt_config_file, 'tv_grab_na_dd' , $opt_quiet); 495 496 497######################################################################## 498# 499# Load config file 500# 501if (-e $config_file && ( !$opt_configure || -s $config_file )) 502{ 503 foreach (XMLTV::Config_file::read_lines($config_file)) 504 { 505 next unless defined $_; 506 chomp; 507 my( $setting, $val ) = split( /:\s+/o, $_, 2 ); 508 509 if ( $setting =~ /^(not )?channel$/o ) 510 { 511 $chan_config{$val} = $1 ? 0 : 1; 512 } 513 elsif ( $setting eq 'username' ) 514 { 515 $dd_user = $val; 516 } 517 elsif ( $setting eq 'password' ) 518 { 519 $dd_pass = $val; 520# print STDERR "\nWARNING: Password in config file, protect as required\n\n" unless $opt_quiet; 521 } 522 elsif ( $setting eq 'timezone' ) 523 { 524 $opt_tz_offset = $val; 525 $opt_tz_offset='+0000' if $opt_tz_offset =~ /UTC/i; 526 } 527 elsif ( $setting eq 'timeoffset' ) 528 { 529 $opt_tz_offset = $val; 530 $opt_tz_offset='+0000' if $opt_tz_offset =~ /UTC/i; 531 } 532 elsif ( $setting eq 'lineup' ) 533 { 534 $dd_lineup = $val; 535# 536# special processing for dd_schema 1.2 -> 1.3 537# 538 if (exists $old_lineups{$dd_lineup}) 539 { 540 print STDERR "WARNING: Lineup IDs have changed. Please run --configure\n"; 541 $dd_lineup = $old_lineups{$dd_lineup}; 542 } 543 } 544 elsif ( $setting eq 'auto-config' ) 545 { 546 $opt_auto_config = $val; 547 } 548 else 549 { 550 warn "WARNING: Unknown setting: $setting, skipping.\n"; 551 } 552 } 553} # load config file 554 555# 556# 557# start --configure mode 558# 559 560if ( $opt_configure ) 561{ 562 if ( ! $opt_auto_config ) 563 { 564 while (1) 565 { 566 if (defined $ENV{TZ}) 567 { 568 $opt_tz_offset=$ENV{TZ} unless defined $opt_tz_offset || $ENV{TZ} !~ /[+-]\d\d\d\d/; 569 } 570 $opt_tz_offset='+0000' if (defined $opt_tz_offset && $opt_tz_offset =~ /UTC/i); 571 $opt_tz_offset='+0000' unless defined $opt_tz_offset; 572 573 $opt_tz_offset=ask(" 574 575Time OFFSET Selection (note: not a timeZONE) 576It is better to specify +0000 and let the final application 577deal with a local conversion (helps with DST issues), but you 578can specify a Time Offset if desired. 579+0000 UTC 580-0400 Eastern Daylight 581-0500 Eastern Standard or Central Daylight 582-0600 Central Standard or Mountain Daylight 583-0700 Mountain Standard or Pacific Daylight 584-0800 Pacific Standard 585Timezone offset (+/-####) ($opt_tz_offset)") || $opt_tz_offset; 586 last if $opt_tz_offset =~ /[+-]\d\d\d\d/; 587 } 588 589 say(" 590Schedules Direct registration required in advance. 591Sign up at http://www.schedulesdirect.org 592(don't forget to add a lineup!) 593 594 "); 595 $dd_user=ask("Username ($dd_user):")|| $dd_user || die "ERROR: Schedules Direct Username Required\n"; 596 $dd_user=lc($dd_user); # force lower-case on username 597 $dd_pass=ask_password(" 598WARNING: Storing the password in the config file is not secure 599If password is blank, it will be prompted as needed(more secure) 600Unsecured password ('x':delete,default:<keep>,):")|| $dd_pass; 601 } 602 $dd_pass='' if $dd_pass eq 'x'; 603} #configure mode 604 605die "*ERROR* Username not specified. Please run --configure\n" unless $dd_user; 606die "*ERROR* Lineup not specified. Please run --configure\n" unless $dd_lineup || $opt_list_lineups || $opt_configure; 607die "*ERROR* Local timezone not yet supported. Please run --configure\n" unless defined $opt_tz_offset; 608die "*ERROR* Bad timezone offset Please run --configure\n" unless $opt_tz_offset =~ /[+-]\d\d\d\d/; 609 610$tz_offset = substr($opt_tz_offset,0,3)*3600+substr($opt_tz_offset,3,2)*60; 611#$opt_tz_offset='UTC' unless $tz_offset; 612print STDERR "Using TZ=<$opt_tz_offset> offset=<$tz_offset>\n" if $DEBUG; 613 614# 615# compute start/stop time 616# 617{ 618 if (int(Date::Manip::DateManipVersion) >= 6) { 619 Date::Manip::Date_Init("SetDate=now," . offset_to_gmt($opt_tz_offset)); 620 } else { 621 Date::Manip::Date_Init("TZ=" . offset_to_gmt($opt_tz_offset)); 622 } 623# 624# TMS bug causes errors around UTC midnight, so let's bump it by a second 625# 626 my $start = DateCalc("00:00:01","$opt_offset days") || die "ERROR: Can't compute <$opt_offset> days\n"; 627 my $stop = DateCalc($start ,"+ $opt_days days") || die "ERROR: Can't compute <$opt_days> days\n"; 628 629# 630# if days==0, back start time up by a minute to try and get only channels 631# 632 $start = DateCalc($start,"- 1 minute") if $opt_days==0; 633 634 die "ERROR: start($start) before stop($stop)\n" unless $stop gt $start; 635 636 $dd_start=UnixDate(Date_ConvTZ($start,offset_to_gmt($opt_tz_offset),"UTC"),"%Y-%m-%dT%H:%M:%SZ"); 637 $dd_stop =UnixDate(Date_ConvTZ($stop ,offset_to_gmt($opt_tz_offset),"UTC"),"%Y-%m-%dT%H:%M:%SZ"); 638 $dd_start=(' 'x$opt_padd).$dd_start if $opt_padd; 639 640 print STDERR "dd_start: $start,$dd_start\n" if $DEBUG; 641 print STDERR "dd_stop : $stop,$dd_stop\n" if $DEBUG; 642} # compute date 643 644# 645# open dd data file (temp, or created) 646# 647if ($opt_reprocess) 648{ 649 die "ERROR: $opt_dd_data file not found\n" unless -e $opt_dd_data; 650 $dd_data_name = $opt_dd_data; 651 $dd_data = new IO::File("<$dd_data_name"); 652 $dd_data_size= -s $dd_data; 653 654} 655else 656{ 657# 658# get DD data 659# 660 # 661 # open file to store DD XML 662 # 663 if ($opt_dd_data) 664 { 665 $dd_data_name = $opt_dd_data; 666 $dd_data = new IO::File("+>$dd_data_name"); 667 } 668 else 669 { 670 ($dd_data,$dd_data_name) = tempfile('tv_grab_na_dd_XXXX', 671 DIR => File::Spec->tmpdir(), 672 SUFFIX => '.tmp', 673 UNLINK=>($DEBUG ? 0 : 1)); 674 } 675 676 die "ERROR: Unable to open dd_data file <$dd_data_name>" unless defined $dd_data; 677 678# 679# Prompt for password (if needed) 680# 681 $dd_pass=~s/^\s//g; 682 my $local_pass=$dd_pass; 683 $local_pass=ask_password("Password for $dd_user: ") 684 unless length $local_pass; 685 686# 687# Zap2IT's servers have a bug that causes errors when certain fields span IP packets. 688# This is causing many users to report "BAD DATE" errors, and the Zap2IT servers guessing dates. 689# 690# Old versions of SOAP::Lite generated envelopes with 285 bytes of schema. 691# Current SOAP::Lite generates 397 bytes! 692# This hack seems to reduce the envelope to 276 bytes. Hopefully it will prevent the problem! 693# 694# Not sure if the Data Direct servers have the same problem, but why take a chance 695# 696 no warnings 'redefine'; # never warn on the SOAP redefine 697 sub SOAP::Serializer::register_ns { return 0; } 698 699# 700# Fetch data 701# 702 sub SOAP::Transport::HTTP::Client::get_basic_credentials 703 { 704 return "$dd_user" => "$local_pass"; 705 } 706 707 my $dd_service='http://dd.schedulesdirect.org/tech/tmsdatadirect/schedulesdirect/tvDataDelivery.wsdl'; 708 $dd_service=$ENV{DD_SERVICE} if exists $ENV{DD_SERVICE}; # used for testing 709 710 my $proxy='http://localhost/'; 711 if (exists $ENV{HTTP_PROXY}) 712 { 713 $proxy=$ENV{HTTP_PROXY}; 714 } 715 716 my $soap= SOAP::Lite 717 -> service($dd_service) 718 -> outputxml('true') 719 -> proxy($proxy, options => {compress_threshold => 10000, 720 timeout => 420}); 721 722 $opt_agent='/'.$opt_agent if length($opt_agent)>1; 723 $soap->transport->agent("xmltv/$XMLTV::VERSION".$opt_agent); 724 725 if ($opt_list_times) 726 { 727 local $_=$soap->acknowledge; 728 printf STDERR "%-15s|%s\n","blockedTime" ,$1 if /<blockedTime>(.+)<.blockedTime>/m; 729 printf STDERR "%-15s|%s\n","suggestedTime",$1 if /<suggestedTime>(.+)<.suggestedTime>/m; 730 } 731 732 print STDERR "Fetching from ",($ENV{DD_SERVICE}?$dd_service:"Schedules Direct") unless $opt_quiet; 733 print STDERR "\n dd_data is in $dd_data_name\n" if $DEBUG || $opt_dd_data; 734 735 my $time=time(); 736 my $raw_data=$soap->download($dd_start,$dd_stop); 737 738# 739# detect non-xml error messages 740# 741 die "Transport ERROR: $raw_data\n" if (! $soap->transport->is_success && 742 substr($raw_data,0,1) eq '>'); 743 744# 745# Sometimes Zap2IT allows bad charcters 0x127-0x255 to sneak through. 746# This causes TWIG to die... let's drop them if asked 747# 748 if ($opt_dropbadchar) { 749 print STDERR "Filtering Bad Characters\n" unless $opt_quiet; 750 $raw_data =~ s/[\x80-\xff]|se\&Ga|ay\&Les|\& //g; 751 } 752 753 if ($opt_down_only) { # --download only exits before normal password check 754 if ($raw_data =~ /HTTP Status 401/g) { 755 die "\n\nERROR: Login failure from Schedules Direct. Check user/password or try again later\n"; 756 } 757 } 758 759 $dd_data->print($raw_data); 760 $dd_data->flush; 761 $dd_data_size= -s $dd_data; 762 undef $raw_data; 763 764 die 'ERROR: got empty result from SOAP call' if $dd_data_size == 0; 765 unless ($opt_quiet) 766 { 767 $time = int(time() - $time); 768 printf STDERR " Fetched %d k/bytes in %d seconds\n",$dd_data_size/1024,$time; 769 } 770} # get data 771 772# 773# quit if --download-only 774# 775exit(0) if $opt_down_only; 776 777# 778# load supporting details 779# 780my $found_fault=0; 781my $twig=XML::Twig->new( 782 twig_roots => { HTML => 1, message => 1, xtvd =>1, 'SOAP-ENV:Fault' => 1 }, 783 twig_handlers => 784 { 785 HTML => sub { 786 die "ERROR: FETCH ERROR".$_->first_child_text; 787 }, 788 xtvd => sub { 789 $dd_schema=$_->att('schemaVersion'); 790 die "ERROR: did not see schemaVersion attribute in <xtvd>" 791 if not defined $dd_schema; 792 $_->twig->purge; 793 return 0; 794 }, 795 796 message => sub { 797 push @messages, $_->first_child_text; 798 $_->twig->purge; 799 return 0; 800 }, 801 802 stations => sub { $_->twig->purge; return 0;}, 803 station => sub { 804 my $hash=$_->simplify; 805 $station{$_->att('id')}=$hash; 806 $_->twig->purge; 807 return 0; 808 }, 809 lineups => sub { $_->twig->purge; return 0;}, 810 lineup => sub { 811 my $hash = $_->simplify; 812 my $name = $_->att('userLineupName'); 813 $name = $_->att('name') unless defined $name; 814 my $id = $_->att('id'); 815# 816# make sure map is a hash, even if only one station 817# 818 $hash->{map}=[$hash->{map}] if ref($hash->{map}) eq 'HASH'; 819# 820# add sub-channels if needed 821# 822 foreach (@{$hash->{map}}) { 823 $_->{channel}.="-".$_->{channelMinor} if exists $_->{channelMinor}; 824 } 825 826 $hash->{orig_id}=$name; 827 $hash->{name} =$name; 828 if (exists $lineups{$name}) 829 { 830 $name.='-2'; # deal with dupe names 831 } 832# 833# note. special processing for dd_schema 1.2 -> 1.3 conversion 834# 835 if ($id) 836 { 837 $old_lineups{$name}=$id; 838 $lineups{$id}=$hash; 839 } 840 else 841 { 842 $lineups{$name}=$hash; 843 } 844 845 $_->twig->purge; 846 return 0; 847 }, 848 programs=> sub { $_->twig->purge; return 0;}, 849 program => sub { 850 my $hash=$_->simplify; 851 852 if ($opt_low_mem) # only store title/subtitle 853 { 854 $program{$_->att('id')}{title}=$hash->{title}; 855 $program{$_->att('id')}{'subtitle'}=$hash->{subtitle} if exists $hash->{subtitle}; 856 $program{$_->att('id')}{'originalAirDate'}=$hash->{originalAirDate} if exists $hash->{originalAirDate}; 857 } 858 else 859 { 860 $program{$_->att('id')}=$hash; 861 } 862 $_->twig->purge; 863 return 0; 864 }, 865 productionCrew => sub { $_->twig->purge; return 0;}, 866 crew => sub { 867 unless ($opt_low_mem) 868 { 869 my $hash=$_->simplify; 870 $crew{$_->att('program')}=$hash; 871 } 872 $_->twig->purge; 873 return 0; 874 }, 875 genres => sub { $_->twig->purge; return 0;}, 876 programGenre => sub { 877 unless ($opt_low_mem) 878 { 879 my $hash=$_->simplify; 880 $programGenre{$_->att('program')}=$hash; 881 } 882 $_->twig->purge; 883 return 0; 884 }, 885 schedule => sub { 886 my $twig=$_; 887 push @schedules,$twig->simplify; 888 $_->twig->purge; 889 return 0; 890 }, 891 faultstring => sub { 892 printf STDERR "\nFAULT: %s\n",$_->first_child_text; 893 $_->twig->purge; 894 $found_fault=1; 895 return 1; 896 }, 897 _all_ => sub { # for some reason this is not being processed last, can't do the purge 898 unless ( $opt_quiet || $count++ % 1000 ) 899 { 900 if ($bar) { $bar->update(tell($dd_data)) } 901 else { print STDERR "." }; 902 } 903 return 0; 904 }, 905 } # end of handlers 906 ); 907 908unless ($opt_quiet) 909{ 910 $bar = new XMLTV::ProgressBar('loading data',$dd_data_size+1); 911} 912seek($dd_data,0,0); #rewind 913eval { $twig->parse( $dd_data ) }; 914 915if ($@) { 916# 917# Sometimes when an error occurs SD-DD generates BAD XML. 918# Before displaying a non-user-friendly message, let's see if SD-DD knows it has a problem 919# 920 my $xml=""; 921 seek($dd_data,0,0); #rewind 922 map {$xml .= $_} <$dd_data>; 923 if ($xml =~ /HTTP Status 401/g) 924 { 925 die "\n\nERROR: Login failure from Schedules Direct. Check user/password or try again later\n"; 926 } 927 928 if ($xml =~ /\<faultstring>(.+)\<.faultstring>/g) 929 { 930 my $faultstring =$1; 931 my ($faultnumber)= $xml =~ /\<faultnumber>(.+)\<\/faultnumber>/g; 932 my $faultcode = join(" / ",$xml =~ /\<faultcode(.+)>(.+)\<\/faultcode>/g); 933 die "\nERROR: Error Message received from Schedules Direct. 934 message: $faultstring 935 code : $faultcode 936 number : $faultnumber 937 This is probably a known issue, please try again later. If the problem 938 persists, check the XMLTV-USERS list or the Schedules Direct forums for known issues 939 and assistance.\n\n"; 940 } # faulstring 941# let's not display this.. if the xml is big, can be trouble. 942# warn "\nWARNING: error parsing DD xml: $@\nPartial XML follows:\n$xml\n"; 943 warn "\nWARNING: error parsing DD xml: $@\n"; 944 my $first_line = 1; 945 if ($@ =~ /at line (\d+)/) { $first_line = $1 } 946 die "\nERROR: Bad XML from DD, cannot continue. Consider using --dropbadchar or Capture xml with --dd-data\n"; 947} 948 949 950$bar->update($dd_data_size+1) if $bar; 951$bar->finish() if $bar; 952 953$twig=undef; # destroy twig (just in case) 954 955# 956# print any messages 957# 958foreach (@messages) 959{ 960 next if $opt_quiet && /^Your subscription will expire/; 961 print STDERR "NOTE: $_\n"; 962} 963 964die "ERROR: 965*** FAULT Message detected. See message above. 966*** This is probably a known issue, please try again later. If the problem 967*** persists, check the XMLTV-USERS list or the Schedules Direct web page for 968*** known issues and assistance.\n\n" if $found_fault; 969 970die "ERROR: did not see <xtvd> element in downloaded content\n" if not defined $dd_schema; 971warn "WARNING: DD Schema # is $dd_schema, check for upgrade\n" if $dd_schema > 1.3; 972 973 974 975# 976# --list-lineup mode 977# 978if ($opt_list_lineups) 979{ 980 my $id_len=2; 981 my $type_len=4; 982 my $orig_len=6; 983 my $dev_len=6; 984 for my $id (sort keys %lineups) 985 { 986 my $len=length($id); 987 $id_len=$len if $len>$id_len; 988 989 $len=length($lineups{$id}{type}||''); 990 $type_len=$len if $len>$type_len; 991 992 $len=length($lineups{$id}{orig_id}||''); 993 $orig_len=$len if $len>$orig_len; 994 995 $len=length($lineups{$id}{device}||''); 996 $dev_len=$len if $len>$dev_len; 997 998 } 999 1000 1001 printf STDOUT "%-${id_len}s|%-6s|%-${type_len}s|%-${orig_len}s|%-${dev_len}s|%s\n", 1002 "Lineup ID", 1003 "Postal", 1004 "Type", 1005 "OrigID", 1006 "Device", 1007 "Location"; 1008 for my $id (sort keys %lineups) 1009 { 1010 printf STDOUT "%-${id_len}s|%-6s|%-${type_len}s|%-${orig_len}s|%-${dev_len}s|%s\n",$id, 1011 ,$lineups{$id}{postalCode}||'', 1012 ,$lineups{$id}{type}||'', 1013 ,$lineups{$id}{orig_id}||'', 1014 ,$lineups{$id}{device}||'', 1015 ,$lineups{$id}{location}||'', 1016 } 1017 exit 0; 1018} 1019 1020# 1021# --configure stage2, process channel list 1022# 1023if ($opt_configure) 1024{ 1025 my %chan_found=(); 1026 $dd_lineup=$old_lineups{$dd_lineup} if exists $old_lineups{$dd_lineup}; 1027 $dd_lineup=(sort keys %lineups)[0] unless exists $lineups{$dd_lineup}; 1028 if (! $opt_auto_config) 1029 { 1030 my @choices=map sprintf("%s|%s,%s",$_, 1031 $lineups{$_}{name}, 1032 $lineups{$_}{type}), 1033 sort keys %lineups; 1034 my $val=sprintf("%s|%s,%s",$dd_lineup, 1035 $lineups{$dd_lineup}{name}, 1036 $lineups{$dd_lineup}{type}); 1037 1038 $val = ask_choice("\nWhich Lineup? ($dd_lineup)",$val,@choices); 1039 $dd_lineup = (split(/\|/,$val))[0]; 1040 } # !opt_auto_config 1041 1042 $opt_auto_config='add' if !$opt_auto_config && !ask_boolean(" 1043The preferred method for controlling the channel lineup is through 1044the Schedules Direct web site, but you can omit channels here as well. 1045Do you want to skip some channels?",0); 1046 1047 print "\n"; 1048 1049 # If the user expressed a default preference 1050 if ($opt_auto_config) 1051 { 1052 # Either add all the new channels 1053 if ($opt_auto_config eq 'add') 1054 { 1055 foreach (@{$lineups{$dd_lineup}{map}}) 1056 { 1057 unless ($station{$_->{station}}{callSign}) 1058 { 1059 print STDERR "Warning $_->{channel} has no callsign. Skipping\n"; 1060 next; 1061 } 1062 my $key1=sprintf("%s %s",$_->{channel}, 1063 $station{$_->{station}}{callSign}); 1064 if (not defined $chan_config{$key1}) { 1065 print STDERR "Adding new channel: $key1\n"; 1066 $chan_config{$key1}=1; 1067 } 1068 } 1069 } 1070 # or ignore them all 1071 else 1072 { 1073 foreach (@{$lineups{$dd_lineup}{map}}) 1074 { 1075 my $key2=sprintf("%s %s",$_->{channel}, 1076 $station{$_->{station}}{callSign}); 1077 if (not defined $chan_config{$key2}) { 1078 print STDERR "Ignoring new channel: (see docs about bandwidth issues) $key2\n"; 1079 $chan_config{$key2}=0; 1080 } 1081 } 1082 } 1083 } # auto config 1084 else # There was no default for new channels, so we ask the user 1085 { 1086 # Construct the questions 1087 my @questions; 1088 foreach (@{$lineups{$dd_lineup}{map}}) 1089 { 1090 my $key3=sprintf("%s %s",$_->{channel}, 1091 $station{$_->{station}}{callSign}); 1092 1093 push @questions, "Add channel $key3?"; 1094 } 1095 # Ask the questions 1096 my @answers = ask_many_boolean( 1, @questions ); 1097 # Save the answers 1098 my $i=0; 1099 foreach (@{$lineups{$dd_lineup}{map}}) 1100 { 1101 my $key4=sprintf("%s %s",$_->{channel}, 1102 $station{$_->{station}}{callSign}); 1103 1104 $chan_config{$key4} = $answers[$i]; 1105 $i++; 1106 } 1107 # 1108 # ask about auto-config for the config file 1109 # 1110 $opt_auto_config=0; 1111 if (ask_boolean("Lineups change periodically. The default for new stations is to notify you.\n". 1112 "Do you want new stations to be automatically added?")) { 1113 $opt_auto_config="add"; 1114 } 1115 elsif (ask_boolean("Do you want new stations to be ignored?")) { 1116 $opt_auto_config="ignore"; 1117 } 1118 } # no --auto-config during configure 1119 1120 1121# 1122# Write the config file 1123# 1124 open(CONF,">$config_file") or die "ERROR: can't open config file: $config_file\n"; 1125 print CONF "username: $dd_user\n"; 1126 print CONF "password: $dd_pass\n" if $dd_pass; 1127 print CONF "timeoffset: $opt_tz_offset\n"; 1128 print CONF "lineup: $dd_lineup\n"; 1129 print CONF "auto-config: $opt_auto_config\n" if $opt_auto_config; 1130 1131 foreach (@{$lineups{$dd_lineup}{map}}) 1132 { 1133 my $key5=sprintf("%s %s",$_->{channel}, 1134 $station{$_->{station}}{callSign}); 1135 print CONF ( $chan_config{$key5} ? '' : 'not ' ), "channel: $key5\n"; 1136 $chan_found{$key5} = 1; 1137 } 1138 1139 foreach (sort keys %chan_config) 1140 { 1141 next if $chan_found{$_}; 1142 print STDERR "Channel '$_' no longer exists\n"; 1143 } 1144 close CONF; 1145 say( 'Configuration complete!' ); 1146 exit 0; 1147} # --configure channel list 1148 1149# 1150# Make sure we have a valid lineup 1151# 1152if ( exists $old_lineups{$dd_lineup} ) 1153{ 1154 print STDERR "WARNING: lineup ID has changed, please re-run configure\n"; 1155 $dd_lineup=$old_lineups{$dd_lineup}; 1156} 1157 1158die "ERROR: Lineup ($dd_lineup} not found in data\n" unless exists $lineups{$dd_lineup}; 1159 1160 1161# 1162# Look for icons 1163# 1164if (-d "$SHARE_DIR/icons") 1165{ 1166 foreach (<$SHARE_DIR/icons/*>) 1167 { 1168 if (m!^.+/(.+?)\.!) 1169 { 1170 my $callsign=$1; 1171 my $uri=$_; 1172 1173 next if /url$/i && exists $icons{$callsign}; 1174 1175 if (/url$/i) 1176 { 1177 open(FILE,$uri) || die "ERROR: opening icon file $uri\n"; 1178 $uri=<FILE>; 1179 close FILE; 1180 chomp($uri); 1181 } 1182 else 1183 { 1184# $uri=~s!/!\\!g if $^O=~/win/i; 1185 $uri="file://".$uri; 1186 } 1187 $icons{$callsign}=[ {src => $uri } ], 1188 } 1189 } 1190} 1191 1192# 1193# open output file 1194# 1195my %w_args; 1196my $writer; 1197if (defined $opt_output) { 1198 my $fh = new IO::File(">$opt_output"); 1199 die "ERROR: cannot write to $opt_output: $!" if not defined $fh; 1200 $w_args{OUTPUT} = $fh; 1201 } 1202$w_args{encoding} = 'ISO-8859-1'; 1203 1204$writer = new XMLTV::Writer(%w_args); 1205$writer->start( { 1206 'source-info-name' => 'Schedules Direct', 1207 'source-info-url' => 'http://www.schedulesdirect.org/', 1208 'generator-info-name' => 'XMLTV/$Id: tv_grab_na_dd.in,v 1.93 2016/03/13 08:06:09 rmeden Exp $', 1209 'generator-info-url' => 'http://www.xmltv.org/', 1210 }); 1211 1212 1213# 1214# write stations, removing those we don't care about 1215# 1216my %seen_station; 1217my $got_multi_chan=0; 1218for my $map (@{$lineups{$dd_lineup}{map}}) 1219{ 1220 my $sid = $map->{station}; 1221 my $station=$station{$sid}; 1222 1223 unless ($station->{callSign}) 1224 { 1225 print STDERR "WARNING: Strange $map->{channel} has no callsign. Skipping\n"; 1226 next; 1227 } 1228 1229 if ($seen_station{$sid}++) 1230 { 1231 warn "WARNING: multiple channel mappings for '$station{$sid}{callSign}'\n"; 1232 $got_multi_chan=1; 1233 next; 1234 } 1235 my $myid = sprintf("I%d.labs.zap2it.com",$sid); 1236 my $key=sprintf("%s %s",$map->{channel},$station->{callSign}); 1237 1238# 1239# detect new channel (appending to config file is lame, but it works) 1240# 1241 unless (exists $chan_config{$key}) 1242 { 1243 $chan_config{$key}=0; # default ignore 1244 if ($opt_auto_config) 1245 { 1246 if ($opt_auto_config eq 'add') { 1247 $chan_config{$key}=1; 1248 print STDERR "Adding new channel: $key\n" unless $opt_quiet; 1249 } 1250 1251 open(CONF,">>$config_file") or die "ERROR: can't open config file for update: $config_file\n"; 1252 print CONF ( $chan_config{$key} ? '' : 'not ' ), "channel: $key\n"; 1253 close CONF; 1254 } 1255 else 1256 { 1257 print STDERR "WARNING: New channel, rerun --configure and/or change your Schedules Direct config: $key\n"; 1258 } 1259 } # new channel 1260 1261 next unless $chan_config{$key}; #skip? 1262 1263# 1264# generate tv_grab_na channel number 1265# 1266 if ($opt_old_chan_id) 1267 { 1268 $myid = sprintf("C%s%s.zap2it.com",$map->{channel},lc($station->{callSign})); 1269 } 1270 1271# 1272# Set display names: 1273# channel + callSign 1274# channel + callSign + lineup 1275# channel (only) 1276 my @names; 1277 push @names, [ sprintf("%s %s" ,$map->{channel},$station->{callSign})]; 1278 push @names, [ sprintf("%s %s %s",$map->{channel},$station->{callSign},$dd_lineup)]; 1279 push @names, [ $map->{channel} ]; 1280 1281# 1282# Now add display names for the fcc 1283# 1284 push @names,[sprintf("%d %s %s",$station->{fccChannelNumber}, 1285 $station->{callSign}, 1286 'fcc')] if exists $station->{fccChannelNumber}; 1287 1288# 1289# round up the rest we have 1290# 1291 for my $key (qw(callSign name affiliate)) 1292 { 1293 push @names,[ $station->{$key} ] if exists $station->{$key}; 1294 } 1295 1296 unless (@names) 1297 { 1298 warn "WARNING: No display names defined for channel $myid\n"; 1299 next; 1300 } 1301 1302 $writer->write_channel({ 'id' => $myid, 1303 'display-name' => \@names, 1304 'icon' => $icons{$station->{callSign}}, 1305 }); 1306 1307 $chan_id{$sid}=$myid; 1308} # output channels 1309warn "WARNING: Multiple channel mappings found, please adjust Schedules Direct lineup\n" if $got_multi_chan; 1310 1311# 1312# list channels only 1313# 1314if ($opt_list_channels) 1315{ 1316 $writer->end(); 1317 exit 0; 1318} 1319 1320# 1321# prepare to output schedule 1322# 1323unless ($opt_quiet) 1324{ 1325 $bar = new XMLTV::ProgressBar('Writing schedule',$#schedules+2); 1326} 1327 1328foreach $_ (@schedules) { 1329 $sched_count++; 1330 unless ( $opt_quiet || $sched_count % 10 ) 1331 { 1332 if ($bar) { $bar->update($sched_count) } 1333 else { print STDERR "." }; 1334 } 1335 1336 my %prog=(); 1337 my $ptr; 1338 1339# Skip programs not in our lineup and shows that start before our start time 1340# (dd provides shows in progress and it messes up splitting/merging) 1341 next unless exists $chan_id{$_->{station}}; 1342 next unless ($opt_notrim || $_->{time} ge $dd_start); 1343 1344# 1345# we generated a TZ offset a while back... this is twice as fast as Date::Manip! 1346# 1347 my $start = timegm( 1348 int( substr($_->{time},17,2) ), 1349 int( substr($_->{time},14,2) ), 1350 int( substr($_->{time},11,2) ), 1351 int( substr($_->{time},8,2) ), 1352 int( substr($_->{time},5,2) - 1 ), 1353 int( substr($_->{time},0,4) - 1900 ) ); 1354 my @gStart = gmtime( $start+$tz_offset ); 1355 $prog{start} = sprintf("%d%02d%02d%02d%02d%02d %s", 1356 $gStart[5] + 1900, 1357 $gStart[4] + 1, 1358 @gStart[3,2,1,0], 1359 $opt_tz_offset); 1360 1361 my $h = substr($_->{duration},2,2); 1362 my $m = substr($_->{duration},5,2); 1363 my $stop = $start + ( ( $h * 60 ) + $m ) * 60; 1364 my @gStop = gmtime( $stop+$tz_offset ); 1365 $prog{stop} = sprintf("%d%02d%02d%02d%02d%02d %s", 1366 $gStop[5] + 1900, 1367 $gStop[4] + 1, 1368 @gStop[3,2,1,0], 1369 $opt_tz_offset); 1370 1371 $prog{channel} = $chan_id{$_->{station}}; 1372 $prog{audio}{stereo}='stereo' if exists $_->{stereo}; 1373 $prog{audio}{stereo}=lc($_->{dolby}) if exists $_->{dolby}; 1374 $prog{'previously-shown'}={} if ! exists $_->{new} 1375 && $_->{program} =~ /^EP|^SH/; 1376 1377 push @{$prog{subtitles}},{type=>'teletext'} if exists $_->{closeCaptioned}; 1378 push @{$prog{subtitles}},{type=>'onscreen'} if exists $_->{subtitled}; 1379 1380 if (exists $_->{hdtv}) 1381 { 1382 $prog{video}{aspect}="16:9"; 1383 $prog{video}{quality}="HDTV"; 1384 } 1385 1386 if (exists $_->{tvRating}) 1387 { 1388 $_->{tvRating} =~ s/^TV/TV-/ unless $_->{tvRating} =~ /-/; 1389 push @{ $prog{rating} }, [$_->{tvRating},'VCHIP']; 1390 } 1391 1392# 1393# Note, provide multi-part info in xmltv_ns format for those apps that need it 1394# 1395 if (exists $_->{part}{number} && exists $_->{part}{total}) 1396 { 1397 push @{$prog{'episode-num'}}, [sprintf("..%d/%d", 1398 $_->{part}{number}-1, 1399 $_->{part}{total}), 1400 'xmltv_ns']; 1401 } 1402 1403# 1404# Store Gracenote Show ID, Episode ID, part in <episode-num> of "id.episode.part/total" 1405# using our own numbering system. 1406# 1407 if ( $_->{program} =~ /^(..\d{8})(\d{4})$/ ) 1408 { 1409 my $value =sprintf("%s.%s",$1,$2); 1410 $value.=sprintf(".%d/%d",$_->{part}{number}-1, 1411 $_->{part}{total}) if exists $_->{part}{number} && exists $_->{part}{total}; 1412 push @{$prog{'episode-num'}}, [$value,'dd_progid']; 1413 } 1414 1415 1416# 1417# add elements from program Genre tag 1418# Note: before program so Genra comes before ShowType in <category> 1419# 1420 if ($ptr = $programGenre{$_->{program}}) 1421 { 1422 if (ref $ptr->{genre} eq 'HASH') 1423 { 1424 push @{$prog{category}},[$ptr->{genre}{class},'en'] 1425 } 1426 else 1427 { 1428 foreach (@{$ptr->{genre}}) 1429 { 1430 push @{$prog{category}},[$_->{class},'en']; 1431 } 1432 } 1433 } # Genra items 1434 1435# 1436# add elements from program tag 1437# 1438# 1439 if (! ($ptr = $program{$_->{program}}) ) { 1440 warn "\nBad DD data: No program tag for $_->{program}\n"; 1441 next; 1442 } else { 1443 $prog{title} =[[$ptr->{title}, 'en']] if exists $ptr->{title}; 1444 $prog{'sub-title'} =[[$ptr->{subtitle} ,'en']] if exists $ptr->{subtitle}; 1445 $prog{desc} =[[$ptr->{description},'en']] if exists $ptr->{description}; 1446# 1447# Note: originalAirDate belongs in the "previosly-shown" tag. 1448# It was put in {date} in error. Let's keep it in {date} for compatibility 1449# reasons. If we have a copyright date, we change it anyway 1450# 1451# Note, {original-air-date} has a different meaning for SH episodes 1452# 1453 if ( exists $ptr->{originalAirDate} && $_->{program} !~ /^SH/) 1454 { 1455 $prog{'previously-shown'}{start}=$ptr->{originalAirDate}.'000000'; 1456 1457 $prog{'previously-shown'}{start}=~ s/-//g; 1458 } 1459 1460 $prog{date} =$ptr->{originalAirDate} if exists $ptr->{originalAirDate} 1461 && $_->{program} =~ /^EP/; 1462 $prog{date} =$ptr->{year} if exists $ptr->{year}; 1463 $prog{date} =~ s/-//g if exists $prog{date}; 1464 1465 1466 if (exists $ptr->{runTime}) 1467 { 1468 if ($ptr->{runTime} !~ /PT\d\dH\d\dM/) 1469 { 1470 printf STDERR "WARNING: bad runTime <%s> detected for %s\n", 1471 $ptr->{runTime},$_->{program} unless $opt_quiet; 1472 } 1473 else 1474 { 1475 $prog{length} = substr($ptr->{runTime},2,2)*3600+ 1476 substr($ptr->{runTime},5,2)*60; 1477 } 1478 } 1479 1480 if (exists $ptr->{advisories}) 1481 { 1482 if (ref $ptr->{advisories}{advisory}) 1483 { 1484 for my $val (@{$ptr->{advisories}{advisory}}) 1485 { 1486 push @{$prog{rating}},[$val,'advisory']; 1487 } 1488 } 1489 else 1490 { 1491 push @{$prog{rating}},[$ptr->{advisories}{advisory},'advisory']; 1492 } 1493 } 1494 1495 if (exists $ptr->{mpaaRating}) 1496 { 1497 if ($ptr->{mpaaRating} =~ /\*/) 1498 { 1499 printf STDERR "WARNING: bad mpaaRating <%s> detected for %s.\n", 1500 $ptr->{mpaaRating},$_->{program} unless $opt_quiet; 1501 } 1502 else 1503 { 1504 push @{ $prog{rating} }, [$ptr->{mpaaRating},'MPAA']; 1505 } 1506 } 1507 1508 if (exists $ptr->{colorCode}) 1509 { 1510 $prog{video}{colour}=1; # too bad this just wants a boolean... 1511 $prog{video}{colour}=0 if $ptr->{colorCode} =~ /^B/i; 1512 } 1513 1514 if (exists $ptr->{starRating}) 1515 { 1516 if ($ptr->{starRating} =~ /\a/) 1517 { 1518 printf STDERR "WARNING: bad starRating detected for %s.\n", 1519 $ptr->{starRating},$_->{program} unless $opt_quiet; 1520 } 1521 else 1522 { 1523 my $star=length($ptr->{starRating}); 1524 if ($ptr->{starRating} =~ /\+$/) 1525 { 1526 $star -= .5; 1527 $prog{'star-rating'}=[sprintf("%1.1f/%d",$star,4)]; 1528 } 1529 else 1530 { 1531 $prog{'star-rating'}=[sprintf("%d/%d",$star,4)]; 1532 } 1533 } 1534 } # star rating 1535 1536# 1537# if a show is new, let's make sure we know it (yes, we lose originalAirDate) 1538# 1539 delete $prog{'previously-shown'} if exists $_->{new}; 1540 1541 1542 1543 push @{$prog{category}}, ['Movie','en' ] if $_->{program}=~ /^MV/; 1544 push @{$prog{category}}, ['Sports','en' ] if $_->{program}=~ /^SP/; 1545 push @{$prog{category}}, [$ptr->{showType} ,'en' ] if exists $ptr->{showType}; 1546 1547 push @{$prog{'episode-num'}}, [$ptr->{syndicatedEpisodeNumber},'onscreen'] if exists $ptr->{syndicatedEpisodeNumber}; 1548 } # %program items 1549 1550 1551# 1552# add elements from crew tag 1553# 1554 if ($ptr = $crew{$_->{program}}) 1555 { 1556 my ( @director, @actor, @writer, @adapter, @producer, 1557 @presenter, @commentator, @guest ); 1558 $ptr->{member}=[$ptr->{member}] if (ref $ptr->{member} eq 'HASH'); 1559 foreach (@{$ptr->{member}}) 1560 { 1561 next unless exists $_->{role}; 1562 my $name=""; 1563 $name.=$_->{givenname}." " unless ref $_->{givenname}; 1564 $name.=$_->{surname} unless ref $_->{surname}; 1565 push @actor ,$name if $_->{role} eq 'Actor'; 1566 push @guest ,$name if $_->{role} eq 'Guest Star'; 1567 push @presenter ,$name if $_->{role} eq 'Host'; 1568 push @director ,$name if $_->{role} eq 'Director'; 1569 push @producer ,$name if $_->{role} eq 'Executive Producter'; 1570 push @producer ,$name if $_->{role} eq 'Producer'; 1571 push @writer ,$name if $_->{role} eq 'Writer'; 1572 } 1573 1574 $prog{credits}{actor }=\@actor if @actor ; 1575 $prog{credits}{director }=\@director if @director; 1576 $prog{credits}{guest }=\@guest if @guest; 1577 $prog{credits}{presenter}=\@presenter if @presenter; 1578 $prog{credits}{producer }=\@producer if @producer; 1579 $prog{credits}{writer }=\@writer if @writer; 1580 } #crew items 1581 1582# 1583# write record 1584# 1585 $writer->write_programme(\%prog); 1586}; # schedule loop 1587 1588 $bar->update($#schedules+1) if $bar; 1589 $bar->finish() if $bar; 1590 1591 $writer->end(); 1592 1593 printf STDERR "\nDownloaded %d programs in %d seconds\n",$sched_count,time()-$start_time 1594 unless $opt_quiet; 1595 1596 1597exit(0); 1598 1599